]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/pythia6115.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Removing semaphore .done files.
[u/mrichter/AliRoot.git] / DPMJET / pythia6115.f
CommitLineData
d30b8254 1C*********************************************************************
2C*********************************************************************
3C* **
4C* March 1997 **
5C* **
6C* The Lund Monte Carlo for Hadronic Processes **
7C* **
8C* PYTHIA version 6.1 **
9C* **
10C* Torbjorn Sjostrand **
11C* Department of Theoretical Physics 2 **
12C* Lund University **
13C* Solvegatan 14A, S-223 62 Lund, Sweden **
14C* phone +46 - 46 - 222 48 16 **
15C* E-mail torbjorn@thep.lu.se **
16C* **
17C* SUSY parts by **
18C* Stephen Mrenna **
19C* Argonne National Laboratory **
20C* 9700 South Cass Avenue, Argonne, IL 60439, USA **
21C* phone + 1 - 630 - 252 - 7615 **
22C* E-mail mrenna@hep.anl.gov **
23C* **
24C* Several parts are written by Hans-Uno Bengtsson **
25C* PYSHOW is written together with Mats Bengtsson **
26C* advanced popcorn baryon production written by Patrik Eden **
27C* CTEQ 3 parton distributions are by the CTEQ collaboration **
28C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
29C* SaS photon parton distributions together with Gerhard Schuler **
30C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
31C* MSSM Higgs mass calculation code by M. Carena, **
32C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
33C* PYGAUS adapted from CERN library (K.S. Kolbig) **
34C* **
35C* The latest program version and documentation is found on WWW **
36C* http://www.thep.lu.se/tf2/staff/torbjorn/Pythia.html **
37C* **
38C* Copyright Torbjorn Sjostrand, Lund 1997 **
39C* **
40C*********************************************************************
41C*********************************************************************
42C *
43C List of subprograms in order of appearance, with main purpose *
44C (S = subroutine, F = function, B = block data) *
45C *
46C B PYDATA to contain all default values *
47C S PYTEST to test the proper functioning of the package *
48C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
49C *
50C S PYINIT to administer the initialization procedure *
51C S PYEVNT to administer the generation of an event *
52C S PYSTAT to print cross-section and other information *
53C S PYINRE to initialize treatment of resonances *
54C S PYINBM to read in beam, target and frame choices *
55C S PYINKI to initialize kinematics of incoming particles *
56C S PYINPR to set up the selection of included processes *
57C S PYXTOT to give total, elastic and diffractive cross-sect. *
58C S PYMAXI to find differential cross-section maxima *
59C S PYPILE to select multiplicity of pileup events *
60C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
61C S PYRAND to select subprocess and kinematics for event *
62C S PYSCAT to set up kinematics and colour flow of event *
63C S PYSSPA to simulate initial state spacelike showers *
64C S PYRESD to perform resonance decays *
65C S PYMULT to generate multiple interactions *
66C S PYREMN to add on target remnants *
67C S PYDIFF to set up kinematics for diffractive events *
68C S PYDOCU to compute cross-sections and handle documentation *
69C S PYFRAM to perform boosts between different frames *
70C S PYWIDT to calculate full and partial widths of resonances *
71C S PYOFSH to calculate partial width into off-shell channels *
72C S PYRECO to handle colour reconnection in W+W- events *
73C S PYKLIM to calculate borders of allowed kinematical region *
74C S PYKMAP to construct value of kinematical variable *
75C S PYSIGH to calculate differential cross-sections *
76C S PYPDFU to evaluate parton distributions *
77C S PYPDFL to evaluate parton distributions at low x and Q^2 *
78C S PYPDEL to evaluate electron parton distributions *
79C S PYPDGA to evaluate photon parton distributions (generic) *
80C S PYGGAM to evaluate photon parton distributions (SaS sets) *
81C S PYGVMD to evaluate VMD part of photon parton distributions *
82C S PYGANO to evaluate anomalous part of photon pdf's *
83C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
84C S PYGDIR to evaluate direct contribution to photon pdf's *
85C S PYPDPI to evaluate pion parton distributions *
86C S PYPDPR to evaluate proton parton distributions *
87C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
88C S PYGRVL to evaluate the GRV 94L pronton parton distributions *
89C S PYGRVM to evaluate the GRV 94M pronton parton distributions *
90C S PYGRVD to evaluate the GRV 94D pronton parton distributions *
91C F PYGRVV auxiliary to the PYGRV* routines *
92C F PYGRVW auxiliary to the PYGRV* routines *
93C F PYGRVS auxiliary to the PYGRV* routines *
94C F PYHFTH to evaluate threshold factor for heavy flavour *
95C S PYSPLI to find flavours left in hadron when one removed *
96C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
97C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
98C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
99C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
100C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
101C *
102C S PYMSIN to initialize the supersymmetry simulation *
103C S PYAPPS to determine MSSM parameters from SUGRA input *
104C F PYRNMQ to determine running quark masses *
105C F PYRNMT to determine running top mass *
106C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
107C S PYINOM to calculate neutralino/chargino mass eigenstates *
108C F PYRNM3 to determine running M3, gluino mass *
109C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
110C S PYHGGM to determine Higgs mass spectrum *
111C S PYSUBH to determine Higgs masses in the MSSM *
112C S PYPOLE to determine Higgs masses in the MSSM *
113C S PYVACU to determine Higgs masses in the MSSM *
114C S PYRGHM auxiliary to PYVACU *
115C S PYGFXX auxiliary to PYRGHM *
116C F PYFINT auxiliary to PYVACU *
117C F PYFISB auxiliary to PYFINT *
118C S PYSFDC to calculate sfermion decay partial widths *
119C S PYGLUI to calculate gluino decay partial widths *
120C S PYTBBN to calculate 3-body decay of gluino to neutralino *
121C S PYTBBC to calculate 3-body decay of gluino to chargino *
122C S PYNJDC to calculate neutralino decay partial widths *
123C S PYCJDC to calculate chargino decay partial widths *
124C F PYXXZ5 auxiliary for neutralino 3-body decay *
125C F PYXXW5 auxiliary for ino charge change 3-body decay *
126C F PYXXGA auxiliary for ino -> ino + gamma decay *
127C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
128C F PYX2XH auxiliary for ino -> ino + Higgs decay *
129C F PYXXZ2 auxiliary for chargino 3-body decay *
130C S PYHEXT to calculate non-SM Higgs decay partial widths *
131C F PYH2XX auxiliary for H -> ino + ino decay *
132C F PYGAUS to perform Gaussian integration *
133C F PYSIMP to perform Simpson integration *
134C F PYLAMF to evaluate the lambda kinematics function *
135C S PYTBDY to perform 3-body decay of gauginos *
136C *
137C S PY1ENT to fill one entry (= parton or particle) *
138C S PY2ENT to fill two entries *
139C S PY3ENT to fill three entries *
140C S PY4ENT to fill four entries *
141C S PYJOIN to connect entries with colour flow information *
142C S PYGIVE to fill (or query) commonblock variables *
143C S PYEXEC to administrate fragmentation and decay chain *
144C S PYPREP to rearrange showered partons along strings *
145C S PYSTRF to do string fragmentation of jet system *
146C S PYINDF to do independent fragmentation of one or many jets *
147C S PYDECY to do the decay of a particle *
148C S PYDCYK to select parton and hadron flavours in decays *
149C S PYKFDI to select parton and hadron flavours in fragm *
150C S PYNMES to select number of popcorn mesons *
151C S PYKFIN to calculate falvour prod. ratios from input params. *
152C S PYPTDI to select transverse momenta in fragm *
153C S PYZDIS to select longitudinal scaling variable in fragm *
154C S PYSHOW to do timelike parton shower evolution *
155C S PYBOEI to include Bose-Einstein effects (crudely) *
156C F PYMASS to give the mass of a particle or parton *
157C S PYNAME to give the name of a particle or parton *
158C F PYCHGE to give three times the electric charge *
159C F PYCOMP to compress standard KF flavour code to internal KC *
160C S PYERRM to write error messages and abort faulty run *
161C F PYALEM to give the alpha_electromagnetic value *
162C F PYALPS to give the alpha_strong value *
163C F PYANGL to give the angle from known x and y components *
164C F PYR to provide a random number generator *
165C S PYRGET to save the state of the random number generator *
166C S PYRSET to set the state of the random number generator *
167C S PYROBO to rotate and/or boost an event *
168C S PYEDIT to remove unwanted entries from record *
169C S PYLIST to list event record or particle data *
170C S PYLOGO to write a logo *
171C S PYUPDA to update particle data *
172C F PYK to provide integer-valued event information *
173C F PYP to provide real-valued event information *
174C S PYSPHE to perform sphericity analysis *
175C S PYTHRU to perform thrust analysis *
176C S PYCLUS to perform three-dimensional cluster analysis *
177C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
178C S PYJMAS to give high and low jet mass of event *
179C S PYFOWO to give Fox-Wolfram moments *
180C S PYTABU to analyze events, with tabular output *
181C *
182C S PYEEVT to administrate the generation of an e+e- event *
183C S PYXTEE to give the total cross-section at given CM energy *
184C S PYRADK to generate initial state photon radiation *
185C S PYXKFL to select flavour of primary qqbar pair *
186C S PYXJET to select (matrix element) jet multiplicity *
187C S PYX3JT to select kinematics of three-jet event *
188C S PYX4JT to select kinematics of four-jet event *
189C S PYXDIF to select angular orientation of event *
190C S PYONIA to perform generation of onium decay to gluons *
191C *
192C S PYBOOK to book a histogram *
193C S PYFILL to fill an entry in a histogram *
194C S PYFACT to multiply histogram contents by a factor *
195C S PYOPER to perform operations between histograms *
196C S PYHIST to print and reset all histograms *
197C S PYPLOT to print a single histogram *
198C S PYNULL to reset contents of a single histogram *
199C S PYDUMP to dump histogram contents onto a file *
200C *
201C S PYKCUT dummy routine for user kinematical cuts *
202C S PYEVWT dummy routine for weighting events *
203C S PYUPIN dummy routine to initialize a user process *
204C S PYUPEV dummy routine to generate a user process event *
205C S PDFSET dummy routine to be removed when using PDFLIB *
206C S STRUCTM dummy routine to be removed when using PDFLIB *
207C S PYTAUD dummy routine for interface to tau decay libraries *
208C S PYTIME dummy routine for giving date and time *
209C *
210C*********************************************************************
211
212C...PYDATA
213C...Default values for switches and parameters,
214C...and particle, decay and process data.
215
216 BLOCK DATA PYDATA
217
218C...Double precision and integer declarations.
219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
220 INTEGER PYK,PYCHGE,PYCOMP
221C...Commonblocks.
222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
224 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
225 COMMON/PYDAT4/CHAF(500,2)
226 CHARACTER CHAF*16
227 COMMON/PYDATR/MRPY(6),RRPY(100)
228 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
229 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
230 COMMON/PYINT1/MINT(400),VINT(400)
231 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
232 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
233 COMMON/PYINT4/MWID(500),WIDS(500,5)
234 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
235 COMMON/PYINT6/PROC(0:500)
236 CHARACTER PROC*28
237 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
238 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
239 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
240 &SFMIX(16,4)
241 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
242 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
243 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
244 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
245
246C...PYDAT1, containing status codes and most parameters.
247 DATA MSTU/
248 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
249 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
250 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
251 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
252 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
253 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
254 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
255 7 30*0,
256 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
257 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
258 & 80*0/
259 DATA PARU/
260 & 3.141592653589793D0, 6.283185307179586D0,
261 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
262 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
263 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
264 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
265 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
266 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
267 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
268 6 40*0D0,
269 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
270 & 0D0, 0D0, 0D0, 0D0, 0D0,
271 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
272 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
273 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
274 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
275 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
276 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
277 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
278 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
279 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
280 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
281 DATA MSTJ/
282 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
283 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
284 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
285 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
286 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
287 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
288 6 40*0,
289 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
290 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
291 2 80*0/
292 DATA PARJ/
293 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
294 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
295 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
296 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
297 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0,2.5D0,0.6D0,0D0,
298 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
299 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
300 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
301 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
302 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
303 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0, 0D0,
304 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
305 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
306 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
307 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
308 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
309 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
310 4 60*0D0/
311
312C...PYDAT2, with particle data and flavour treatment parameters.
313 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
314 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,
315 &8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,3*0,4,3*3,
316 &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,
317 &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,
318 &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,
319 &-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,
320 &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,
321 &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
322 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
323 &3*0,-1,4*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
324 &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
325 &6*1,6*0,2*1,165*0/
326 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
327 &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0,
328 &102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,
329 &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
330 DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
331 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
332 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
333 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
334 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
335 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
336 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
337 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
338 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
339 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
340 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
341 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
342 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
343 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
344 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
345 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
346 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
347 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
348 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
349 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
350 DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
351 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
352 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
353 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
354 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
355 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
356 DATA (PMAS(I,1),I= 1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0,
357 &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,
358 &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
359 &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0,
360 &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0,
361 &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0,
362 &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0,
363 &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0,
364 &1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,3.09688D0,3.5562D0,
365 &5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,5.3693D0,
366 &5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,9.9132D0,
367 &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0,
368 &0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
369 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
370 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
371 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
372 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
373 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
374 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
375 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0/
376 DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0,
377 &5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,5.84D0,7.00575D0,5.56725D0,
378 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
379 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
380 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
381 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
382 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
383 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
384 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
385 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
386 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
387 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
388 &4*400D0,163*0D0/
389 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0,
390 &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0,
391 &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0,
392 &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,
393 &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0,
394 &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,
395 &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,
396 &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,
397 &0.0394D0,4*0D0,0.036D0,0D0,0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,
398 &74*0D0,0.06D0,0.142D0,0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,
399 &0.287D0,0.09D0,0.25D0,0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,
400 &0D0,0.014D0,0.01D0,8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,
401 &0.053D0,3*0.05D0,0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,
402 &1D0,0D0,1D0,0D0,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/
403 DATA (PMAS(I,3),I= 1, 500)/5*0D0,14D0,16*0D0,24.78326D0,
404 &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0,
405 &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0,
406 &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,
407 &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
408 &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,
409 &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,
410 &3*0D0,2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,
411 &0.05D0,0D0,0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,
412 &0.4D0,0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,
413 &0.08D0,0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,
414 &2*0.3D0,0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,
415 &3*0D0,19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,
416 &0.00001D0,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*0D0/
417 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
418 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
419 &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
420 &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
421 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
422 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
423 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
424 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
425 DATA PARF/
426 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
427 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
428 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
429 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
430 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
431 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
432 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
433 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
434 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
435 9 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
436 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
437 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
438 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
439 3 60*0D0,
440 4 0.2D0, 0.5D0, 8*0D0,
441 5 1800*0D0/
442 DATA ((VCKM(I,J),J=1,4),I=1,4)/
443 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
444 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
445 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
446 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
447
448C...PYDAT3, with particle decay parameters and data.
449 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
450 &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1,
451 &0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,
452 &2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,
453 &1,0,4*1,163*0/
454 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
455 &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
456 &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
457 &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
458 &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
459 &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
460 &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
461 &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
462 &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
463 &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
464 &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
465 &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
466 &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
467 &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
468 &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
469 &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
470 &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
471 &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
472 &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
473 &2493,2496,163*0/
474 DATA (MDCY(I,3),I= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
475 &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18,
476 &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6,
477 &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0,
478 &1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,
479 &4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,
480 &1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,
481 &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
482 &15,0,2*4,3,2,163*0/
483 DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
484 &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
485 &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,2*-1,
486 &6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,197*1,2*-1,2*1,-1,20*1,
487 &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1,
488 &2*-1,1892*1,1503*0/
489 DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
490 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
491 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
492 &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0,
493 &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*0,12,2*42,2*11,9*42,0,2,3,
494 &15*0,4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,
495 &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,
496 &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
497 &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,
498 &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,
499 &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
500 &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,
501 &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
502 &4*32,2*4,5*0,828*53,1515*0/
503 DATA (BRAT(I) ,I= 1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0,
504 &33*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,0.003D0,
505 &0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,0.0071D0,
506 &0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,0.0034D0,0.08D0,
507 &0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,0.0067D0,0.0005D0,
508 &0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,0.00075D0,0.0001D0,
509 &0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,0.0004D0,0.0001D0,
510 &2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,0.00025D0,35*0D0,
511 &0.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0,
512 &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0,
513 &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0,
514 &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0,
515 &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0,
516 &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0,
517 &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0,
518 &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0,
519 &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0,
520 &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0,
521 &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0,
522 &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/
523 DATA (BRAT(I) ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0,
524 &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0,
525 &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0,
526 &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0,
527 &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0,
528 &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,
529 &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0,
530 &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0,
531 &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,
532 &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,
533 &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,
534 &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,
535 &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,
536 &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,
537 &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,
538 &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,
539 &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,
540 &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,
541 &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,
542 &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/
543 DATA (BRAT(I) ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0,
544 &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,
545 &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,
546 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,
547 &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,
548 &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,
549 &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,
550 &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,
551 &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,
552 &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
553 &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,
554 &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,
555 &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,
556 &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,
557 &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,
558 &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,
559 &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,
560 &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,
561 &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
562 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
563 DATA (BRAT(I) ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0,
564 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
565 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
566 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
567 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
568 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
569 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
570 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
571 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
572 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
573 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
574 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
575 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
576 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
577 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
578 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
579 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
580 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
581 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
582 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
583 DATA (BRAT(I) ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0,
584 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
585 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
586 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
587 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
588 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
589 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
590 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
591 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
592 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
593 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
594 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
595 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
596 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
597 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
598 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
599 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
600 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
601 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
602 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
603 DATA (BRAT(I) ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
604 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
605 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
606 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
607 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
608 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
609 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
610 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
611 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
612 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
613 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
614 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
615 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
616 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
617 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
618 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
619 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
620 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
621 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
622 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
623 DATA (BRAT(I) ,I=1448,1648)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
624 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
625 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
626 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
627 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
628 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
629 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
630 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
631 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
632 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
633 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
634 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
635 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
636 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
637 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
638 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
639 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
640 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
641 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
642 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
643 DATA (BRAT(I) ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0,
644 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0,
645 &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0,
646 &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0,
647 &1503*0D0/
648 DATA (KFDP(I,1),I= 1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
649 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
650 &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
651 &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
652 &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
653 &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,
654 &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
655 &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
656 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
657 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
658 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
659 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
660 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
661 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
662 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
663 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
664 &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
665 &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
666 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
667 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
668 DATA (KFDP(I,1),I= 376, 606)/1000003,-1000003,1000004,2000004,
669 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
670 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
671 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
672 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
673 &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
674 &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
675 &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
676 &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
677 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
678 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
679 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
680 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
681 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
682 &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
683 &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
684 &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
685 &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3,
686 &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7,
687 &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
688 DATA (KFDP(I,1),I= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
689 &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
690 &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
691 &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
692 &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
693 &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
694 &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
695 &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
696 &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
697 &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
698 &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
699 &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
700 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
701 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
702 &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
703 &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
704 &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
705 &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
706 &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
707 &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
708 DATA (KFDP(I,1),I=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
709 &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
710 &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
711 &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
712 &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
713 &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
714 &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
715 &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
716 &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
717 &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
718 &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
719 &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
720 &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
721 &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
722 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
723 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
724 &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
725 &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
726 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
727 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
728 DATA (KFDP(I,1),I=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
729 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
730 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
731 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
732 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
733 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
734 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
735 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
736 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
737 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
738 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
739 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
740 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
741 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
742 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
743 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
744 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
745 &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
746 &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
747 &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
748 DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006,
749 &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
750 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
751 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
752 &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
753 &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
754 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
755 &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
756 &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
757 &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
758 &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
759 &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
760 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
761 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
762 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
763 &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
764 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
765 &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
766 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
767 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
768 DATA (KFDP(I,1),I=1901,2095)/-1000037,1000037,-1000037,1000037,
769 &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
770 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
771 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
772 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
773 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
774 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
775 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
776 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
777 &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
778 &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
779 &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
780 &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
781 &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
782 &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
783 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
784 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
785 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
786 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
787 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
788 DATA (KFDP(I,1),I=2096,2323)/2000003,-2000003,1000004,-1000004,
789 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
790 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
791 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
792 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
793 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
794 &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
795 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
796 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
797 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
798 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
799 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
800 &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
801 &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
802 &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
803 &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
804 &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
805 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
806 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
807 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
808 DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006,
809 &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
810 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
811 &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
812 &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
813 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
814 &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
815 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
816 &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
817 &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
818 &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
819 &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
820 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
821 &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
822 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
823 &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
824 &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
825 &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
826 &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
827 &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
828 DATA (KFDP(I,2),I= 1, 337)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
829 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,4*1000006,3*7,
830 &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
831 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
832 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
833 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
834 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
835 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
836 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
837 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
838 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
839 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
840 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
841 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
842 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
843 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
844 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
845 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
846 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
847 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
848 DATA (KFDP(I,2),I= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
849 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
850 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
851 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
852 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
853 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
854 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
855 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
856 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
857 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
858 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
859 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
860 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
861 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
862 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
863 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
864 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
865 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
866 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
867 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
868 DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
869 &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
870 &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
871 &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
872 &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
873 &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
874 &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
875 &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
876 &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
877 &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
878 &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
879 &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
880 &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
881 &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
882 &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
883 &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
884 &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
885 &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
886 &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
887 &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
888 DATA (KFDP(I,2),I= 941,1318)/2*-15,211,213,20213,211,213,20213,
889 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
890 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
891 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
892 &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
893 &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
894 &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
895 &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
896 &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
897 &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
898 &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
899 &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
900 &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
901 &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
902 &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
903 &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
904 &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
905 &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
906 &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
907 &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/
908 DATA (KFDP(I,2),I=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
909 &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,
910 &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
911 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
912 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
913 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
914 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
915 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
916 &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
917 &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
918 &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
919 &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
920 &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
921 &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
922 &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
923 &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
924 &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,
925 &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24,
926 &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11,
927 &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
928 DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
929 &4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,
930 &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,
931 &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
932 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
933 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
934 &1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
935 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
936 &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
937 &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
938 &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,
939 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
940 &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
941 &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
942 &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
943 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
944 &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
945 &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
946 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
947 &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
948 DATA (KFDP(I,2),I=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
949 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
950 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
951 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
952 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
953 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
954 &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
955 &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25,
956 &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6,
957 &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
958 &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
959 &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
960 DATA (KFDP(I,3),I= 1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
961 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
962 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
963 &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
964 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
965 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
966 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
967 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
968 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
969 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
970 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
971 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
972 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
973 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
974 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
975 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
976 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
977 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
978 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
979 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
980 DATA (KFDP(I,3),I=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
981 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
982 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
983 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
984 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
985 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
986 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
987 &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
988 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
989 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
990 &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
991 &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
992 &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
993 &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
994 &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
995 &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
996 &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
997 &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
998 &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
999 &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
1000 DATA (KFDP(I,3),I=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
1001 &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
1002 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
1003 &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
1004 DATA (KFDP(I,4),I= 1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
1005 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1006 &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1007 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1008 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1009 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1010 &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
1011 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1012 &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
1013 &162*81,31*0,-211,111,2450*0/
1014 DATA (KFDP(I,5),I= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
1015 &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1016 &3*111,-211,111,3127*0/
1017
1018C...PYDAT4, with particle names (character strings).
1019 DATA (CHAF(I,1),I= 1, 190)/'d','u','s','c','b','t','b''','t''',
1020 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1021 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1022 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1023 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1024 &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
1025 &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
1026 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
1027 &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
1028 &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
1029 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
1030 &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
1031 &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
1032 &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
1033 &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
1034 &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
1035 &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
1036 &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
1037 &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
1038 &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
1039 DATA (CHAF(I,1),I= 191, 317)/'Sigma*_c+','Sigma_c++',
1040 &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
1041 &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
1042 &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
1043 &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
1044 &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1045 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1046 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1047 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1048 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1049 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1050 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1051 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1052 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1053 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1054 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1055 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1056 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1057 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1058 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
1059 DATA (CHAF(I,1),I= 318, 500)/'~chi_30','~chi_40','~chi_2+',
1060 &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
1061 &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
1062 &'nu*_e0',163*' '/
1063 DATA (CHAF(I,2),I= 1, 206)/'dbar','ubar','sbar','cbar','bbar',
1064 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1065 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1066 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1067 &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
1068 &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
1069 &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
1070 &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
1071 &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
1072 &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
1073 &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
1074 &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
1075 &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
1076 &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
1077 &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
1078 &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
1079 &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
1080 &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
1081 &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1082 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
1083 DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
1084 &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
1085 &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
1086 &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
1087 &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
1088 &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
1089 &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
1090 &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
1091 &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
1092 &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
1093 &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1094 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1095 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1096 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1097 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1098 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1099 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1100 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1101 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1102 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
1103 DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
1104 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1105 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1106
1107C...PYDATR, with initial values for the random number generator.
1108 DATA MRPY/19780503,0,0,97,33,0/
1109
1110C...Default values for allowed processes and kinematics constraints.
1111 DATA MSEL/1/
1112 DATA MSUB/500*0/
1113 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1114 &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
1115 &6*1,4*0,4*1,16*0/
1116 DATA CKIN/
1117 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1118 & 1.0D0, -10D0, 10D0, -10D0, 10D0,
1119 1 -10D0, 10D0, -10D0, 10D0, -10D0,
1120 1 10D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1121 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1122 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1123 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1124 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1125 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1126 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1127 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1128 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1129 6 140*0D0/
1130
1131C...Default values for main switches and parameters. Reset information.
1132 DATA (MSTP(I),I=1,100)/
1133 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1134 1 1, 0, 1, 0, 5, 0, 0, 0, 0, 0,
1135 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1136 3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0,
1137 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1138 5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7,
1139 6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0,
1140 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1141 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
1142 9 1, 4, 1, 2, 0, 0, 0, 0, 0, 0/
1143 DATA (MSTP(I),I=101,200)/
1144 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1145 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1146 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1147 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1148 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1149 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1150 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1151 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1152 8 6, 115, 1998, 01, 27, 0, 0, 0, 0, 0,
1153 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1154 DATA (PARP(I),I=1,100)/
1155 & 0.25D0, 10D0, 8*0D0,
1156 1 0D0, 0D0, 1.0D0, 0.01D0, 0.6D0, 1.0D0, 1.0D0, 3*0D0,
1157 2 10*0D0,
1158 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1159 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1160 5 1.0D0, 9*0D0,
1161 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1162 7 4.0D0, 0.25D0, 8*0D0,
1163 8 1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0,
1164 9 0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/
1165 DATA (PARP(I),I=101,200)/
1166 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
1167 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1168 2 1.0D0, 0.4D0, 8*0D0,
1169 3 0.01D0, 9*0D0,
1170 4 0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0,
1171 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
1172 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0,
1173 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1174 8 20*0D0/
1175 DATA MSTI/200*0/
1176 DATA PARI/200*0D0/
1177 DATA MINT/400*0/
1178 DATA VINT/400*0D0/
1179
1180C...Constants for the generation of the various processes.
1181 DATA (ISET(I),I=1,100)/
1182 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1183 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1184 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1185 3 2, -1, 2, 2, 2, 2, -1, -1, -1, -1,
1186 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1187 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1188 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1189 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1190 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1191 9 0, 0, 0, 0, 0, 9, -2, -2, -2, -2/
1192 DATA (ISET(I),I=101,200)/
1193 & -1, 1, 1, -2, -2, 2, 2, 2, -2, 2,
1194 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1195 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1196 3 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1197 4 1, 1, 1, 1, 1, -2, 1, 1, 1, -2,
1198 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1199 6 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1200 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1201 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1202 9 1, 1, 1, 2, -2, -2, -2, -2, -2, -2/
1203 DATA (ISET(I),I=201,300)/
1204 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1205 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1206 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1207 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1208 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1209 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1210 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1211 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1212 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1213 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
1214 DATA (ISET(I),I=301,500)/200*-2/
1215 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1216 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1217 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1218 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1219 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1220 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1221 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1222 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1223 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1224 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1225 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1226 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1227 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1228 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1229 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1230 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1231 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1232 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1233 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1234 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1235 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1236 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1237 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1238 & 23, 0, 25, 0, 25, 0, 0, 0, 0, 0,
1239 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1240 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1241 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1242 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1243 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1244 3 23, 5, 0, 0, 0, 0, 0, 0, 0, 0,
1245 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1246 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1247 4 0, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1248 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1249 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1250 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1251 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1252 6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 0, 0,
1253 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1254 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1255 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1256 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1257 9 54, 0, 55, 0, 56, 0, 11, 0, 0, 0,
1258 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1259 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1260 & 1000011, 1000011, 2000011, 2000011, 1000011,
1261 & 2000011, 1000013, 1000013, 2000013, 2000013,
1262 & 1000013, 2000013, 1000015, 1000015, 2000015,
1263 & 2000015, 1000015, 2000015, 1000011, 1000012,
1264 1 1000015, 1000016, 2000015, 1000016, 1000012,
1265 1 1000012, 1000016, 1000016, 0, 0,
1266 1 1000022, 1000022, 1000023, 1000023, 1000025,
1267 1 1000025, 1000035, 1000035, 1000022, 1000023,
1268 2 1000022, 1000025, 1000022, 1000035, 1000023,
1269 2 1000025, 1000023, 1000035, 1000025, 1000035,
1270 2 1000024, 1000024, 1000037, 1000037, 1000024,
1271 2 1000037, 1000022, 1000024, 1000023, 1000024,
1272 3 1000025, 1000024, 1000035, 1000024, 1000022,
1273 3 1000037, 1000023, 1000037, 1000025, 1000037,
1274 3 1000035, 1000037, 1000021, 1000022, 1000021,
1275 3 1000023, 1000021, 1000025, 1000021, 1000035/
1276 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1277 4 1000021, 1000024, 1000021, 1000037, 1000021,
1278 4 1000021, 1000021, 1000021, 0, 0,
1279 4 1000002, 1000022, 2000002, 1000022, 1000002,
1280 4 1000023, 2000002, 1000023, 1000002, 1000025,
1281 5 2000002, 1000025, 1000002, 1000035, 2000002,
1282 5 1000035, 1000001, 1000024, 2000005, 1000024,
1283 5 1000001, 1000037, 2000005, 1000037, 1000002,
1284 5 1000021, 2000002, 1000021, 0, 0,
1285 6 1000006, 1000006, 2000006, 2000006, 1000006,
1286 6 2000006, 1000006, 1000006, 2000006, 2000006,
1287 6 0, 0, 0, 0, 0,
1288 6 0, 0, 0, 0, 0,
1289 7 1000002, 1000002, 2000002, 2000002, 1000002,
1290 7 2000002, 1000002, 1000002, 2000002, 2000002,
1291 7 1000002, 2000002, 1000002, 1000002, 2000002,
1292 7 2000002, 1000002, 1000002, 2000002, 2000002/
1293 DATA ((KFPR(I,J),J=1,2),I=281,500)/440*0/
1294 DATA COEF/10000*0D0/
1295 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1296 &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
1297 &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
1298 &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
1299 &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
1300 &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
1301 &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
1302 &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
1303 &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
1304 &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1305 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
1306
1307C...Treatment of resonances.
1308 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1309 &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1310
1311C...Character constants: name of processes.
1312 DATA PROC(0)/ 'All included subprocesses '/
1313 DATA (PROC(I),I=1,20)/
1314 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1315 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1316 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1317 &' ', 'W+ + W- -> h0 ',
1318 &' ', 'f + f'' -> f + f'' (QFD) ',
1319 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1320 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1321 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1322 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1323 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1324 DATA (PROC(I),I=21,40)/
1325 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1326 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1327 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1328 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1329 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1330 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1331 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1332 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1333 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1334 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1335 DATA (PROC(I),I=41,60)/
1336 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1337 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1338 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1339 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1340 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1341 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1342 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1343 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1344 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1345 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1346 DATA (PROC(I),I=61,80)/
1347 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1348 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1349 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1350 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1351 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1352 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1353 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1354 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1355 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1356 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1357 DATA (PROC(I),I=81,100)/
1358 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1359 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1360 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1361 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1362 8'g + g -> chi_2c + g ', ' ',
1363 9'Elastic scattering ', 'Single diffractive (XB) ',
1364 9'Single diffractive (AX) ', 'Double diffractive ',
1365 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1366 9' ', ' ',
1367 9' ', ' '/
1368 DATA (PROC(I),I=101,120)/
1369 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1370 &'gamma + gamma -> h0 ', ' ',
1371 &' ', 'g + g -> J/Psi + gamma ',
1372 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1373 &' ', 'f + fbar -> gamma + h0 ',
1374 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1375 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1376 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1377 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1378 1' ', ' '/
1379 DATA (PROC(I),I=121,140)/
1380 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1381 2'f + f'' -> f + f'' + h0 ',
1382 2'f + f'' -> f" + f"'' + h0 ',
1383 2' ', ' ',
1384 2' ', ' ',
1385 2' ', ' ',
1386 3'g + g -> Z0 + q + qbar ', ' ',
1387 3' ', ' ',
1388 3' ', ' ',
1389 3' ', ' ',
1390 3' ', ' '/
1391 DATA (PROC(I),I=141,160)/
1392 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1393 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1394 4'q + l -> LQ ', ' ',
1395 4'd + g -> d* ', 'u + g -> u* ',
1396 4'g + g -> eta_techni ', ' ',
1397 5'f + fbar -> H0 ', 'g + g -> H0 ',
1398 5'gamma + gamma -> H0 ', ' ',
1399 5' ', 'f + fbar -> A0 ',
1400 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1401 5' ', ' '/
1402 DATA (PROC(I),I=161,180)/
1403 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1404 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1405 6'f + fbar -> f'' + fbar'' (g/Z)',
1406 6'f +fbar'' -> f" + fbar"'' (W) ',
1407 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1408 6' ', ' ',
1409 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1410 7'f + f'' -> f + f'' + H0 ',
1411 7'f + f'' -> f" + f"'' + H0 ',
1412 7' ', 'f + fbar -> Z0 + A0 ',
1413 7'f + fbar'' -> W+/- + A0 ',
1414 7'f + f'' -> f + f'' + A0 ',
1415 7'f + f'' -> f" + f"'' + A0 ',
1416 7' '/
1417 DATA (PROC(I),I=181,200)/
1418 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1419 8' ', ' ',
1420 8' ', 'g + g -> Q + Qbar + A0 ',
1421 8'q + qbar -> Q + Qbar + A0 ', ' ',
1422 8' ', ' ',
1423 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1424 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)',
1425 9' ', ' ',
1426 9' ', ' ',
1427 9' ', ' '/
1428 DATA (PROC(I),I=201,220)/
1429 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1430 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1431 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1432 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1433 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1434 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1435 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1436 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1437 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1438 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1439 DATA (PROC(I),I=221,240)/
1440 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1441 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1442 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1443 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1444 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1445 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1446 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1447 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1448 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1449 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1450 DATA (PROC(I),I=241,260)/
1451 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1452 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1453 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1454 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1455 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1456 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1457 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1458 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1459 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1460 5'qj + g -> ~qj_R + ~g ', ' '/
1461 DATA (PROC(I),I=261,280)/
1462 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1463 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1464 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1465 6' ', ' ',
1466 6' ', ' ',
1467 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1468 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1469 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1470 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1471 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar '/
1472 DATA (PROC(I),I=281,500)/220*' '/
1473
1474C...Cross sections and slope offsets.
1475 DATA SIGT/294*0D0/
1476
1477C...Supersymmetry switches and parameters.
1478 DATA IMSS/0,
1479 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1480 1 89*0/
1481 DATA RMSS/0D0,
1482 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1483 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1484 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,24D17,2*0D0,
1485 3 69*0D0/
1486
1487C...Data for histogramming routines.
1488 DATA IHIST/1000,20000,55,1/
1489 DATA INDX/1000*0/
1490
1491 END
1492
1493C*********************************************************************
1494
1495C...PYTEST
1496C...A simple program (disguised as subroutine) to run at installation
1497C...as a check that the program works as intended.
1498
1499 SUBROUTINE PYTEST(MTEST)
1500
1501C...Double precision and integer declarations.
1502 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1503 INTEGER PYK,PYCHGE,PYCOMP
1504C...Commonblocks.
1505 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1506 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1507 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1508 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1509 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1510 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1511 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1512C...Local arrays.
1513 DIMENSION PSUM(5),PINI(6),PFIN(6)
1514
1515C...Save defaults for values that are changed.
1516 MSTJ1=MSTJ(1)
1517 MSTJ3=MSTJ(3)
1518 MSTJ11=MSTJ(11)
1519 MSTJ42=MSTJ(42)
1520 MSTJ43=MSTJ(43)
1521 MSTJ44=MSTJ(44)
1522 PARJ17=PARJ(17)
1523 PARJ22=PARJ(22)
1524 PARJ43=PARJ(43)
1525 PARJ54=PARJ(54)
1526 MST101=MSTJ(101)
1527 MST104=MSTJ(104)
1528 MST105=MSTJ(105)
1529 MST107=MSTJ(107)
1530 MST116=MSTJ(116)
1531
1532C...First part: loop over simple events to be generated.
1533 IF(MTEST.GE.1) CALL PYTABU(20)
1534 NERR=0
1535 DO 180 IEV=1,500
1536
1537C...Reset parameter values. Switch on some nonstandard features.
1538 MSTJ(1)=1
1539 MSTJ(3)=0
1540 MSTJ(11)=1
1541 MSTJ(42)=2
1542 MSTJ(43)=4
1543 MSTJ(44)=2
1544 PARJ(17)=0.1D0
1545 PARJ(22)=1.5D0
1546 PARJ(43)=1D0
1547 PARJ(54)=-0.05D0
1548 MSTJ(101)=5
1549 MSTJ(104)=5
1550 MSTJ(105)=0
1551 MSTJ(107)=1
1552 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1553
1554C...Ten events each for some single jets configurations.
1555 IF(IEV.LE.50) THEN
1556 ITY=(IEV+9)/10
1557 MSTJ(3)=-1
1558 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1559 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1560 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1561 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1562 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1563 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1564
1565C...Ten events each for some simple jet systems; string fragmentation.
1566 ELSEIF(IEV.LE.130) THEN
1567 ITY=(IEV-41)/10
1568 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1569 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1570 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1571 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1572 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1573 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1574 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1575 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1576 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1577
1578C...Seventy events with independent fragmentation and momentum cons.
1579 ELSEIF(IEV.LE.200) THEN
1580 ITY=1+(IEV-131)/16
1581 MSTJ(2)=1+MOD(IEV-131,4)
1582 MSTJ(3)=1+MOD((IEV-131)/4,4)
1583 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1584 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1585 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1586 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1587 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1588 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1589
1590C...A hundred events with random jets (check invariant mass).
1591 ELSEIF(IEV.LE.300) THEN
1592 100 DO 110 J=1,5
1593 PSUM(J)=0D0
1594 110 CONTINUE
1595 NJET=2D0+6D0*PYR(0)
1596 DO 130 I=1,NJET
1597 KFL=21
1598 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1599 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1600 EJET=5D0+20D0*PYR(0)
1601 THETA=ACOS(2D0*PYR(0)-1D0)
1602 PHI=6.2832D0*PYR(0)
1603 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1604 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1605 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1606 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1607 DO 120 J=1,4
1608 PSUM(J)=PSUM(J)+P(I,J)
1609 120 CONTINUE
1610 130 CONTINUE
1611 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1612 & (PSUM(5)+PARJ(32))**2) GOTO 100
1613
1614C...Fifty e+e- continuum events with matrix elements.
1615 ELSEIF(IEV.LE.350) THEN
1616 MSTJ(101)=2
1617 CALL PYEEVT(0,40D0)
1618
1619C...Fifty e+e- continuum event with varying shower options.
1620 ELSEIF(IEV.LE.400) THEN
1621 MSTJ(42)=1+MOD(IEV,2)
1622 MSTJ(43)=1+MOD(IEV/2,4)
1623 MSTJ(44)=MOD(IEV/8,3)
1624 CALL PYEEVT(0,90D0)
1625
1626C...Fifty e+e- continuum events with coherent shower.
1627 ELSEIF(IEV.LE.450) THEN
1628 CALL PYEEVT(0,500D0)
1629
1630C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1631 ELSE
1632 CALL PYONIA(5,9.46D0)
1633 ENDIF
1634
1635C...Generate event. Find total momentum, energy and charge.
1636 DO 140 J=1,4
1637 PINI(J)=PYP(0,J)
1638 140 CONTINUE
1639 PINI(6)=PYP(0,6)
1640 CALL PYEXEC
1641 DO 150 J=1,4
1642 PFIN(J)=PYP(0,J)
1643 150 CONTINUE
1644 PFIN(6)=PYP(0,6)
1645
1646C...Check conservation of energy, momentum and charge;
1647C...usually exact, but only approximate for single jets.
1648 MERR=0
1649 IF(IEV.LE.50) THEN
1650 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4D0)
1651 & MERR=MERR+1
1652 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1653 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1654 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1655 ELSE
1656 DO 160 J=1,4
1657 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1658 160 CONTINUE
1659 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1660 ENDIF
1661 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1662 & (PFIN(J),J=1,4),PFIN(6)
1663
1664C...Check that all KF codes are known ones, and that partons/particles
1665C...satisfy energy-momentum-mass relation. Store particle statistics.
1666 DO 170 I=1,N
1667 IF(K(I,1).GT.20) GOTO 170
1668 IF(PYCOMP(K(I,2)).EQ.0) THEN
1669 WRITE(MSTU(11),5100) I
1670 MERR=MERR+1
1671 ENDIF
1672 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1673 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1674 & THEN
1675 WRITE(MSTU(11),5200) I
1676 MERR=MERR+1
1677 ENDIF
1678 170 CONTINUE
1679 IF(MTEST.GE.1) CALL PYTABU(21)
1680
1681C...List all erroneous events and some normal ones.
1682 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1683 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1684 CALL PYLIST(2)
1685 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1686 CALL PYLIST(1)
1687 ENDIF
1688
1689C...Stop execution if too many errors.
1690 IF(MERR.NE.0) NERR=NERR+1
1691 IF(NERR.GE.10) THEN
1692 WRITE(MSTU(11),6300)
1693 CALL PYLIST(1)
1694 STOP
1695 ENDIF
1696 180 CONTINUE
1697
1698C...Summarize result of run.
1699 IF(MTEST.GE.1) CALL PYTABU(22)
1700
1701C...Reset commonblock variables changed during run.
1702 MSTJ(1)=MSTJ1
1703 MSTJ(3)=MSTJ3
1704 MSTJ(11)=MSTJ11
1705 MSTJ(42)=MSTJ42
1706 MSTJ(43)=MSTJ43
1707 MSTJ(44)=MSTJ44
1708 PARJ(17)=PARJ17
1709 PARJ(22)=PARJ22
1710 PARJ(43)=PARJ43
1711 PARJ(54)=PARJ54
1712 MSTJ(101)=MST101
1713 MSTJ(104)=MST104
1714 MSTJ(105)=MST105
1715 MSTJ(107)=MST107
1716 MSTJ(116)=MST116
1717
1718C...Second part: complete events of various kinds.
1719C...Common initial values. Loop over initiating conditions.
1720 MSTP(122)=MAX(0,MIN(2,MTEST))
1721 MDCY(PYCOMP(111),1)=0
1722 DO 230 IPROC=1,8
1723
1724C...Reset process type, kinematics cuts, and the flags used.
1725 MSEL=0
1726 DO 190 ISUB=1,500
1727 MSUB(ISUB)=0
1728 190 CONTINUE
1729 CKIN(1)=2D0
1730 CKIN(3)=0D0
1731 MSTP(2)=1
1732 MSTP(11)=0
1733 MSTP(33)=0
1734 MSTP(81)=1
1735 MSTP(82)=1
1736 MSTP(111)=1
1737 MSTP(131)=0
1738 MSTP(133)=0
1739 PARP(131)=0.01D0
1740
1741C...Prompt photon production at fixed target.
1742 IF(IPROC.EQ.1) THEN
1743 PZSUM=300D0
1744 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1745 PQSUM=2D0
1746 MSEL=10
1747 CKIN(3)=5D0
1748 CALL PYINIT('FIXT','pi+','p',PZSUM)
1749
1750C...QCD processes at ISR energies.
1751 ELSEIF(IPROC.EQ.2) THEN
1752 PESUM=63D0
1753 PZSUM=0D0
1754 PQSUM=2D0
1755 MSEL=1
1756 CKIN(3)=5D0
1757 CALL PYINIT('CMS','p','p',PESUM)
1758
1759C...W production + multiple interactions at CERN Collider.
1760 ELSEIF(IPROC.EQ.3) THEN
1761 PESUM=630D0
1762 PZSUM=0D0
1763 PQSUM=0D0
1764 MSEL=12
1765 CKIN(1)=20D0
1766 MSTP(82)=4
1767 MSTP(2)=2
1768 MSTP(33)=3
1769 CALL PYINIT('CMS','p','pbar',PESUM)
1770
1771C...W/Z gauge boson pairs + pileup events at the Tevatron.
1772 ELSEIF(IPROC.EQ.4) THEN
1773 PESUM=1800D0
1774 PZSUM=0D0
1775 PQSUM=0D0
1776 MSUB(22)=1
1777 MSUB(23)=1
1778 MSUB(25)=1
1779 CKIN(1)=200D0
1780 MSTP(111)=0
1781 MSTP(131)=1
1782 MSTP(133)=2
1783 PARP(131)=0.04D0
1784 CALL PYINIT('CMS','p','pbar',PESUM)
1785
1786C...Higgs production at LHC.
1787 ELSEIF(IPROC.EQ.5) THEN
1788 PESUM=15400D0
1789 PZSUM=0D0
1790 PQSUM=2D0
1791 MSUB(3)=1
1792 MSUB(102)=1
1793 MSUB(123)=1
1794 MSUB(124)=1
1795 PMAS(25,1)=300D0
1796 CKIN(1)=200D0
1797 MSTP(81)=0
1798 MSTP(111)=0
1799 CALL PYINIT('CMS','p','p',PESUM)
1800
1801C...Z' production at SSC.
1802 ELSEIF(IPROC.EQ.6) THEN
1803 PESUM=40000D0
1804 PZSUM=0D0
1805 PQSUM=2D0
1806 MSEL=21
1807 PMAS(32,1)=600D0
1808 CKIN(1)=400D0
1809 MSTP(81)=0
1810 MSTP(111)=0
1811 CALL PYINIT('CMS','p','p',PESUM)
1812
1813C...W pair production at 1 TeV e+e- collider.
1814 ELSEIF(IPROC.EQ.7) THEN
1815 PESUM=1000D0
1816 PZSUM=0D0
1817 PQSUM=0D0
1818 MSUB(25)=1
1819 MSUB(69)=1
1820 MSTP(11)=1
1821 CALL PYINIT('CMS','e+','e-',PESUM)
1822
1823C...Deep inelastic scattering at a LEP+LHC ep collider.
1824 ELSEIF(IPROC.EQ.8) THEN
1825 P(1,1)=0D0
1826 P(1,2)=0D0
1827 P(1,3)=8000D0
1828 P(2,1)=0D0
1829 P(2,2)=0D0
1830 P(2,3)=-80D0
1831 PESUM=8080D0
1832 PZSUM=7920D0
1833 PQSUM=0D0
1834 MSUB(10)=1
1835 CKIN(3)=50D0
1836 MSTP(111)=0
1837 CALL PYINIT('USER','p','e-',PESUM)
1838 ENDIF
1839
1840C...Generate 20 events of each required type.
1841 DO 220 IEV=1,20
1842 CALL PYEVNT
1843 PESUMM=PESUM
1844 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1845
1846C...Check conservation of energy/momentum/flavour.
1847 PINI(1)=0D0
1848 PINI(2)=0D0
1849 PINI(3)=PZSUM
1850 PINI(4)=PESUMM
1851 PINI(6)=PQSUM
1852 DO 200 J=1,4
1853 PFIN(J)=PYP(0,J)
1854 200 CONTINUE
1855 PFIN(6)=PYP(0,6)
1856 MERR=0
1857 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1858 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1859 DEVQ=ABS(PFIN(6)-PINI(6))
1860 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1861 & DEVQ.GT.0.1D0) MERR=1
1862 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1863 & (PFIN(J),J=1,4),PFIN(6)
1864
1865C...Check that all KF codes are known ones, and that partons/particles
1866C...satisfy energy-momentum-mass relation.
1867 DO 210 I=1,N
1868 IF(K(I,1).GT.20) GOTO 210
1869 IF(PYCOMP(K(I,2)).EQ.0) THEN
1870 WRITE(MSTU(11),5100) I
1871 MERR=MERR+1
1872 ENDIF
1873 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
1874 & SIGN(1D0,P(I,5))
1875 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
1876 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
1877 WRITE(MSTU(11),5200) I
1878 MERR=MERR+1
1879 ENDIF
1880 210 CONTINUE
1881
1882C...Listing of erroneous events, and first event of each type.
1883 IF(MERR.GE.1) NERR=NERR+1
1884 IF(NERR.GE.10) THEN
1885 WRITE(MSTU(11),6300)
1886 CALL PYLIST(1)
1887 STOP
1888 ENDIF
1889 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
1890 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1891 CALL PYLIST(1)
1892 ENDIF
1893 220 CONTINUE
1894
1895C...List statistics for each process type.
1896 IF(MTEST.GE.1) CALL PYSTAT(1)
1897 230 CONTINUE
1898
1899C...Summarize result of run.
1900 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
1901 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
1902
1903C...Format statements for output.
1904 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
1905 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
1906 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
1907 &4(1X,F12.5),1X,F8.2)
1908 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
1909 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
1910 &'kinematics')
1911 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
1912 &'wrong.'/5X,'Execution will be stopped after listing of event.')
1913 6400 FORMAT(5X,'Faulty event follows:')
1914 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
1915 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
1916 &5X,'This should not have happened!')
1917
1918 RETURN
1919 END
1920
1921C*********************************************************************
1922
1923C...PYHEPC
1924C...Converts PYTHIA event record contents to or from
1925C...the standard event record commonblock.
1926
1927 SUBROUTINE PYHEPC(MCONV)
1928
1929C...Double precision and integer declarations.
1930 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1931 INTEGER PYK,PYCHGE,PYCOMP
1932C...Commonblocks.
1933 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1934 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1935 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1936 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
1937C...HEPEVT commonblock.
1938 PARAMETER (NMXHEP=4000)
1939 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
1940 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
1941 DOUBLE PRECISION PHEP,VHEP
1942 SAVE /HEPEVT/
1943
1944C...Conversion from PYTHIA to standard, the easy part.
1945 IF(MCONV.EQ.1) THEN
1946 NEVHEP=0
1947 IF(N.GT.NMXHEP) CALL PYERRM(8,
1948 & '(PYHEPC:) no more space in /HEPEVT/')
1949 NHEP=MIN(N,NMXHEP)
1950 DO 140 I=1,NHEP
1951 ISTHEP(I)=0
1952 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
1953 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
1954 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
1955 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
1956 IDHEP(I)=K(I,2)
1957 JMOHEP(1,I)=K(I,3)
1958 JMOHEP(2,I)=0
1959 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
1960 JDAHEP(1,I)=K(I,4)
1961 JDAHEP(2,I)=K(I,5)
1962 ELSE
1963 JDAHEP(1,I)=0
1964 JDAHEP(2,I)=0
1965 ENDIF
1966 DO 100 J=1,5
1967 PHEP(J,I)=P(I,J)
1968 100 CONTINUE
1969 DO 110 J=1,4
1970 VHEP(J,I)=V(I,J)
1971 110 CONTINUE
1972
1973C...Check if new event (from pileup).
1974 IF(I.EQ.1) THEN
1975 INEW=1
1976 ELSE
1977 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
1978 ENDIF
1979
1980C...Fill in missing mother information.
1981 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
1982 IMO1=I-2
1983 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
1984 & IMO1=IMO1-1
1985 JMOHEP(1,I)=IMO1
1986 JMOHEP(2,I)=IMO1+1
1987 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
1988 I1=K(I,3)-1
1989 120 I1=I1+1
1990 IF(I1.GE.I) CALL PYERRM(8,
1991 & '(PYHEPC:) translation of inconsistent event history')
1992 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
1993 KC=PYCOMP(K(I1,2))
1994 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
1995 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
1996 JMOHEP(2,I)=I1
1997 ELSEIF(K(I,2).EQ.94) THEN
1998 NJET=2
1999 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2000 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2001 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2002 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2003 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2004 ENDIF
2005
2006C...Fill in missing daughter information.
2007 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2008 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2009 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2010 JDAHEP(1,I2)=I
2011 130 CONTINUE
2012 ENDIF
2013 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2014 I1=JMOHEP(1,I)
2015 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2016 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2017 IF(JDAHEP(1,I1).EQ.0) THEN
2018 JDAHEP(1,I1)=I
2019 ELSE
2020 JDAHEP(2,I1)=I
2021 ENDIF
2022 140 CONTINUE
2023 DO 150 I=1,NHEP
2024 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2025 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2026 150 CONTINUE
2027
2028C...Conversion from standard to PYTHIA, the easy part.
2029 ELSE
2030 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2031 & '(PYHEPC:) no more space in /PYJETS/')
2032 N=MIN(NHEP,MSTU(4))
2033 NKQ=0
2034 KQSUM=0
2035 DO 180 I=1,N
2036 K(I,1)=0
2037 IF(ISTHEP(I).EQ.1) K(I,1)=1
2038 IF(ISTHEP(I).EQ.2) K(I,1)=11
2039 IF(ISTHEP(I).EQ.3) K(I,1)=21
2040 K(I,2)=IDHEP(I)
2041 K(I,3)=JMOHEP(1,I)
2042 K(I,4)=JDAHEP(1,I)
2043 K(I,5)=JDAHEP(2,I)
2044 DO 160 J=1,5
2045 P(I,J)=PHEP(J,I)
2046 160 CONTINUE
2047 DO 170 J=1,4
2048 V(I,J)=VHEP(J,I)
2049 170 CONTINUE
2050 V(I,5)=0D0
2051 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2052 I1=JDAHEP(1,I)
2053 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2054 & PHEP(5,I)/PHEP(4,I)
2055 ENDIF
2056
2057C...Fill in missing information on colour connection in jet systems.
2058 IF(ISTHEP(I).EQ.1) THEN
2059 KC=PYCOMP(K(I,2))
2060 KQ=0
2061 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2062 IF(KQ.NE.0) NKQ=NKQ+1
2063 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2064 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2065 K(I,1)=2
2066 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2067 IF(K(I+1,2).EQ.21) K(I,1)=2
2068 ENDIF
2069 ENDIF
2070 180 CONTINUE
2071 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2072 & '(PYHEPC:) input parton configuration not colour singlet')
2073 ENDIF
2074
2075 END
2076
2077C*********************************************************************
2078
2079C...PYINIT
2080C...Initializes the generation procedure; finds maxima of the
2081C...differential cross-sections to be used for weighting.
2082
2083 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2084
2085C...Double precision and integer declarations.
2086 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2087 INTEGER PYK,PYCHGE,PYCOMP
2088C...Commonblocks.
2089 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2090 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2091 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2092 COMMON/PYDAT4/CHAF(500,2)
2093 CHARACTER CHAF*16
2094 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2095 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2096 COMMON/PYINT1/MINT(400),VINT(400)
2097 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2098 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2099 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2100 &/PYINT1/,/PYINT2/,/PYINT5/
2101C...Local arrays and character variables.
2102 DIMENSION ALAMIN(20),NFIN(20)
2103 CHARACTER*(*) FRAME,BEAM,TARGET
2104 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHLH(2)*6
2105
2106C...Interface to PDFLIB.
2107 COMMON/W50512/QCDL4,QCDL5
2108 SAVE /W50512/
2109 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2110 CHARACTER*20 PARM(20)
2111 DATA VALUE/20*0D0/,PARM/20*' '/
2112
2113C...Data:Lambda and n_f values for parton distributions; months.
2114 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2115 &14*0.2D0/,NFIN/20*4/
2116 DATA CHLH/'lepton','hadron'/
2117
2118C...Reset MINT and VINT arrays. Write headers.
2119 DO 100 J=1,400
2120 MINT(J)=0
2121 VINT(J)=0D0
2122 100 CONTINUE
2123 IF(MSTU(12).GE.1) CALL PYLIST(0)
2124 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2125
2126C...Maximum 4 generations; set maximum number of allowed flavours.
2127 MSTP(1)=MIN(4,MSTP(1))
2128 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2129 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2130
2131C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2132 DO 120 I=-20,20
2133 VINT(180+I)=0D0
2134 IA=IABS(I)
2135 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2136 DO 110 J=1,MSTP(1)
2137 IB=2*J-1+MOD(IA,2)
2138 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2139 IPM=(5-ISIGN(1,I))/2
2140 IDC=J+MDCY(IA,2)+2
2141 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2142 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2143 110 CONTINUE
2144 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2145 VINT(180+I)=1D0
2146 ENDIF
2147 120 CONTINUE
2148
2149C...Initialize parton distributions: PDFLIB.
2150 IF(MSTP(52).EQ.2) THEN
2151 PARM(1)='NPTYPE'
2152 VALUE(1)=1
2153 PARM(2)='NGROUP'
2154 VALUE(2)=MSTP(51)/1000
2155 PARM(3)='NSET'
2156 VALUE(3)=MOD(MSTP(51),1000)
2157 PARM(4)='TMAS'
2158 VALUE(4)=PMAS(6,1)
2159 CALL PDFSET(PARM,VALUE)
2160 MINT(93)=1000000+MSTP(51)
2161 ENDIF
2162
2163C...Choose Lambda value to use in alpha-strong.
2164 MSTU(111)=MSTP(2)
2165 IF(MSTP(3).GE.2) THEN
2166 ALAM=0.2D0
2167 NF=4
2168 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.10) THEN
2169 ALAM=ALAMIN(MSTP(51))
2170 NF=NFIN(MSTP(51))
2171 ELSEIF(MSTP(52).EQ.2) THEN
2172 ALAM=QCDL4
2173 NF=4
2174 ENDIF
2175 PARP(1)=ALAM
2176 PARP(61)=ALAM
2177 PARP(72)=ALAM
2178 PARU(112)=ALAM
2179 MSTU(112)=NF
2180 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2181 ENDIF
2182
2183C...Initialize the SUSY generation: couplings, masses,
2184C...decay modes, branching ratios, and so on.
2185 CALL PYMSIN
2186
2187C...Initialize widths and partial widths for resonances.
2188 CALL PYINRE
2189C...Set Z0 mass and width for e+e- routines.
2190 PARJ(123)=PMAS(23,1)
2191 PARJ(124)=PMAS(23,2)
2192
2193C...Identify beam and target particles and frame of process.
2194 CHFRAM=FRAME//' '
2195 CHBEAM=BEAM//' '
2196 CHTARG=TARGET//' '
2197 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2198 IF(MINT(65).EQ.1) GOTO 170
2199
2200C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2201C...For e-gamma allow 2 alternatives.
2202 MINT(121)=1
2203 MINT(123)=MSTP(14)
2204 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2205 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2206 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2207 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2208 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2209 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2210 ENDIF
2211
2212C...Set up kinematics of process.
2213 CALL PYINKI(0)
2214
2215C...Precalculate flavour selection weights
2216 CALL PYKFIN
2217
2218C...Loop over gamma-p or gamma-gamma alternatives.
2219 DO 160 IGA=1,MINT(121)
2220 MINT(122)=IGA
2221
2222C...Select partonic subprocesses to be included in the simulation.
2223 CALL PYINPR
2224
2225C...Count number of subprocesses on.
2226 MINT(48)=0
2227 DO 130 ISUB=1,500
2228 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2229 & MSUB(ISUB).EQ.1) THEN
2230 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2231 STOP
2232 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2233 WRITE(MSTU(11),5300) ISUB
2234 STOP
2235 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2236 WRITE(MSTU(11),5400) ISUB
2237 STOP
2238 ELSEIF(MSUB(ISUB).EQ.1) THEN
2239 MINT(48)=MINT(48)+1
2240 ENDIF
2241 130 CONTINUE
2242 IF(MINT(48).EQ.0) THEN
2243 WRITE(MSTU(11),5500)
2244 STOP
2245 ENDIF
2246 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2247
2248C...Reset variables for cross-section calculation.
2249 DO 150 I=0,500
2250 DO 140 J=1,3
2251 NGEN(I,J)=0
2252 XSEC(I,J)=0D0
2253 140 CONTINUE
2254 150 CONTINUE
2255
2256C...Find parametrized total cross-sections.
2257 CALL PYXTOT
2258
2259C...Maxima of differential cross-sections.
2260 IF(MSTP(121).LE.1) CALL PYMAXI
2261
2262C...Initialize possibility of pileup events.
2263 IF(MINT(121).GT.1) MSTP(131)=0
2264 IF(MSTP(131).NE.0) CALL PYPILE(1)
2265
2266C...Initialize multiple interactions with variable impact parameter.
2267 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2268 & MSTP(82).GE.2) CALL PYMULT(1)
2269
2270C...Save results for gamma-p and gamma-gamma alternatives.
2271 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2272 160 CONTINUE
2273
2274C...Initialization finished.
2275 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2276
2277C...Formats for initialization information.
2278 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2279 &'routines',1X,17('*'))
2280 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2281 &'-',A6,' interactions.'/1X,'Execution stopped!')
2282 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2283 &1X,'Execution stopped!')
2284 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2285 &1X,'Execution stopped!')
2286 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2287 &1X,'Execution stopped.')
2288 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2289 &22('*'))
2290
2291 RETURN
2292 END
2293
2294C*********************************************************************
2295
2296C...PYEVNT
2297C...Administers the generation of a high-pT event via calls to
2298C...a number of subroutines.
2299
2300 SUBROUTINE PYEVNT
2301
2302C...Double precision and integer declarations.
2303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2304 INTEGER PYK,PYCHGE,PYCOMP
2305C...Commonblocks.
2306 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2307 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2308 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2309 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2310 COMMON/PYINT1/MINT(400),VINT(400)
2311 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2312 COMMON/PYINT4/MWID(500),WIDS(500,5)
2313 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2314 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2315 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2316 &/PYINT4/,/PYINT5/,/PYUPPR/
2317C...Local array.
2318 DIMENSION VTX(4)
2319
2320C...Initial values for some counters.
2321 N=0
2322 MINT(5)=MINT(5)+1
2323 MINT(7)=0
2324 MINT(8)=0
2325 MINT(83)=0
2326 MINT(84)=MSTP(126)
2327 MSTU(24)=0
2328 MSTU70=0
2329 MSTJ14=MSTJ(14)
2330
2331C...If variable energies: redo incoming kinematics and cross-section.
2332 MSTI(61)=0
2333 IF(MSTP(171).EQ.1) THEN
2334 CALL PYINKI(1)
2335 IF(MSTI(61).EQ.1) THEN
2336 MINT(5)=MINT(5)-1
2337 RETURN
2338 ENDIF
2339 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2340 CALL PYXTOT
2341 ENDIF
2342
2343C...Loop over number of pileup events; check space left.
2344 IF(MSTP(131).LE.0) THEN
2345 NPILE=1
2346 ELSE
2347 CALL PYPILE(2)
2348 NPILE=MINT(81)
2349 ENDIF
2350 DO 260 IPILE=1,NPILE
2351 IF(MINT(84)+100.GE.MSTU(4)) THEN
2352 CALL PYERRM(11,
2353 & '(PYEVNT:) no more space in PYJETS for pileup events')
2354 IF(MSTU(21).GE.1) GOTO 270
2355 ENDIF
2356 MINT(82)=IPILE
2357
2358C...Generate variables of hard scattering.
2359 MINT(51)=0
2360 MSTI(52)=0
2361 100 CONTINUE
2362 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2363 MINT(31)=0
2364 MINT(51)=0
2365 MINT(57)=0
2366 CALL PYRAND
2367 IF(MSTI(61).EQ.1) THEN
2368 MINT(5)=MINT(5)-1
2369 RETURN
2370 ENDIF
2371 IF(MINT(51).EQ.2) RETURN
2372 ISUB=MINT(1)
2373 IF(MSTP(111).EQ.-1) GOTO 250
2374
2375 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
2376C...Hard scattering (including low-pT):
2377C...reconstruct kinematics and colour flow of hard scattering.
2378 110 MINT(51)=0
2379 CALL PYSCAT
2380 IF(MINT(51).EQ.1) GOTO 100
2381 IPU1=MINT(84)+1
2382 IPU2=MINT(84)+2
2383 IF(ISUB.EQ.95) GOTO 130
2384
2385C...Showering of initial state partons (optional).
2386 ALAMSV=PARJ(81)
2387 PARJ(81)=PARP(72)
2388 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2389 PARJ(81)=ALAMSV
2390 IF(MINT(51).EQ.1) GOTO 100
2391
2392C...Showering of final state partons (optional).
2393 ALAMSV=PARJ(81)
2394 PARJ(81)=PARP(72)
2395 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2396 & THEN
2397 IPU3=MINT(84)+3
2398 IPU4=MINT(84)+4
2399 IF(ISET(ISUB).EQ.5) IPU4=-3
2400 QMAX=VINT(55)
2401 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2402 CALL PYSHOW(IPU3,IPU4,QMAX)
2403 ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2404 DO 120 IUP=1,NFUP
2405 IPU3=IFUP(IUP,1)+MINT(84)
2406 IPU4=IFUP(IUP,2)+MINT(84)
2407 QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2408 CALL PYSHOW(IPU3,IPU4,QMAX)
2409 120 CONTINUE
2410 ENDIF
2411 PARJ(81)=ALAMSV
2412
2413C...Decay of final state resonances.
2414 MINT(32)=0
2415 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2416 IF(MINT(51).EQ.1) GOTO 100
2417 MINT(52)=N
2418
2419C...Multiple interactions.
2420 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2421 MINT(53)=N
2422
2423C...Hadron remnants and primordial kT.
2424 130 CALL PYREMN(IPU1,IPU2)
2425 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2426 IF(MINT(51).EQ.1) GOTO 100
2427
2428 ELSE
2429C...Diffractive and elastic scattering.
2430 CALL PYDIFF
2431 ENDIF
2432
2433C...Check that no odd resonance left undecayed.
2434 IF(MSTP(111).GE.1) THEN
2435 NFIX=N
2436 DO 140 I=MINT(84)+1,NFIX
2437 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2438 & K(I,2).NE.22) THEN
2439 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2440 CALL PYRESD(I)
2441 IF(MINT(51).EQ.1) GOTO 100
2442 ENDIF
2443 ENDIF
2444 140 CONTINUE
2445 ENDIF
2446
2447C...Recalculate energies from momenta and masses (if desired).
2448 IF(MSTP(113).GE.1) THEN
2449 DO 150 I=MINT(83)+1,N
2450 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2451 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2452 150 CONTINUE
2453 NRECAL=N
2454 ENDIF
2455
2456C...Rearrange partons along strings, check invariant mass cuts.
2457 MSTU(28)=0
2458 IF(MSTP(111).LE.0) MSTJ(14)=-1
2459 CALL PYPREP(MINT(84)+1)
2460 MSTJ(14)=MSTJ14
2461 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2462 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2463 DO 180 I=MINT(84)+1,N
2464 IF(K(I,2).EQ.94) THEN
2465 DO 170 I1=I+1,MIN(N,I+3)
2466 IF(K(I1,3).EQ.I) THEN
2467 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2468 IF(K(I1,3).EQ.0) THEN
2469 DO 160 II=MINT(84)+1,I-1
2470 IF(K(II,2).EQ.K(I1,2)) THEN
2471 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2472 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2473 ENDIF
2474 160 CONTINUE
2475 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2476 ENDIF
2477 ENDIF
2478 170 CONTINUE
2479 ENDIF
2480 180 CONTINUE
2481 CALL PYEDIT(12)
2482 CALL PYEDIT(14)
2483 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2484 IF(MSTP(125).EQ.0) MINT(4)=0
2485 DO 200 I=MINT(83)+1,N
2486 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2487 DO 190 I1=I+1,N
2488 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2489 IF(K(I1,3).EQ.I) K(I,5)=I1
2490 190 CONTINUE
2491 ENDIF
2492 200 CONTINUE
2493 ENDIF
2494
2495C...Introduce separators between sections in PYLIST event listing.
2496 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2497 MSTU70=1
2498 MSTU(71)=N
2499 ELSEIF(IPILE.EQ.1) THEN
2500 MSTU70=3
2501 MSTU(71)=2
2502 MSTU(72)=MINT(4)
2503 MSTU(73)=N
2504 ENDIF
2505
2506C...Go back to lab frame (needed for vertices, also in fragmentation).
2507 CALL PYFRAM(1)
2508
2509C...Set nonvanishing production vertex (optional).
2510 IF(MSTP(151).EQ.1) THEN
2511 DO 210 J=1,4
2512 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2513 & SIN(PARU(2)*PYR(0))
2514 210 CONTINUE
2515 DO 230 I=MINT(83)+1,N
2516 DO 220 J=1,4
2517 V(I,J)=V(I,J)+VTX(J)
2518 220 CONTINUE
2519 230 CONTINUE
2520 ENDIF
2521
2522C...Perform hadronization (if desired).
2523 IF(MSTP(111).GE.1) THEN
2524 CALL PYEXEC
2525 IF(MSTU(24).NE.0) GOTO 100
2526 ENDIF
2527 IF(MSTP(113).GE.1) THEN
2528 DO 240 I=NRECAL,N
2529 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2530 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2531 240 CONTINUE
2532 ENDIF
2533 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2534
2535C...Store event information and calculate Monte Carlo estimates of
2536C...subprocess cross-sections.
2537 250 IF(IPILE.EQ.1) CALL PYDOCU
2538
2539C...Set counters for current pileup event and loop to next one.
2540 MSTI(41)=IPILE
2541 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2542 IF(MSTU70.LT.10) THEN
2543 MSTU70=MSTU70+1
2544 MSTU(70+MSTU70)=N
2545 ENDIF
2546 MINT(83)=N
2547 MINT(84)=N+MSTP(126)
2548 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2549 260 CONTINUE
2550
2551C...Generic information on pileup events. Reconstruct missing history.
2552 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2553 PARI(91)=VINT(132)
2554 PARI(92)=VINT(133)
2555 PARI(93)=VINT(134)
2556 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2557 ENDIF
2558 CALL PYEDIT(16)
2559
2560C...Transform to the desired coordinate frame.
2561 270 CALL PYFRAM(MSTP(124))
2562 MSTU(70)=MSTU70
2563 PARU(21)=VINT(1)
2564
2565 RETURN
2566 END
2567
2568C***********************************************************************
2569
2570C...PYSTAT
2571C...Prints out information about cross-sections, decay widths, branching
2572C...ratios, kinematical limits, status codes and parameter values.
2573
2574 SUBROUTINE PYSTAT(MSTAT)
2575
2576C...Double precision and integer declarations.
2577 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2578 INTEGER PYK,PYCHGE,PYCOMP
2579C...Parameter statement to help give large particle numbers.
2580 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2581C...Commonblocks.
2582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2583 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2584 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2585 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2586 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2587 COMMON/PYINT1/MINT(400),VINT(400)
2588 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2589 COMMON/PYINT4/MWID(500),WIDS(500,5)
2590 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2591 COMMON/PYINT6/PROC(0:500)
2592 CHARACTER PROC*28
2593 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2594 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2595 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2596C...Local arrays, character variables and data.
2597 DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2598 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2599 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28
2600 DATA PROGA/
2601 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2602 &'VMD/hadron * anomalous ','direct * direct ',
2603 &'direct * anomalous ','anomalous * anomalous '/
2604 DATA DISGA/'e * VMD','e * anomalous'/
2605 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2606 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2607 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2608 &' y*_small ',' eta*_large ',' eta*_small ',
2609 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2610 &' x_2 ',' x_F ',' cos(theta_hard) ',
2611 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2612 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2613 &' tau'' '/
2614
2615C...Cross-sections.
2616 IF(MSTAT.LE.1) THEN
2617 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2618 WRITE(MSTU(11),5000)
2619 WRITE(MSTU(11),5100)
2620 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2621 DO 100 I=1,500
2622 IF(MSUB(I).NE.1) GOTO 100
2623 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2624 100 CONTINUE
2625 IF(MINT(121).GT.1) THEN
2626 WRITE(MSTU(11),5300)
2627 DO 110 IGA=1,MINT(121)
2628 CALL PYSAVE(3,IGA)
2629 IF(MINT(121).EQ.2) THEN
2630 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2631 & XSEC(0,3)
2632 ELSE
2633 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2634 & XSEC(0,3)
2635 ENDIF
2636 110 CONTINUE
2637 CALL PYSAVE(5,0)
2638 ENDIF
2639 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2640 & MAX(1D0,DBLE(NGEN(0,2)))
2641
2642C...Decay widths and branching ratios.
2643 ELSEIF(MSTAT.EQ.2) THEN
2644 WRITE(MSTU(11),5500)
2645 WRITE(MSTU(11),5600)
2646 DO 140 KC=1,500
2647 KF=KCHG(KC,4)
2648 CALL PYNAME(KF,CHKF)
2649 IOFF=0
2650 IF(KC.LE.22) THEN
2651 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2652 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2653 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2654 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2655 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2656 ELSE
2657 IF(MWID(KC).LE.0) GOTO 140
2658 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2659 & KF/KSUSY1.EQ.2)) GOTO 140
2660 ENDIF
2661C...Off-shell branchings.
2662 IF(IOFF.EQ.1) THEN
2663 NGP=0
2664 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2665 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2666 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2667 DO 120 J=1,MDCY(KC,3)
2668 IDC=J+MDCY(KC,2)-1
2669 NGP1=0
2670 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2671 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2672 NGP2=0
2673 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2674 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2675 CALL PYNAME(KFDP(IDC,1),CHD1)
2676 CALL PYNAME(KFDP(IDC,2),CHD2)
2677 IF(KFDP(IDC,3).EQ.0) THEN
2678 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2679 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2680 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2681 ELSE
2682 CALL PYNAME(KFDP(IDC,3),CHD3)
2683 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2684 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2685 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2686 ENDIF
2687 120 CONTINUE
2688C...On-shell decays.
2689 ELSE
2690 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2691 BRFIN=1D0
2692 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2693 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2694 & STATE(MDCY(KC,1)),BRFIN
2695 DO 130 J=1,MDCY(KC,3)
2696 IDC=J+MDCY(KC,2)-1
2697 NGP1=0
2698 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2699 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2700 NGP2=0
2701 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2702 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2703 BRFIN=0D0
2704 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2705 CALL PYNAME(KFDP(IDC,1),CHD1)
2706 CALL PYNAME(KFDP(IDC,2),CHD2)
2707 IF(KFDP(IDC,3).EQ.0) THEN
2708 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2709 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2710 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2711 & STATE(MDME(IDC,1)),BRFIN
2712 ELSE
2713 CALL PYNAME(KFDP(IDC,3),CHD3)
2714 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2715 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2716 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2717 & STATE(MDME(IDC,1)),BRFIN
2718 ENDIF
2719 130 CONTINUE
2720 ENDIF
2721 140 CONTINUE
2722 WRITE(MSTU(11),6000)
2723
2724C...Allowed incoming partons/particles at hard interaction.
2725 ELSEIF(MSTAT.EQ.3) THEN
2726 WRITE(MSTU(11),6100)
2727 CALL PYNAME(MINT(11),CHAU)
2728 CHIN(1)=CHAU(1:12)
2729 CALL PYNAME(MINT(12),CHAU)
2730 CHIN(2)=CHAU(1:12)
2731 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2732 DO 150 I=-20,22
2733 IF(I.EQ.0) GOTO 150
2734 IA=IABS(I)
2735 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2736 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2737 CALL PYNAME(I,CHAU)
2738 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2739 & STATE(KFIN(2,I))
2740 150 CONTINUE
2741 WRITE(MSTU(11),6400)
2742
2743C...User-defined limits on kinematical variables.
2744 ELSEIF(MSTAT.EQ.4) THEN
2745 WRITE(MSTU(11),6500)
2746 WRITE(MSTU(11),6600)
2747 SHRMAX=CKIN(2)
2748 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2749 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2750 PTHMIN=MAX(CKIN(3),CKIN(5))
2751 PTHMAX=CKIN(4)
2752 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2753 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2754 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2755 DO 160 I=4,14
2756 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2757 160 CONTINUE
2758 SPRMAX=CKIN(32)
2759 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2760 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2761 WRITE(MSTU(11),7000)
2762
2763C...Status codes and parameter values.
2764 ELSEIF(MSTAT.EQ.5) THEN
2765 WRITE(MSTU(11),7100)
2766 WRITE(MSTU(11),7200)
2767 DO 170 I=1,100
2768 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
2769 & PARP(100+I)
2770 170 CONTINUE
2771
2772C...List of all processes implemented in the program.
2773 ELSEIF(MSTAT.EQ.6) THEN
2774 WRITE(MSTU(11),7400)
2775 WRITE(MSTU(11),7500)
2776 DO 180 I=1,500
2777 IF(ISET(I).LT.0) GOTO 180
2778 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
2779 180 CONTINUE
2780 WRITE(MSTU(11),7700)
2781 ENDIF
2782
2783C...Formats for printouts.
2784 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
2785 &'Events and Cross-sections',1X,9('*'))
2786 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
2787 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
2788 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
2789 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
2790 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
2791 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
2792 &'I',12X,'I')
2793 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
2794 &D10.3,1X,'I')
2795 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
2796 &1X,'I',34X,'I',28X,'I',12X,'I')
2797 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
2798 &1X,'********* Fraction of events that fail fragmentation ',
2799 &'cuts =',1X,F8.5,' *********'/)
2800 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
2801 &'Ratios',1X,27('*'))
2802 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2803 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
2804 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
2805 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2806 &1X,98('='))
2807 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
2808 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
2809 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
2810 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
2811 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2812 &1P,D10.3,0P,1X,'I')
2813 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
2814 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2815 &1P,D10.3,0P,1X,'I')
2816 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
2817 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
2818 &'Particles at Hard Interaction',1X,7('*'))
2819 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
2820 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
2821 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
2822 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
2823 &78('=')/1X,'I',38X,'I',37X,'I')
2824 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
2825 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
2826 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
2827 &'Kinematical Variables',1X,12('*'))
2828 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
2829 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
2830 &16X,'I')
2831 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
2832 &1X,'<',1X,1P,D10.3,0P,16X,'I')
2833 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
2834 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
2835 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
2836 &'Parameter Values',1X,12('*'))
2837 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
2838 &'PARP(I)'/)
2839 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
2840 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
2841 &1X,13('*'))
2842 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
2843 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
2844 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
2845 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
2846 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
2847
2848 RETURN
2849 END
2850
2851C*********************************************************************
2852
2853C...PYINRE
2854C...Calculates full and effective widths of gauge bosons, stores
2855C...masses and widths, rescales coefficients to be used for
2856C...resonance production generation.
2857
2858 SUBROUTINE PYINRE
2859
2860C...Double precision and integer declarations.
2861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2862 INTEGER PYK,PYCHGE,PYCOMP
2863C...Parameter statement to help give large particle numbers.
2864 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2865C...Commonblocks.
2866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2868 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2869 COMMON/PYDAT4/CHAF(500,2)
2870 CHARACTER CHAF*16
2871 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2872 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2873 COMMON/PYINT1/MINT(400),VINT(400)
2874 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2875 COMMON/PYINT4/MWID(500),WIDS(500,5)
2876 COMMON/PYINT6/PROC(0:500)
2877 CHARACTER PROC*28
2878 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2879 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2880 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
2881C...Local arrays and data.
2882 DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
2883 &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
2884
2885C...Born level couplings in MSSM Higgs doublet sector.
2886 XW=PARU(102)
2887 XWV=XW
2888 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
2889 XW1=1D0-XW
2890 IF(MSTP(4).EQ.2) THEN
2891 TANBE=PARU(141)
2892 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
2893 SQMZ=PMAS(23,1)**2
2894 SQMW=PMAS(24,1)**2
2895 SQMH=PMAS(25,1)**2
2896 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
2897 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
2898 SQMHC=SQMA+SQMW
2899 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
2900 WRITE(MSTU(11),5000)
2901 STOP
2902 ENDIF
2903 PMAS(35,1)=SQRT(SQMHP)
2904 PMAS(36,1)=SQRT(SQMA)
2905 PMAS(37,1)=SQRT(SQMHC)
2906 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
2907 & (SQMA-SQMZ)))
2908 BESU=ATAN(TANBE)
2909 PARU(142)=1D0
2910 PARU(143)=1D0
2911 PARU(161)=-SIN(ALSU)/COS(BESU)
2912 PARU(162)=COS(ALSU)/SIN(BESU)
2913 PARU(163)=PARU(161)
2914 PARU(164)=SIN(BESU-ALSU)
2915 PARU(165)=PARU(164)
2916 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
2917 PARU(171)=COS(ALSU)/COS(BESU)
2918 PARU(172)=SIN(ALSU)/SIN(BESU)
2919 PARU(173)=PARU(171)
2920 PARU(174)=COS(BESU-ALSU)
2921 PARU(175)=PARU(174)
2922 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
2923 & SIN(BESU+ALSU)
2924 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
2925 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
2926 PARU(181)=TANBE
2927 PARU(182)=1D0/TANBE
2928 PARU(183)=PARU(181)
2929 PARU(184)=0D0
2930 PARU(185)=PARU(184)
2931 PARU(186)=COS(BESU-ALSU)
2932 PARU(187)=SIN(BESU-ALSU)
2933 PARU(188)=PARU(186)
2934 PARU(189)=PARU(187)
2935 PARU(190)=0D0
2936 PARU(195)=COS(BESU-ALSU)
2937 ENDIF
2938
2939C...Reset effective widths of gauge bosons.
2940 DO 110 I=1,500
2941 DO 100 J=1,5
2942 WIDS(I,J)=1D0
2943 100 CONTINUE
2944 110 CONTINUE
2945
2946C...Order resonances by increasing mass (except Z0 and W+/-).
2947 NRES=0
2948 DO 140 KC=1,500
2949 KF=KCHG(KC,4)
2950 IF(KF.EQ.0) GOTO 140
2951 IF(MWID(KC).EQ.0) GOTO 140
2952 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
2953 IF(MSTP(1).LE.3) GOTO 140
2954 ENDIF
2955 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
2956 IF(IMSS(1).LE.0) GOTO 140
2957 ENDIF
2958 NRES=NRES+1
2959 PMRES=PMAS(KC,1)
2960 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
2961 DO 120 I1=NRES-1,1,-1
2962 IF(PMRES.GE.PMORD(I1)) GOTO 130
2963 KCORD(I1+1)=KCORD(I1)
2964 PMORD(I1+1)=PMORD(I1)
2965 120 CONTINUE
2966 130 KCORD(I1+1)=KC
2967 PMORD(I1+1)=PMRES
2968 140 CONTINUE
2969
2970C...Loop over possible resonances.
2971 DO 180 I=1,NRES
2972 KC=KCORD(I)
2973 KF=KCHG(KC,4)
2974
2975C...Check that no fourth generation channels on by mistake.
2976 IF(MSTP(1).LE.3) THEN
2977 DO 150 J=1,MDCY(KC,3)
2978 IDC=J+MDCY(KC,2)-1
2979 KFA1=IABS(KFDP(IDC,1))
2980 KFA2=IABS(KFDP(IDC,2))
2981 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
2982 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
2983 & MDME(IDC,1)=-1
2984 150 CONTINUE
2985 ENDIF
2986
2987C...Check that no supersymmetric channels on by mistake.
2988 IF(IMSS(1).LE.0) THEN
2989 DO 160 J=1,MDCY(KC,3)
2990 IDC=J+MDCY(KC,2)-1
2991 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
2992 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
2993 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
2994 & MDME(IDC,1)=-1
2995 160 CONTINUE
2996 ENDIF
2997
2998C...Find mass and evaluate width.
2999 PMR=PMAS(KC,1)
3000 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3001 IF(MWID(KC).EQ.3) MINT(63)=1
3002 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3003 MINT(51)=0
3004
3005C...Evaluate suppression factors due to non-simulated channels.
3006 IF(KCHG(KC,3).EQ.0) THEN
3007 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3008 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3009 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3010 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3011 WIDS(KC,3)=0D0
3012 WIDS(KC,4)=0D0
3013 WIDS(KC,5)=0D0
3014 ELSE
3015 IF(MWID(KC).EQ.3) MINT(63)=1
3016 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3017 MINT(51)=0
3018 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3019 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3020 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3021 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3022 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3023 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3024 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3025 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3026 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3027 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3028 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3029 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3030 ENDIF
3031
3032C...Set resonance widths and branching ratios;
3033C...also on/off switch for decays.
3034 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3035 PMAS(KC,2)=WDTP(0)
3036 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3037 MDCY(KC,1)=MSTP(41)
3038 DO 170 J=1,MDCY(KC,3)
3039 IDC=J+MDCY(KC,2)-1
3040 BRAT(IDC)=0D0
3041 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3042 170 CONTINUE
3043 ENDIF
3044 180 CONTINUE
3045
3046C...Flavours of leptoquark: redefine charge and name.
3047 KFLQQ=KFDP(MDCY(39,2),1)
3048 KFLQL=KFDP(MDCY(39,2),2)
3049 KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3050 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3051 LL=1
3052 IF(IABS(KFLQL).EQ.13) LL=2
3053 IF(IABS(KFLQL).EQ.15) LL=3
3054 CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3055 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3056 CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3057
3058C...Special cases in treatment of gamma*/Z0: redefine process name.
3059 IF(MSTP(43).EQ.1) THEN
3060 PROC(1)='f + fbar -> gamma*'
3061 PROC(15)='f + fbar -> g + gamma*'
3062 PROC(19)='f + fbar -> gamma + gamma*'
3063 PROC(30)='f + g -> f + gamma*'
3064 PROC(35)='f + gamma -> f + gamma*'
3065 ELSEIF(MSTP(43).EQ.2) THEN
3066 PROC(1)='f + fbar -> Z0'
3067 PROC(15)='f + fbar -> g + Z0'
3068 PROC(19)='f + fbar -> gamma + Z0'
3069 PROC(30)='f + g -> f + Z0'
3070 PROC(35)='f + gamma -> f + Z0'
3071 ELSEIF(MSTP(43).EQ.3) THEN
3072 PROC(1)='f + fbar -> gamma*/Z0'
3073 PROC(15)='f + fbar -> g + gamma*/Z0'
3074 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3075 PROC(30)='f + g -> f + gamma*/Z0'
3076 PROC(35)='f + gamma -> f + gamma*/Z0'
3077 ENDIF
3078
3079C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3080 IF(MSTP(44).EQ.1) THEN
3081 PROC(141)='f + fbar -> gamma*'
3082 ELSEIF(MSTP(44).EQ.2) THEN
3083 PROC(141)='f + fbar -> Z0'
3084 ELSEIF(MSTP(44).EQ.3) THEN
3085 PROC(141)='f + fbar -> Z''0'
3086 ELSEIF(MSTP(44).EQ.4) THEN
3087 PROC(141)='f + fbar -> gamma*/Z0'
3088 ELSEIF(MSTP(44).EQ.5) THEN
3089 PROC(141)='f + fbar -> gamma*/Z''0'
3090 ELSEIF(MSTP(44).EQ.6) THEN
3091 PROC(141)='f + fbar -> Z0/Z''0'
3092 ELSEIF(MSTP(44).EQ.7) THEN
3093 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3094 ENDIF
3095
3096C...Special cases in treatment of WW -> WW: redefine process name.
3097 IF(MSTP(45).EQ.1) THEN
3098 PROC(77)='W+ + W+ -> W+ + W+'
3099 ELSEIF(MSTP(45).EQ.2) THEN
3100 PROC(77)='W+ + W- -> W+ + W-'
3101 ELSEIF(MSTP(45).EQ.3) THEN
3102 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3103 ENDIF
3104
3105C...Format for error information.
3106 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3107 &'combination'/1X,'Execution stopped!')
3108
3109 RETURN
3110 END
3111
3112C*********************************************************************
3113
3114C...PYINBM
3115C...Identifies the two incoming particles and the choice of frame.
3116
3117 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3118
3119C...Double precision and integer declarations.
3120 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3121 INTEGER PYK,PYCHGE,PYCOMP
3122C...Commonblocks.
3123 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3124 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3125 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3126 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3127 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3128 COMMON/PYINT1/MINT(400),VINT(400)
3129 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3130C...Local arrays, character variables and data.
3131 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
3132 &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76
3133 DIMENSION LEN(3),KCDE(29),PM(2)
3134 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3135 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3136 DATA CHCDE/'e- ','e+ ','nu_e ','nu_ebar ',
3137 &'mu- ','mu+ ','nu_mu ','nu_mubar','tau- ',
3138 &'tau+ ','nu_tau ','nu_tauba','pi+ ','pi- ',
3139 &'n0 ','nbar0 ','p+ ','pbar- ','gamma ',
3140 &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ',
3141 &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/
3142 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3143 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3144 &3312,3322,3334,111,28,29/
3145
3146C...Store initial energy. Default frame.
3147 VINT(290)=WIN
3148 MINT(111)=0
3149
3150C...Convert character variables to lowercase and find their length.
3151 CHCOM(1)=CHFRAM
3152 CHCOM(2)=CHBEAM
3153 CHCOM(3)=CHTARG
3154 DO 130 I=1,3
3155 LEN(I)=8
3156 DO 110 LL=8,1,-1
3157 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3158 DO 100 LA=1,26
3159 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3160 & CHALP(1)(LA:LA)
3161 100 CONTINUE
3162 110 CONTINUE
3163 CHIDNT(I)=CHCOM(I)
3164
3165C...Fix up bar, underscore and charge in particle name (if needed).
3166 DO 120 LL=1,6
3167 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3168 CHTEMP=CHIDNT(I)
3169 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//' '
3170 ENDIF
3171 120 CONTINUE
3172 IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba'
3173 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3174 CHTEMP=CHIDNT(I)
3175 CHIDNT(I)='nu_'//CHTEMP(3:7)
3176 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3177 CHIDNT(I)(1:3)='n0 '
3178 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3179 CHIDNT(I)(1:5)='nbar0'
3180 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3181 CHIDNT(I)(1:3)='p+ '
3182 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3183 & CHIDNT(I)(1:2).EQ.'p-') THEN
3184 CHIDNT(I)(1:5)='pbar-'
3185 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3186 CHIDNT(I)(7:7)='0'
3187 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3188 CHIDNT(I)(1:7)='reggeon'
3189 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3190 CHIDNT(I)(1:7)='pomeron'
3191 ENDIF
3192 130 CONTINUE
3193
3194C...Identify free initialization.
3195 IF(CHCOM(1)(1:2).EQ.'no') THEN
3196 MINT(65)=1
3197 RETURN
3198 ENDIF
3199
3200C...Identify incoming beam and target particles.
3201 DO 150 I=1,2
3202 DO 140 J=1,29
3203 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3204 140 CONTINUE
3205 PM(I)=PYMASS(MINT(10+I))
3206 VINT(2+I)=PM(I)
3207 150 CONTINUE
3208 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3209 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3210 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3211
3212C...Identify choice of frame and input energies.
3213 CHINIT=' '
3214
3215C...Events defined in the CM frame.
3216 IF(CHCOM(1)(1:2).EQ.'cm') THEN
3217 MINT(111)=1
3218 S=WIN**2
3219 IF(MSTP(122).GE.1) THEN
3220 IF(CHCOM(2)(1:1).NE.'e') THEN
3221 LOFFS=(31-(LEN(2)+LEN(3)))/2
3222 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3223 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3224 & ' collider'//' '
3225 ELSE
3226 LOFFS=(30-(LEN(2)+LEN(3)))/2
3227 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3228 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3229 & ' collider'//' '
3230 ENDIF
3231 WRITE(MSTU(11),5200) CHINIT
3232 WRITE(MSTU(11),5300) WIN
3233 ENDIF
3234
3235C...Events defined in fixed target frame.
3236 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3237 MINT(111)=2
3238 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3239 IF(MSTP(122).GE.1) THEN
3240 LOFFS=(29-(LEN(2)+LEN(3)))/2
3241 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3242 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3243 & ' fixed target'//' '
3244 WRITE(MSTU(11),5200) CHINIT
3245 WRITE(MSTU(11),5400) WIN
3246 WRITE(MSTU(11),5500) SQRT(S)
3247 ENDIF
3248
3249C...Frame defined by user three-vectors.
3250 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3251 MINT(111)=3
3252 P(1,5)=PM(1)
3253 P(2,5)=PM(2)
3254 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3255 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3256 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3257 & (P(1,3)+P(2,3))**2
3258 IF(MSTP(122).GE.1) THEN
3259 LOFFS=(12-(LEN(2)+LEN(3)))/2
3260 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3261 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3262 & ' user-specified configuration'//' '
3263 WRITE(MSTU(11),5200) CHINIT
3264 WRITE(MSTU(11),5600)
3265 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3266 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3267 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3268 ENDIF
3269
3270C...Frame defined by user four-vectors.
3271 ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3272 MINT(111)=4
3273 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3274 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3275 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3276 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3277 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3278 & (P(1,3)+P(2,3))**2
3279 IF(MSTP(122).GE.1) THEN
3280 LOFFS=(12-(LEN(2)+LEN(3)))/2
3281 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3282 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3283 & ' user-specified configuration'//' '
3284 WRITE(MSTU(11),5200) CHINIT
3285 WRITE(MSTU(11),5600)
3286 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3287 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3288 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3289 ENDIF
3290
3291C...Frame defined by user five-vectors.
3292 ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3293 MINT(111)=5
3294 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3295 & (P(1,3)+P(2,3))**2
3296 IF(MSTP(122).GE.1) THEN
3297 LOFFS=(12-(LEN(2)+LEN(3)))/2
3298 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3299 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3300 & ' user-specified configuration'//' '
3301 WRITE(MSTU(11),5200) CHINIT
3302 WRITE(MSTU(11),5600)
3303 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3304 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3305 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3306 ENDIF
3307
3308C...Unknown frame. Error for too low CM energy.
3309 ELSE
3310 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3311 STOP
3312 ENDIF
3313 IF(S.LT.PARP(2)**2) THEN
3314 WRITE(MSTU(11),5900) SQRT(S)
3315 STOP
3316 ENDIF
3317
3318C...Formats for initialization and error information.
3319 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3320 &1X,'Execution stopped!')
3321 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3322 &1X,'Execution stopped!')
3323 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3324 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3325 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3326 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3327 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3328 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3329 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3330 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3331 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3332 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3333 &1X,'Execution stopped!')
3334 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3335 &'generation.'/1X,'Execution stopped!')
3336
3337 RETURN
3338 END
3339
3340C*********************************************************************
3341
3342C...PYINKI
3343C...Sets up kinematics, including rotations and boosts to/from CM frame.
3344
3345 SUBROUTINE PYINKI(MODKI)
3346
3347C...Double precision and integer declarations.
3348 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3349 INTEGER PYK,PYCHGE,PYCOMP
3350C...Commonblocks.
3351 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3354 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3355 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3356 COMMON/PYINT1/MINT(400),VINT(400)
3357 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3358
3359C...Set initial flavour state.
3360 N=2
3361 DO 100 I=1,2
3362 K(I,1)=1
3363 K(I,2)=MINT(10+I)
3364 100 CONTINUE
3365
3366C...Reset boost. Do kinematics for various cases.
3367 DO 110 J=6,10
3368 VINT(J)=0D0
3369 110 CONTINUE
3370
3371C...Set up kinematics for events defined in CM frame.
3372 IF(MINT(111).EQ.1) THEN
3373 WIN=VINT(290)
3374 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3375 S=WIN**2
3376 P(1,5)=VINT(3)
3377 P(2,5)=VINT(4)
3378 P(1,1)=0D0
3379 P(1,2)=0D0
3380 P(2,1)=0D0
3381 P(2,2)=0D0
3382 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3383 & (4D0*S))
3384 P(2,3)=-P(1,3)
3385 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3386 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3387
3388C...Set up kinematics for fixed target events.
3389 ELSEIF(MINT(111).EQ.2) THEN
3390 WIN=VINT(290)
3391 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3392 P(1,5)=VINT(3)
3393 P(2,5)=VINT(4)
3394 P(1,1)=0D0
3395 P(1,2)=0D0
3396 P(2,1)=0D0
3397 P(2,2)=0D0
3398 P(1,3)=WIN
3399 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3400 P(2,3)=0D0
3401 P(2,4)=P(2,5)
3402 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3403 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3404 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3405
3406C...Set up kinematics for events in user-defined frame.
3407 ELSEIF(MINT(111).EQ.3) THEN
3408 P(1,5)=VINT(3)
3409 P(2,5)=VINT(4)
3410 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3411 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3412 DO 120 J=1,3
3413 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3414 120 CONTINUE
3415 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3416 VINT(7)=PYANGL(P(1,1),P(1,2))
3417 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3418 VINT(6)=PYANGL(P(1,3),P(1,1))
3419 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3420 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3421
3422C...Set up kinematics for events with user-defined four-vectors.
3423 ELSEIF(MINT(111).EQ.4) THEN
3424 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3425 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3426 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3427 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3428 DO 130 J=1,3
3429 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3430 130 CONTINUE
3431 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3432 VINT(7)=PYANGL(P(1,1),P(1,2))
3433 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3434 VINT(6)=PYANGL(P(1,3),P(1,1))
3435 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3436 S=(P(1,4)+P(2,4))**2
3437
3438C...Set up kinematics for events with user-defined five-vectors.
3439 ELSEIF(MINT(111).EQ.5) THEN
3440 DO 140 J=1,3
3441 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3442 140 CONTINUE
3443 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3444 VINT(7)=PYANGL(P(1,1),P(1,2))
3445 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3446 VINT(6)=PYANGL(P(1,3),P(1,1))
3447 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3448 S=(P(1,4)+P(2,4))**2
3449 ENDIF
3450
3451C...Return or error for too low CM energy.
3452 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3453 IF(MSTP(172).LE.1) THEN
3454 CALL PYERRM(23,
3455 & '(PYINKI:) too low invariant mass in this event')
3456 ELSE
3457 MSTI(61)=1
3458 RETURN
3459 ENDIF
3460 ENDIF
3461
3462C...Save information on incoming particles.
3463 VINT(1)=SQRT(S)
3464 VINT(2)=S
3465 IF(MINT(111).GE.4) VINT(3)=P(1,5)
3466 IF(MINT(111).GE.4) VINT(4)=P(2,5)
3467 VINT(5)=P(1,3)
3468 IF(MODKI.EQ.0) VINT(289)=S
3469 DO 150 J=1,5
3470 V(1,J)=0D0
3471 V(2,J)=0D0
3472 VINT(290+J)=P(1,J)
3473 VINT(295+J)=P(2,J)
3474 150 CONTINUE
3475
3476C...Store pT cut-off and related constants to be used in generation.
3477 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3478 IF(MSTP(82).LE.1) THEN
3479 IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/
3480 & LOG(900D0/200D0)
3481 PTMN=PARP(81)
3482 ELSE
3483 IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/
3484 & LOG(900D0/200D0)
3485 PTMN=PARP(82)
3486 ENDIF
3487 VINT(149)=4D0*PTMN**2/S
3488
3489 RETURN
3490 END
3491
3492C*********************************************************************
3493
3494C...PYINPR
3495C...Selects partonic subprocesses to be included in the simulation.
3496
3497 SUBROUTINE PYINPR
3498
3499C...Double precision and integer declarations.
3500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3501 INTEGER PYK,PYCHGE,PYCOMP
3502C...Commonblocks.
3503 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3504 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3505 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3507 COMMON/PYINT1/MINT(400),VINT(400)
3508 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3509 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3510
3511C...Reset processes to be included.
3512 IF(MSEL.NE.0) THEN
3513 DO 100 I=1,500
3514 MSUB(I)=0
3515 100 CONTINUE
3516 ENDIF
3517
3518C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
3519 IF(MINT(121).EQ.2) THEN
3520 MSUB(10)=1
3521 MINT(123)=MINT(122)+1
3522
3523C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
3524C...Here also set a few parameters otherwise normally not touched.
3525 ELSEIF(MINT(121).GT.1) THEN
3526
3527C...Parton distributions dampened at small Q2; go to low energies,
3528C...alpha_s <1; no minimum pT cut-off a priori.
3529 MSTP(57)=3
3530 MSTP(85)=0
3531 PARP(2)=2D0
3532 PARU(115)=1D0
3533 CKIN(5)=0.2D0
3534 CKIN(6)=0.2D0
3535
3536C...Define pT cut-off parameters and whether run involves low-pT.
3537 IF(MSTP(82).LE.1) THEN
3538 PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3539 ELSE
3540 PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3541 ENDIF
3542 PTMDIR=PARP(15)
3543 PTMANO=PTMVMD
3544 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3545 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3546 IPTL=1
3547 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3548 IF(MSEL.EQ.2) IPTL=1
3549
3550C...Set up for p/VMD * VMD.
3551 IF(MINT(122).EQ.1) THEN
3552 MINT(123)=2
3553 MSUB(11)=1
3554 MSUB(12)=1
3555 MSUB(13)=1
3556 MSUB(28)=1
3557 MSUB(53)=1
3558 MSUB(68)=1
3559 IF(IPTL.EQ.1) MSUB(95)=1
3560 IF(MSEL.EQ.2) THEN
3561 MSUB(91)=1
3562 MSUB(92)=1
3563 MSUB(93)=1
3564 MSUB(94)=1
3565 ENDIF
3566 PARP(81)=PTMVMD
3567 PARP(82)=PTMVMD
3568 IF(IPTL.EQ.1) CKIN(3)=0D0
3569
3570C...Set up for p/VMD * direct gamma.
3571 ELSEIF(MINT(122).EQ.2) THEN
3572 MINT(123)=0
3573 IF(MINT(121).EQ.6) MINT(123)=5
3574 MSUB(33)=1
3575 MSUB(54)=1
3576 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3577
3578C...Set up for p/VMD * anomalous gamma.
3579 ELSEIF(MINT(122).EQ.3) THEN
3580 MINT(123)=3
3581 IF(MINT(121).EQ.6) MINT(123)=7
3582 MSUB(11)=1
3583 MSUB(12)=1
3584 MSUB(13)=1
3585 MSUB(28)=1
3586 MSUB(53)=1
3587 MSUB(68)=1
3588 IF(MSTP(82).GE.2) MSTP(85)=1
3589 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3590
3591C...Set up for direct * direct gamma (switch off leptons).
3592 ELSEIF(MINT(122).EQ.4) THEN
3593 MINT(123)=0
3594 MSUB(58)=1
3595 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3596 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3597 110 CONTINUE
3598 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3599
3600C...Set up for direct * anomalous gamma.
3601 ELSEIF(MINT(122).EQ.5) THEN
3602 MINT(123)=6
3603 MSUB(33)=1
3604 MSUB(54)=1
3605 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3606
3607C...Set up for anomalous * anomalous gamma.
3608 ELSEIF(MINT(122).EQ.6) THEN
3609 MINT(123)=3
3610 MSUB(11)=1
3611 MSUB(12)=1
3612 MSUB(13)=1
3613 MSUB(28)=1
3614 MSUB(53)=1
3615 MSUB(68)=1
3616 IF(MSTP(82).GE.2) MSTP(85)=1
3617 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3618 ENDIF
3619
3620C...End of special set up for gamma-p and gamma-gamma.
3621 CKIN(1)=2D0*CKIN(3)
3622 ENDIF
3623
3624C...Flavour information for individual beams.
3625 DO 120 I=1,2
3626 MINT(40+I)=1
3627 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
3628 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
3629 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
3630 MINT(44+I)=MINT(40+I)
3631 IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3
3632 120 CONTINUE
3633
3634C...If two gammas, whereof one direct, pick the first.
3635 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3636 IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN
3637 MINT(41)=1
3638 MINT(45)=1
3639 ENDIF
3640 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
3641 IF(MINT(123).GE.4) CALL PYERRM(26,
3642 & '(PYINPR:) unallowed MSTP(14) code for single photon')
3643 ENDIF
3644
3645C...Flavour information on combination of incoming particles.
3646 MINT(43)=2*MINT(41)+MINT(42)-2
3647 MINT(44)=MINT(43)
3648 IF(MINT(123).LE.0) THEN
3649 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
3650 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
3651 ELSEIF(MINT(123).LE.3) THEN
3652 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
3653 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
3654 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3655 MINT(43)=4
3656 MINT(44)=1
3657 ENDIF
3658 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
3659 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
3660 MINT(50)=0
3661 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
3662 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3)
3663 &MINT(50)=0
3664 MINT(107)=0
3665 IF(MINT(11).EQ.22) THEN
3666 MINT(107)=MINT(123)
3667 IF(MINT(123).GE.4) MINT(107)=0
3668 IF(MINT(123).EQ.7) MINT(107)=2
3669 ENDIF
3670 MINT(108)=0
3671 IF(MINT(12).EQ.22) THEN
3672 MINT(108)=MINT(123)
3673 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
3674 IF(MINT(123).EQ.7) MINT(108)=3
3675 ENDIF
3676
3677C...Select default processes according to incoming beams
3678C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
3679 IF(MINT(121).GT.1) THEN
3680 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
3681
3682 IF(MINT(43).EQ.1) THEN
3683C...Lepton + lepton -> gamma/Z0 or W.
3684 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
3685 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
3686
3687 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
3688 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
3689C...Unresolved photon + lepton: Compton scattering.
3690 MSUB(34)=1
3691
3692 ELSEIF(MINT(43).LE.3) THEN
3693C...Lepton + hadron: deep inelastic scattering.
3694 MSUB(10)=1
3695
3696 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
3697 & MINT(12).EQ.22) THEN
3698C...Two unresolved photons: fermion pair production.
3699 MSUB(58)=1
3700
3701 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
3702 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
3703 & MINT(12).EQ.22)) THEN
3704C...Unresolved photon + hadron: photon-parton scattering.
3705 MSUB(33)=1
3706 MSUB(34)=1
3707 MSUB(54)=1
3708
3709 ELSEIF(MSEL.EQ.1) THEN
3710C...High-pT QCD processes:
3711 MSUB(11)=1
3712 MSUB(12)=1
3713 MSUB(13)=1
3714 MSUB(28)=1
3715 MSUB(53)=1
3716 MSUB(68)=1
3717 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
3718 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
3719 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
3720
3721 ELSE
3722C...All QCD processes:
3723 MSUB(11)=1
3724 MSUB(12)=1
3725 MSUB(13)=1
3726 MSUB(28)=1
3727 MSUB(53)=1
3728 MSUB(68)=1
3729 MSUB(91)=1
3730 MSUB(92)=1
3731 MSUB(93)=1
3732 MSUB(94)=1
3733 MSUB(95)=1
3734 ENDIF
3735
3736 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
3737C...Heavy quark production.
3738 MSUB(81)=1
3739 MSUB(82)=1
3740 MSUB(84)=1
3741 DO 130 J=1,MIN(8,MDCY(21,3))
3742 MDME(MDCY(21,2)+J-1,1)=0
3743 130 CONTINUE
3744 MDME(MDCY(21,2)+MSEL-1,1)=1
3745 MSUB(85)=1
3746 DO 140 J=1,MIN(12,MDCY(22,3))
3747 MDME(MDCY(22,2)+J-1,1)=0
3748 140 CONTINUE
3749 MDME(MDCY(22,2)+MSEL-1,1)=1
3750
3751 ELSEIF(MSEL.EQ.10) THEN
3752C...Prompt photon production:
3753 MSUB(14)=1
3754 MSUB(18)=1
3755 MSUB(29)=1
3756
3757 ELSEIF(MSEL.EQ.11) THEN
3758C...Z0/gamma* production:
3759 MSUB(1)=1
3760
3761 ELSEIF(MSEL.EQ.12) THEN
3762C...W+/- production:
3763 MSUB(2)=1
3764
3765 ELSEIF(MSEL.EQ.13) THEN
3766C...Z0 + jet:
3767 MSUB(15)=1
3768 MSUB(30)=1
3769
3770 ELSEIF(MSEL.EQ.14) THEN
3771C...W+/- + jet:
3772 MSUB(16)=1
3773 MSUB(31)=1
3774
3775 ELSEIF(MSEL.EQ.15) THEN
3776C...Z0 & W+/- pair production:
3777 MSUB(19)=1
3778 MSUB(20)=1
3779 MSUB(22)=1
3780 MSUB(23)=1
3781 MSUB(25)=1
3782
3783 ELSEIF(MSEL.EQ.16) THEN
3784C...h0 production:
3785 MSUB(3)=1
3786 MSUB(102)=1
3787 MSUB(103)=1
3788 MSUB(123)=1
3789 MSUB(124)=1
3790
3791 ELSEIF(MSEL.EQ.17) THEN
3792C...h0 & Z0 or W+/- pair production:
3793 MSUB(24)=1
3794 MSUB(26)=1
3795
3796 ELSEIF(MSEL.EQ.18) THEN
3797C...h0 production; interesting processes in e+e-.
3798 MSUB(24)=1
3799 MSUB(103)=1
3800 MSUB(123)=1
3801 MSUB(124)=1
3802
3803 ELSEIF(MSEL.EQ.19) THEN
3804C...h0, H0 and A0 production; interesting processes in e+e-.
3805 MSUB(24)=1
3806 MSUB(103)=1
3807 MSUB(123)=1
3808 MSUB(124)=1
3809 MSUB(153)=1
3810 MSUB(171)=1
3811 MSUB(173)=1
3812 MSUB(174)=1
3813 MSUB(158)=1
3814 MSUB(176)=1
3815 MSUB(178)=1
3816 MSUB(179)=1
3817
3818 ELSEIF(MSEL.EQ.21) THEN
3819C...Z'0 production:
3820 MSUB(141)=1
3821
3822 ELSEIF(MSEL.EQ.22) THEN
3823C...W'+/- production:
3824 MSUB(142)=1
3825
3826 ELSEIF(MSEL.EQ.23) THEN
3827C...H+/- production:
3828 MSUB(143)=1
3829
3830 ELSEIF(MSEL.EQ.24) THEN
3831C...R production:
3832 MSUB(144)=1
3833
3834 ELSEIF(MSEL.EQ.25) THEN
3835C...LQ (leptoquark) production.
3836 MSUB(145)=1
3837 MSUB(162)=1
3838 MSUB(163)=1
3839 MSUB(164)=1
3840
3841 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
3842C...Production of one heavy quark (W exchange):
3843 MSUB(83)=1
3844 DO 150 J=1,MIN(8,MDCY(21,3))
3845 MDME(MDCY(21,2)+J-1,1)=0
3846 150 CONTINUE
3847 MDME(MDCY(21,2)+MSEL-31,1)=1
3848
3849CMRENNA++Define SUSY alternatives.
3850 ELSEIF(MSEL.EQ.39) THEN
3851C...Turn on all SUSY processes.
3852 IF(MINT(43).EQ.4) THEN
3853C...Hadron-hadron processes.
3854 DO 160 I=201,280
3855 IF(ISET(I).GE.0) MSUB(I)=1
3856 160 CONTINUE
3857 ELSEIF(MINT(43).EQ.1) THEN
3858C...Lepton-lepton processes: QED production of squarks.
3859 DO 170 I=201,214
3860 MSUB(I)=1
3861 170 CONTINUE
3862 MSUB(210)=0
3863 MSUB(211)=0
3864 MSUB(212)=0
3865 DO 180 I=216,228
3866 MSUB(I)=1
3867 180 CONTINUE
3868 DO 190 I=261,263
3869 MSUB(I)=1
3870 190 CONTINUE
3871 MSUB(277)=1
3872 MSUB(278)=1
3873 ENDIF
3874
3875 ELSEIF(MSEL.EQ.40) THEN
3876C...Gluinos and squarks.
3877 IF(MINT(43).EQ.4) THEN
3878 MSUB(243)=1
3879 MSUB(244)=1
3880 MSUB(258)=1
3881 MSUB(259)=1
3882 MSUB(261)=1
3883 MSUB(262)=1
3884 MSUB(264)=1
3885 MSUB(265)=1
3886 DO 200 I=271,280
3887 MSUB(I)=1
3888 200 CONTINUE
3889 ELSEIF(MINT(43).EQ.1) THEN
3890 MSUB(277)=1
3891 MSUB(278)=1
3892 ENDIF
3893
3894 ELSEIF(MSEL.EQ.41) THEN
3895C...Stop production.
3896 MSUB(261)=1
3897 MSUB(262)=1
3898 MSUB(263)=1
3899 IF(MINT(43).EQ.4) THEN
3900 MSUB(264)=1
3901 MSUB(265)=1
3902 ENDIF
3903
3904 ELSEIF(MSEL.EQ.42) THEN
3905C...Slepton production.
3906 DO 210 I=201,214
3907 MSUB(I)=1
3908 210 CONTINUE
3909 IF(MINT(43).NE.4) THEN
3910 MSUB(210)=0
3911 MSUB(211)=0
3912 MSUB(212)=0
3913 ENDIF
3914
3915 ELSEIF(MSEL.EQ.43) THEN
3916C...Neutralino/Chargino + Gluino/Squark.
3917 IF(MINT(43).EQ.4) THEN
3918 DO 220 I=237,242
3919 MSUB(I)=1
3920 220 CONTINUE
3921 DO 230 I=246,257
3922 MSUB(I)=1
3923 230 CONTINUE
3924 ENDIF
3925
3926 ELSEIF(MSEL.EQ.44) THEN
3927C...Neutralino/Chargino pair production.
3928 IF(MINT(43).EQ.4) THEN
3929 DO 240 I=216,236
3930 MSUB(I)=1
3931 240 CONTINUE
3932 ELSEIF(MINT(43).EQ.1) THEN
3933 DO 250 I=216,228
3934 MSUB(I)=1
3935 250 CONTINUE
3936 ENDIF
3937 ENDIF
3938
3939C...Find heaviest new quark flavour allowed in processes 81-84.
3940 KFLQM=1
3941 DO 260 I=1,MIN(8,MDCY(21,3))
3942 IDC=I+MDCY(21,2)-1
3943 IF(MDME(IDC,1).LE.0) GOTO 260
3944 KFLQM=I
3945 260 CONTINUE
3946 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
3947 &KFLQM=MSTP(7)
3948 MINT(55)=KFLQM
3949 KFPR(81,1)=KFLQM
3950 KFPR(81,2)=KFLQM
3951 KFPR(82,1)=KFLQM
3952 KFPR(82,2)=KFLQM
3953 KFPR(83,1)=KFLQM
3954 KFPR(84,1)=KFLQM
3955 KFPR(84,2)=KFLQM
3956
3957C...Find heaviest new fermion flavour allowed in process 85.
3958 KFLFM=1
3959 DO 270 I=1,MIN(12,MDCY(22,3))
3960 IDC=I+MDCY(22,2)-1
3961 IF(MDME(IDC,1).LE.0) GOTO 270
3962 KFLFM=KFDP(IDC,1)
3963 270 CONTINUE
3964 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
3965 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
3966 MINT(56)=KFLFM
3967 KFPR(85,1)=KFLFM
3968 KFPR(85,2)=KFLFM
3969
3970 RETURN
3971 END
3972
3973C*********************************************************************
3974
3975C...PYXTOT
3976C...Parametrizes total, elastic and diffractive cross-sections
3977C...for different energies and beams. Donnachie-Landshoff for
3978C...total and Schuler-Sjostrand for elastic and diffractive.
3979C...Process code IPROC:
3980C...= 1 : p + p;
3981C...= 2 : pbar + p;
3982C...= 3 : pi+ + p;
3983C...= 4 : pi- + p;
3984C...= 5 : pi0 + p;
3985C...= 6 : phi + p;
3986C...= 7 : J/psi + p;
3987C...= 11 : rho + rho;
3988C...= 12 : rho + phi;
3989C...= 13 : rho + J/psi;
3990C...= 14 : phi + phi;
3991C...= 15 : phi + J/psi;
3992C...= 16 : J/psi + J/psi;
3993C...= 21 : gamma + p (DL);
3994C...= 22 : gamma + p (VDM).
3995C...= 23 : gamma + pi (DL);
3996C...= 24 : gamma + pi (VDM);
3997C...= 25 : gamma + gamma (DL);
3998C...= 26 : gamma + gamma (VDM).
3999
4000 SUBROUTINE PYXTOT
4001
4002C...Double precision and integer declarations.
4003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4004 INTEGER PYK,PYCHGE,PYCOMP
4005C...Commonblocks.
4006 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4007 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4008 COMMON/PYINT1/MINT(400),VINT(400)
4009 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4010 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4011 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4012C...Local arrays.
4013 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4014 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4015 &CEFFD(10,9),SIGTMP(6,0:5)
4016
4017C...Common constants.
4018 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4019 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4020 &FACDD/0.0084D0/
4021
4022C...Number of multiple processes to be evaluated (= 0 : undefined).
4023 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4024C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4025 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4026 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4027 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4028 DATA YPAR/
4029 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4030 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4031 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4032
4033C...Beam and target hadron class:
4034C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4035 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4036 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4037C...Characteristic class masses, slope parameters, beta = sqrt(X).
4038 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4039 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4040 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4041
4042C...Fitting constants used in parametrizations of diffractive results.
4043 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4044 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4045 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4046 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4047 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4048 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4049 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4050 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
4051 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4052 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4053 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4054 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4055 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4056 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4057 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
4058 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
4059 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
4060 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
4061 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
4062 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
4063 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
4064 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
4065 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
4066 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
4067 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
4068 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
4069 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
4070 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
4071 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4072
4073C...Parameters. Combinations of the energy.
4074 AEM=PARU(101)
4075 PMTH=PARP(102)
4076 S=VINT(2)
4077 SRT=VINT(1)
4078 SEPS=S**EPS
4079 SETA=S**ETA
4080 SLOG=LOG(S)
4081
4082C...Ratio of gamma/pi (for rescaling in parton distributions).
4083 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4084 &(XPAR(5)*SEPS+YPAR(5)*SETA)
4085 IF(MINT(50).NE.1) RETURN
4086
4087C...Order flavours of incoming particles: KF1 < KF2.
4088 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4089 KF1=IABS(MINT(11))
4090 KF2=IABS(MINT(12))
4091 IORD=1
4092 ELSE
4093 KF1=IABS(MINT(12))
4094 KF2=IABS(MINT(11))
4095 IORD=2
4096 ENDIF
4097 ISGN12=ISIGN(1,MINT(11)*MINT(12))
4098
4099C...Find process number (for lookup tables).
4100 IF(KF1.GT.1000) THEN
4101 IPROC=1
4102 IF(ISGN12.LT.0) IPROC=2
4103 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4104 IPROC=3
4105 IF(ISGN12.LT.0) IPROC=4
4106 IF(KF1.EQ.111) IPROC=5
4107 ELSEIF(KF1.GT.100) THEN
4108 IPROC=11
4109 ELSEIF(KF2.GT.1000) THEN
4110 IPROC=21
4111 IF(MINT(123).EQ.2) IPROC=22
4112 ELSEIF(KF2.GT.100) THEN
4113 IPROC=23
4114 IF(MINT(123).EQ.2) IPROC=24
4115 ELSE
4116 IPROC=25
4117 IF(MINT(123).EQ.2) IPROC=26
4118 ENDIF
4119
4120C... Number of multiple processes to be stored; beam/target side.
4121 NPR=NPROC(IPROC)
4122 MINT(101)=1
4123 MINT(102)=1
4124 IF(NPR.EQ.3) THEN
4125 MINT(100+IORD)=4
4126 ELSEIF(NPR.EQ.6) THEN
4127 MINT(101)=4
4128 MINT(102)=4
4129 ENDIF
4130 N1=0
4131 IF(MINT(101).EQ.4) N1=4
4132 N2=0
4133 IF(MINT(102).EQ.4) N2=4
4134
4135C...Do not do any more for user-set or undefined cross-sections.
4136 IF(MSTP(31).LE.0) RETURN
4137 IF(NPR.EQ.0) CALL PYERRM(26,
4138 &'(PYXTOT:) cross section for this process not yet implemented')
4139
4140C...Parameters. Combinations of the energy.
4141 AEM=PARU(101)
4142 PMTH=PARP(102)
4143 S=VINT(2)
4144 SRT=VINT(1)
4145 SEPS=S**EPS
4146 SETA=S**ETA
4147 SLOG=LOG(S)
4148
4149C...Loop over multiple processes (for VDM).
4150 DO 110 I=1,NPR
4151 IF(NPR.EQ.1) THEN
4152 IPR=IPROC
4153 ELSEIF(NPR.EQ.3) THEN
4154 IPR=I+4
4155 IF(KF2.LT.1000) IPR=I+10
4156 ELSEIF(NPR.EQ.6) THEN
4157 IPR=I+10
4158 ENDIF
4159
4160C...Evaluate hadron species, mass, slope contribution and fit number.
4161 IHA=IHADA(IPR)
4162 IHB=IHADB(IPR)
4163 PMA=PMHAD(IHA)
4164 PMB=PMHAD(IHB)
4165 BHA=BHAD(IHA)
4166 BHB=BHAD(IHB)
4167 ISD=IFITSD(IPR)
4168 IDD=IFITDD(IPR)
4169
4170C...Skip if energy too low relative to masses.
4171 DO 100 J=0,5
4172 SIGTMP(I,J)=0D0
4173 100 CONTINUE
4174 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4175
4176C...Total cross-section. Elastic slope parameter and cross-section.
4177 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4178 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4179 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4180
4181C...Diffractive scattering A + B -> X + B.
4182 BSD=2D0*BHB
4183 SQML=(PMA+PMTH)**2
4184 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4185 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4186 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4187 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4188 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4189 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4190 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4191
4192C...Diffractive scattering A + B -> A + X.
4193 BSD=2D0*BHA
4194 SQML=(PMB+PMTH)**2
4195 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4196 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4197 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4198 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4199 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4200 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4201 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4202
4203C...Order single diffractive correctly.
4204 IF(IORD.EQ.2) THEN
4205 SIGSAV=SIGTMP(I,2)
4206 SIGTMP(I,2)=SIGTMP(I,3)
4207 SIGTMP(I,3)=SIGSAV
4208 ENDIF
4209
4210C...Double diffractive scattering A + B -> X1 + X2.
4211 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4212 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4213 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4214 IF(YEFF.LE.0) SUM1=0D0
4215 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4216 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4217 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4218 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4219 & (2D0*ALP)
4220 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4221 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4222 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4223 & (2D0*ALP)
4224 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4225 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4226 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4227 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4228 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4229
4230C...Non-diffractive by unitarity.
4231 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4232 & SIGTMP(I,4)
4233 110 CONTINUE
4234
4235C...Put temporary results in output array: only one process.
4236 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4237 DO 120 J=0,5
4238 SIGT(0,0,J)=SIGTMP(1,J)
4239 120 CONTINUE
4240
4241C...Beam multiple processes.
4242 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4243 DO 140 I=1,4
4244 CONV=AEM/PARP(160+I)
4245 I1=MAX(1,I-1)
4246 DO 130 J=0,5
4247 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4248 130 CONTINUE
4249 140 CONTINUE
4250 DO 150 J=0,5
4251 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4252 150 CONTINUE
4253
4254C...Target multiple processes.
4255 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4256 DO 170 I=1,4
4257 CONV=AEM/PARP(160+I)
4258 IV=MAX(1,I-1)
4259 DO 160 J=0,5
4260 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4261 160 CONTINUE
4262 170 CONTINUE
4263 DO 180 J=0,5
4264 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4265 180 CONTINUE
4266
4267C...Both beam and target multiple processes.
4268 ELSE
4269 DO 210 I1=1,4
4270 DO 200 I2=1,4
4271 CONV=AEM**2/(PARP(160+I1)*PARP(160+I2))
4272 IF(I1.LE.2) THEN
4273 IV=MAX(1,I2-1)
4274 ELSEIF(I2.LE.2) THEN
4275 IV=MAX(1,I1-1)
4276 ELSEIF(I1.EQ.I2) THEN
4277 IV=2*I1-2
4278 ELSE
4279 IV=5
4280 ENDIF
4281 DO 190 J=0,5
4282 JV=J
4283 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4284 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4285 190 CONTINUE
4286 200 CONTINUE
4287 210 CONTINUE
4288 DO 230 J=0,5
4289 DO 220 I=1,4
4290 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4291 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4292 220 CONTINUE
4293 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4294 230 CONTINUE
4295 ENDIF
4296
4297C...Scale up uniformly for Donnachie-Landshoff parametrization.
4298 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4299 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4300 DO 260 I1=0,N1
4301 DO 250 I2=0,N2
4302 DO 240 J=0,5
4303 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4304 240 CONTINUE
4305 250 CONTINUE
4306 260 CONTINUE
4307 ENDIF
4308
4309 RETURN
4310 END
4311
4312C*********************************************************************
4313
4314C...PYMAXI
4315C...Finds optimal set of coefficients for kinematical variable selection
4316C...and the maximum of the part of the differential cross-section used
4317C...in the event weighting.
4318
4319 SUBROUTINE PYMAXI
4320
4321C...Double precision and integer declarations.
4322 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4323 INTEGER PYK,PYCHGE,PYCOMP
4324C...Parameter statement to help give large particle numbers.
4325 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4326C...Commonblocks.
4327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4329 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4330 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4331 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4332 COMMON/PYINT1/MINT(400),VINT(400)
4333 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4334 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4335 COMMON/PYINT4/MWID(500),WIDS(500,5)
4336 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4337 COMMON/PYINT6/PROC(0:500)
4338 CHARACTER PROC*28
4339 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4340 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4341 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4342C...Local arrays, character variables and data.
4343 CHARACTER CVAR(4)*4
4344 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4345 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4346 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4347 DATA CVAR/'tau ','tau''','y* ','cth '/
4348 DATA SIGSSM/3*0D0/
4349
4350C...Select subprocess to study: skip cases not applicable.
4351 NPOSI=0
4352 VINT(143)=1D0
4353 VINT(144)=1D0
4354 XSEC(0,1)=0D0
4355 DO 460 ISUB=1,500
4356 MINT(51)=0
4357 IF(ISET(ISUB).EQ.11) THEN
4358 XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
4359 NPOSI=NPOSI+1
4360 GOTO 450
4361 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
4362 XSEC(ISUB,1)=SIGT(0,0,ISUB-90)
4363 IF(MSUB(ISUB).NE.1) GOTO 460
4364 NPOSI=NPOSI+1
4365 GOTO 450
4366 ELSEIF(ISUB.EQ.96) THEN
4367 IF(MINT(50).EQ.0) GOTO 460
4368 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
4369 & GOTO 460
4370 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
4371 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
4372 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
4373 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
4374 ELSE
4375 IF(MSUB(ISUB).NE.1) GOTO 460
4376 ENDIF
4377 MINT(1)=ISUB
4378 ISTSB=ISET(ISUB)
4379 IF(ISUB.EQ.96) ISTSB=2
4380 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
4381 MWTXS=0
4382 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
4383 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
4384
4385C...Find resonances (explicit or implicit in cross-section).
4386 MINT(72)=0
4387 KFR1=0
4388 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
4389 KFR1=KFPR(ISUB,1)
4390 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
4391 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
4392 KFR1=23
4393 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
4394 & .OR.ISUB.EQ.177) THEN
4395 KFR1=24
4396 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
4397 KFR1=25
4398 IF(MSTP(46).EQ.5) THEN
4399 KFR1=30
4400 PMAS(30,1)=PARP(45)
4401 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
4402 ENDIF
4403 ELSEIF(ISUB.EQ.194) THEN
4404 KFR1=54
4405 ENDIF
4406 CKMX=CKIN(2)
4407 IF(CKMX.LE.0D0) CKMX=VINT(1)
4408 KCR1=PYCOMP(KFR1)
4409 IF(KFR1.NE.0) THEN
4410 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
4411 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
4412 ENDIF
4413 IF(KFR1.NE.0) THEN
4414 TAUR1=PMAS(KCR1,1)**2/VINT(2)
4415 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
4416 MINT(72)=1
4417 MINT(73)=KFR1
4418 VINT(73)=TAUR1
4419 VINT(74)=GAMR1
4420 ENDIF
4421 KFR2=0
4422 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
4423 KFR2=23
4424 IF(ISUB.EQ.194) KFR2=56
4425 KCR2=PYCOMP(KFR2)
4426 TAUR2=PMAS(KCR2,1)**2/VINT(2)
4427 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
4428 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
4429 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
4430 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
4431 MINT(72)=2
4432 MINT(74)=KFR2
4433 VINT(75)=TAUR2
4434 VINT(76)=GAMR2
4435 ELSEIF(KFR2.NE.0) THEN
4436 KFR1=KFR2
4437 TAUR1=TAUR2
4438 GAMR1=GAMR2
4439 MINT(72)=1
4440 MINT(73)=KFR1
4441 VINT(73)=TAUR1
4442 VINT(74)=GAMR1
4443 KFR2=0
4444 ENDIF
4445 ENDIF
4446
4447C...Find product masses and minimum pT of process.
4448 SQM3=0D0
4449 SQM4=0D0
4450 MINT(71)=0
4451 VINT(71)=CKIN(3)
4452 VINT(80)=1D0
4453 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4454 NBW=0
4455 DO 110 I=1,2
4456 PMMN(I)=0D0
4457 IF(KFPR(ISUB,I).EQ.0) THEN
4458 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
4459 & PARP(41)) THEN
4460 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4461 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4462 ELSE
4463 NBW=NBW+1
4464C...This prevents SUSY/t particles from becoming too light.
4465 KFLW=KFPR(ISUB,I)
4466 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
4467 KCW=PYCOMP(KFLW)
4468 PMMN(I)=PMAS(KCW,1)
4469 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
4470 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
4471 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
4472 & PMAS(PYCOMP(KFDP(IDC,2)),1)
4473 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
4474 & PMAS(PYCOMP(KFDP(IDC,3)),1)
4475 PMMN(I)=MIN(PMMN(I),PMSUM)
4476 ENDIF
4477 100 CONTINUE
4478 ELSEIF(KFLW.EQ.6) THEN
4479 PMMN(I)=PMAS(24,1)+PMAS(5,1)
4480 ENDIF
4481 ENDIF
4482 110 CONTINUE
4483 IF(NBW.GE.1) THEN
4484 CKIN41=CKIN(41)
4485 CKIN43=CKIN(43)
4486 CKIN(41)=MAX(PMMN(1),CKIN(41))
4487 CKIN(43)=MAX(PMMN(2),CKIN(43))
4488 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
4489 CKIN(41)=CKIN41
4490 CKIN(43)=CKIN43
4491 IF(MINT(51).EQ.1) THEN
4492 WRITE(MSTU(11),5100) ISUB
4493 MSUB(ISUB)=0
4494 GOTO 460
4495 ENDIF
4496 SQM3=PQM3**2
4497 SQM4=PQM4**2
4498 ENDIF
4499 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
4500 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
4501 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
4502 IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82)
4503 ENDIF
4504 VINT(63)=SQM3
4505 VINT(64)=SQM4
4506
4507C...Prepare for additional variable choices in 2 -> 3.
4508 IF(ISTSB.EQ.5) THEN
4509 VINT(201)=0D0
4510 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
4511 VINT(206)=VINT(201)
4512 VINT(204)=PMAS(23,1)
4513 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
4514 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
4515 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
4516 VINT(209)=VINT(204)
4517 ENDIF
4518
4519C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
4520 NPTS(1)=2+2*MINT(72)
4521 IF(MINT(47).EQ.1) THEN
4522 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
4523 ELSEIF(MINT(47).EQ.5) THEN
4524 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
4525 ENDIF
4526 NPTS(2)=1
4527 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
4528 IF(MINT(47).GE.2) NPTS(2)=2
4529 IF(MINT(47).EQ.5) NPTS(2)=3
4530 ENDIF
4531 NPTS(3)=1
4532 IF(MINT(47).GE.4) NPTS(3)=3
4533 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
4534 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
4535 NPTS(4)=1
4536 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
4537 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
4538
4539C...Reset coefficients of cross-section weighting.
4540 DO 120 J=1,20
4541 COEF(ISUB,J)=0D0
4542 120 CONTINUE
4543 COEF(ISUB,1)=1D0
4544 COEF(ISUB,8)=0.5D0
4545 COEF(ISUB,9)=0.5D0
4546 COEF(ISUB,13)=1D0
4547 COEF(ISUB,18)=1D0
4548 MCTH=0
4549 MTAUP=0
4550 METAUP=0
4551 VINT(23)=0D0
4552 VINT(26)=0D0
4553 SIGSAM=0D0
4554
4555C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
4556C...in grid of phase space points.
4557 CALL PYKLIM(1)
4558 METAU=MINT(51)
4559 NACC=0
4560 DO 150 ITRY=1,NTRY
4561 MINT(51)=0
4562 IF(METAU.EQ.1) GOTO 150
4563 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
4564 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
4565 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
4566 RTAU=0.5D0
4567C...Special case when both resonances have same mass,
4568C...as is often the case in process 194.
4569 IF(MINT(72).EQ.2) THEN
4570 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
4571 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
4572 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
4573 RTAU=0.4D0
4574 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
4575 RTAU=0.6D0
4576 ENDIF
4577 ENDIF
4578 ENDIF
4579 CALL PYKMAP(1,MTAU,RTAU)
4580 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
4581 METAUP=MINT(51)
4582 ENDIF
4583 IF(METAUP.EQ.1) GOTO 150
4584 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
4585 & .EQ.0) THEN
4586 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
4587 CALL PYKMAP(4,MTAUP,0.5D0)
4588 ENDIF
4589 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
4590 CALL PYKLIM(2)
4591 MEYST=MINT(51)
4592 ENDIF
4593 IF(MEYST.EQ.1) GOTO 150
4594 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
4595 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
4596 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
4597 CALL PYKMAP(2,MYST,0.5D0)
4598 CALL PYKLIM(3)
4599 MECTH=MINT(51)
4600 ENDIF
4601 IF(MECTH.EQ.1) GOTO 150
4602 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4603 MCTH=1+MOD(ITRY-1,NPTS(4))
4604 CALL PYKMAP(3,MCTH,0.5D0)
4605 ENDIF
4606 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
4607
4608C...Store position and limits.
4609 MINT(51)=0
4610 CALL PYKLIM(0)
4611 IF(MINT(51).EQ.1) GOTO 150
4612 NACC=NACC+1
4613 MVARPT(NACC,1)=MTAU
4614 MVARPT(NACC,2)=MTAUP
4615 MVARPT(NACC,3)=MYST
4616 MVARPT(NACC,4)=MCTH
4617 DO 130 J=1,30
4618 VINTPT(NACC,J)=VINT(10+J)
4619 130 CONTINUE
4620
4621C...Normal case: calculate cross-section.
4622 IF(ISTSB.NE.5) THEN
4623 CALL PYSIGH(NCHN,SIGS)
4624 IF(MWTXS.EQ.1) THEN
4625 CALL PYEVWT(WTXS)
4626 SIGS=WTXS*SIGS
4627 ENDIF
4628
4629C..2 -> 3: find highest value out of a number of tries.
4630 ELSE
4631 SIGS=0D0
4632 DO 140 IKIN3=1,MSTP(129)
4633 CALL PYKMAP(5,0,0D0)
4634 IF(MINT(51).EQ.1) GOTO 140
4635 CALL PYSIGH(NCHN,SIGTMP)
4636 IF(MWTXS.EQ.1) THEN
4637 CALL PYEVWT(WTXS)
4638 SIGTMP=WTXS*SIGTMP
4639 ENDIF
4640 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4641 140 CONTINUE
4642 ENDIF
4643
4644C...Store cross-section.
4645 SIGSPT(NACC)=SIGS
4646 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
4647 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
4648 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
4649 150 CONTINUE
4650 IF(NACC.EQ.0) THEN
4651 WRITE(MSTU(11),5100) ISUB
4652 MSUB(ISUB)=0
4653 GOTO 460
4654 ELSEIF(SIGSAM.EQ.0D0) THEN
4655 WRITE(MSTU(11),5300) ISUB
4656 MSUB(ISUB)=0
4657 GOTO 460
4658 ENDIF
4659 IF(ISUB.NE.96) NPOSI=NPOSI+1
4660
4661C...Calculate integrals in tau over maximal phase space limits.
4662 TAUMIN=VINT(11)
4663 TAUMAX=VINT(31)
4664 ATAU1=LOG(TAUMAX/TAUMIN)
4665 IF(NPTS(1).GE.2) THEN
4666 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
4667 ENDIF
4668 IF(NPTS(1).GE.4) THEN
4669 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
4670 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
4671 & GAMR1
4672 ENDIF
4673 IF(NPTS(1).GE.6) THEN
4674 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
4675 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
4676 & GAMR2
4677 ENDIF
4678 IF(NPTS(1).GT.2+2*MINT(72)) THEN
4679 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
4680 ENDIF
4681
4682C...Reset. Sum up cross-sections in points calculated.
4683 DO 320 IVAR=1,4
4684 IF(NPTS(IVAR).EQ.1) GOTO 320
4685 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
4686 NBIN=NPTS(IVAR)
4687 DO 170 J1=1,NBIN
4688 NAREL(J1)=0
4689 WTREL(J1)=0D0
4690 COEFU(J1)=0D0
4691 DO 160 J2=1,NBIN
4692 WTMAT(J1,J2)=0D0
4693 160 CONTINUE
4694 170 CONTINUE
4695 DO 180 IACC=1,NACC
4696 IBIN=MVARPT(IACC,IVAR)
4697 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
4698 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
4699 NAREL(IBIN)=NAREL(IBIN)+1
4700 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
4701
4702C...Sum up tau cross-section pieces in points used.
4703 IF(IVAR.EQ.1) THEN
4704 TAU=VINTPT(IACC,11)
4705 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4706 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
4707 IF(NBIN.GE.4) THEN
4708 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
4709 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
4710 & ((TAU-TAUR1)**2+GAMR1**2)
4711 ENDIF
4712 IF(NBIN.GE.6) THEN
4713 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
4714 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
4715 & ((TAU-TAUR2)**2+GAMR2**2)
4716 ENDIF
4717 IF(NBIN.GT.2+2*MINT(72)) THEN
4718 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
4719 & TAU/MAX(2D-6,1D0-TAU)
4720 ENDIF
4721
4722C...Sum up tau' cross-section pieces in points used.
4723 ELSEIF(IVAR.EQ.2) THEN
4724 TAU=VINTPT(IACC,11)
4725 TAUP=VINTPT(IACC,16)
4726 TAUPMN=VINTPT(IACC,6)
4727 TAUPMX=VINTPT(IACC,26)
4728 ATAUP1=LOG(TAUPMX/TAUPMN)
4729 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
4730 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4731 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
4732 & (1D0-TAU/TAUP)**3/TAUP
4733 IF(NBIN.GE.3) THEN
4734 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
4735 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
4736 & TAUP/MAX(2D-6,1D0-TAUP)
4737 ENDIF
4738
4739C...Sum up y* cross-section pieces in points used.
4740 ELSEIF(IVAR.EQ.3) THEN
4741 YST=VINTPT(IACC,12)
4742 YSTMIN=VINTPT(IACC,2)
4743 YSTMAX=VINTPT(IACC,22)
4744 AYST0=YSTMAX-YSTMIN
4745 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
4746 AYST2=AYST1
4747 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
4748 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
4749 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
4750 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
4751 IF(MINT(45).EQ.3) THEN
4752 TAUE=VINTPT(IACC,11)
4753 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4754 YST0=-0.5D0*LOG(TAUE)
4755 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
4756 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
4757 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
4758 & MAX(1D-6,1D0-EXP(YST-YST0))
4759 ENDIF
4760 IF(MINT(46).EQ.3) THEN
4761 TAUE=VINTPT(IACC,11)
4762 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4763 YST0=-0.5D0*LOG(TAUE)
4764 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
4765 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
4766 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
4767 & MAX(1D-6,1D0-EXP(-YST-YST0))
4768 ENDIF
4769
4770C...Sum up cos(theta-hat) cross-section pieces in points used.
4771 ELSE
4772 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
4773 RSQM=1D0+RM34
4774 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
4775 CTHMIN=-CTHMAX
4776 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
4777 & (TAUMAX*VINT(2)))
4778 ACTH1=CTHMAX-CTHMIN
4779 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
4780 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
4781 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
4782 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
4783 CTH=VINTPT(IACC,13)
4784 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4785 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
4786 & MAX(RM34,RSQM-CTH)
4787 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
4788 & MAX(RM34,RSQM+CTH)
4789 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
4790 & MAX(RM34,RSQM-CTH)**2
4791 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
4792 & MAX(RM34,RSQM+CTH)**2
4793 ENDIF
4794 180 CONTINUE
4795
4796C...Check that equation system solvable.
4797 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
4798 MSOLV=1
4799 WTRELS=0D0
4800 DO 190 IBIN=1,NBIN
4801 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
4802 & IRED=1,NBIN),WTREL(IBIN)
4803 IF(NAREL(IBIN).EQ.0) MSOLV=0
4804 WTRELS=WTRELS+WTREL(IBIN)
4805 190 CONTINUE
4806 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
4807
4808C...Solve to find relative importance of cross-section pieces.
4809 IF(MSOLV.EQ.1) THEN
4810 DO 200 IBIN=1,NBIN
4811 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
4812 200 CONTINUE
4813 DO 230 IRED=1,NBIN-1
4814 DO 220 IBIN=IRED+1,NBIN
4815 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
4816 MSOLV=0
4817 GOTO 260
4818 ENDIF
4819 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
4820 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
4821 DO 210 ICOE=IRED,NBIN
4822 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
4823 210 CONTINUE
4824 220 CONTINUE
4825 230 CONTINUE
4826 DO 250 IRED=NBIN,1,-1
4827 DO 240 ICOE=IRED+1,NBIN
4828 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
4829 240 CONTINUE
4830 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
4831 250 CONTINUE
4832 ENDIF
4833
4834C...Share evenly if failure.
4835 260 IF(MSOLV.EQ.0) THEN
4836 DO 270 IBIN=1,NBIN
4837 COEFU(IBIN)=1D0
4838 WTRELN(IBIN)=0.1D0
4839 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
4840 & WTREL(IBIN)/WTRELS)
4841 270 CONTINUE
4842 ENDIF
4843
4844C...Normalize coefficients, with piece shared democratically.
4845 COEFSU=0D0
4846 WTRELS=0D0
4847 DO 280 IBIN=1,NBIN
4848 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
4849 COEFSU=COEFSU+COEFU(IBIN)
4850 WTRELS=WTRELS+WTRELN(IBIN)
4851 280 CONTINUE
4852 IF(COEFSU.GT.0D0) THEN
4853 DO 290 IBIN=1,NBIN
4854 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
4855 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
4856 290 CONTINUE
4857 ELSE
4858 DO 300 IBIN=1,NBIN
4859 COEFO(IBIN)=1D0/NBIN
4860 300 CONTINUE
4861 ENDIF
4862 IF(IVAR.EQ.1) IOFF=0
4863 IF(IVAR.EQ.2) IOFF=17
4864 IF(IVAR.EQ.3) IOFF=7
4865 IF(IVAR.EQ.4) IOFF=12
4866 DO 310 IBIN=1,NBIN
4867 ICOF=IOFF+IBIN
4868 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
4869 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
4870 COEF(ISUB,ICOF)=COEFO(IBIN)
4871 310 CONTINUE
4872 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
4873 & (COEFO(IBIN),IBIN=1,NBIN)
4874 320 CONTINUE
4875
4876C...Find two most promising maxima among points previously determined.
4877 DO 330 J=1,4
4878 IACCMX(J)=0
4879 SIGSMX(J)=0D0
4880 330 CONTINUE
4881 NMAX=0
4882 DO 390 IACC=1,NACC
4883 DO 340 J=1,30
4884 VINT(10+J)=VINTPT(IACC,J)
4885 340 CONTINUE
4886 IF(ISTSB.NE.5) THEN
4887 CALL PYSIGH(NCHN,SIGS)
4888 IF(MWTXS.EQ.1) THEN
4889 CALL PYEVWT(WTXS)
4890 SIGS=WTXS*SIGS
4891 ENDIF
4892 ELSE
4893 SIGS=0D0
4894 DO 350 IKIN3=1,MSTP(129)
4895 CALL PYKMAP(5,0,0D0)
4896 IF(MINT(51).EQ.1) GOTO 350
4897 CALL PYSIGH(NCHN,SIGTMP)
4898 IF(MWTXS.EQ.1) THEN
4899 CALL PYEVWT(WTXS)
4900 SIGTMP=WTXS*SIGTMP
4901 ENDIF
4902 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4903 350 CONTINUE
4904 ENDIF
4905 IEQ=0
4906 DO 360 IMV=1,NMAX
4907 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
4908 360 CONTINUE
4909 IF(IEQ.EQ.0) THEN
4910 DO 370 IMV=NMAX,1,-1
4911 IIN=IMV+1
4912 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
4913 IACCMX(IMV+1)=IACCMX(IMV)
4914 SIGSMX(IMV+1)=SIGSMX(IMV)
4915 370 CONTINUE
4916 IIN=1
4917 380 IACCMX(IIN)=IACC
4918 SIGSMX(IIN)=SIGS
4919 IF(NMAX.LE.1) NMAX=NMAX+1
4920 ENDIF
4921 390 CONTINUE
4922
4923C...Read out starting position for search.
4924 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
4925 SIGSAM=SIGSMX(1)
4926 DO 440 IMAX=1,NMAX
4927 IACC=IACCMX(IMAX)
4928 MTAU=MVARPT(IACC,1)
4929 MTAUP=MVARPT(IACC,2)
4930 MYST=MVARPT(IACC,3)
4931 MCTH=MVARPT(IACC,4)
4932 VTAU=0.5D0
4933 VYST=0.5D0
4934 VCTH=0.5D0
4935 VTAUP=0.5D0
4936
4937C...Starting point and step size in parameter space.
4938 DO 430 IRPT=1,2
4939 DO 420 IVAR=1,4
4940 IF(NPTS(IVAR).EQ.1) GOTO 420
4941 IF(IVAR.EQ.1) VVAR=VTAU
4942 IF(IVAR.EQ.2) VVAR=VTAUP
4943 IF(IVAR.EQ.3) VVAR=VYST
4944 IF(IVAR.EQ.4) VVAR=VCTH
4945 IF(IVAR.EQ.1) MVAR=MTAU
4946 IF(IVAR.EQ.2) MVAR=MTAUP
4947 IF(IVAR.EQ.3) MVAR=MYST
4948 IF(IVAR.EQ.4) MVAR=MCTH
4949 IF(IRPT.EQ.1) VDEL=0.1D0
4950 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
4951 & 0.98D0-VVAR))
4952 IF(IRPT.EQ.1) VMAR=0.02D0
4953 IF(IRPT.EQ.2) VMAR=0.002D0
4954 IMOV0=1
4955 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
4956 DO 410 IMOV=IMOV0,8
4957
4958C...Define new point in parameter space.
4959 IF(IMOV.EQ.0) THEN
4960 INEW=2
4961 VNEW=VVAR
4962 ELSEIF(IMOV.EQ.1) THEN
4963 INEW=3
4964 VNEW=VVAR+VDEL
4965 ELSEIF(IMOV.EQ.2) THEN
4966 INEW=1
4967 VNEW=VVAR-VDEL
4968 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
4969 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
4970 VVAR=VVAR+VDEL
4971 SIGSSM(1)=SIGSSM(2)
4972 SIGSSM(2)=SIGSSM(3)
4973 INEW=3
4974 VNEW=VVAR+VDEL
4975 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
4976 & VVAR-2D0*VDEL.GT.VMAR) THEN
4977 VVAR=VVAR-VDEL
4978 SIGSSM(3)=SIGSSM(2)
4979 SIGSSM(2)=SIGSSM(1)
4980 INEW=1
4981 VNEW=VVAR-VDEL
4982 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
4983 VDEL=0.5D0*VDEL
4984 VVAR=VVAR+VDEL
4985 SIGSSM(1)=SIGSSM(2)
4986 INEW=2
4987 VNEW=VVAR
4988 ELSE
4989 VDEL=0.5D0*VDEL
4990 VVAR=VVAR-VDEL
4991 SIGSSM(3)=SIGSSM(2)
4992 INEW=2
4993 VNEW=VVAR
4994 ENDIF
4995
4996C...Convert to relevant variables and find derived new limits.
4997 ILERR=0
4998 IF(IVAR.EQ.1) THEN
4999 VTAU=VNEW
5000 CALL PYKMAP(1,MTAU,VTAU)
5001 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5002 CALL PYKLIM(4)
5003 IF(MINT(51).EQ.1) ILERR=1
5004 ENDIF
5005 ENDIF
5006 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5007 & ILERR.EQ.0) THEN
5008 IF(IVAR.EQ.2) VTAUP=VNEW
5009 CALL PYKMAP(4,MTAUP,VTAUP)
5010 ENDIF
5011 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5012 CALL PYKLIM(2)
5013 IF(MINT(51).EQ.1) ILERR=1
5014 ENDIF
5015 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5016 IF(IVAR.EQ.3) VYST=VNEW
5017 CALL PYKMAP(2,MYST,VYST)
5018 CALL PYKLIM(3)
5019 IF(MINT(51).EQ.1) ILERR=1
5020 ENDIF
5021 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5022 & ILERR.EQ.0) THEN
5023 IF(IVAR.EQ.4) VCTH=VNEW
5024 CALL PYKMAP(3,MCTH,VCTH)
5025 ENDIF
5026 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5027
5028C...Evaluate cross-section. Save new maximum. Final maximum.
5029 IF(ILERR.NE.0) THEN
5030 SIGS=0.
5031 ELSEIF(ISTSB.NE.5) THEN
5032 CALL PYSIGH(NCHN,SIGS)
5033 IF(MWTXS.EQ.1) THEN
5034 CALL PYEVWT(WTXS)
5035 SIGS=WTXS*SIGS
5036 ENDIF
5037 ELSE
5038 SIGS=0D0
5039 DO 400 IKIN3=1,MSTP(129)
5040 CALL PYKMAP(5,0,0D0)
5041 IF(MINT(51).EQ.1) GOTO 400
5042 CALL PYSIGH(NCHN,SIGTMP)
5043 IF(MWTXS.EQ.1) THEN
5044 CALL PYEVWT(WTXS)
5045 SIGTMP=WTXS*SIGTMP
5046 ENDIF
5047 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5048 400 CONTINUE
5049 ENDIF
5050 SIGSSM(INEW)=SIGS
5051 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5052 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5053 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5054 410 CONTINUE
5055 420 CONTINUE
5056 430 CONTINUE
5057 440 CONTINUE
5058 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5059 XSEC(ISUB,1)=1.05D0*SIGSAM
5060 450 CONTINUE
5061 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5062 & PARP(174)*XSEC(ISUB,1)
5063 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5064 460 CONTINUE
5065 MINT(51)=0
5066
5067C...Print summary table.
5068 IF(NPOSI.EQ.0) THEN
5069 WRITE(MSTU(11),5900)
5070 STOP
5071 ENDIF
5072 IF(MSTP(122).GE.1) THEN
5073 WRITE(MSTU(11),6000)
5074 WRITE(MSTU(11),6100)
5075 DO 470 ISUB=1,500
5076 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5077 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5078 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5079 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5080 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5081 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5082 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5083 470 CONTINUE
5084 WRITE(MSTU(11),6300)
5085 ENDIF
5086
5087C...Format statements for maximization results.
5088 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5089 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
5090 &'cth',9X,'tau''',7X,'sigma')
5091 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5092 &'phase space.'/1X,'Process switched off!')
5093 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5094 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5095 &'cross-section.'/1X,'Process switched off!')
5096 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5097 5500 FORMAT(1X,1P,8D11.3)
5098 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5099 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5100 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5101 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5102 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5103 &'cross-section.'/1X,'Execution stopped!')
5104 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5105 &'cross-section maximum search',1X,8('*'))
5106 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
5107 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
5108 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5109 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5110 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5111
5112 RETURN
5113 END
5114
5115C*********************************************************************
5116
5117C...PYPILE
5118C...Initializes multiplicity distribution and selects mutliplicity
5119C...of pileup events, i.e. several events occuring at the same
5120C...beam crossing.
5121
5122 SUBROUTINE PYPILE(MPILE)
5123
5124C...Double precision and integer declarations.
5125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5126 INTEGER PYK,PYCHGE,PYCOMP
5127C...Commonblocks.
5128 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5129 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5130 COMMON/PYINT1/MINT(400),VINT(400)
5131 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5132 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5133C...Local arrays and saved variables.
5134 DIMENSION WTI(0:200)
5135 SAVE IMIN,IMAX,WTI,WTS
5136
5137C...Sum of allowed cross-sections for pileup events.
5138 IF(MPILE.EQ.1) THEN
5139 VINT(131)=SIGT(0,0,5)
5140 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5141 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5142 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5143 IF(MSTP(133).LE.0) RETURN
5144
5145C...Initialize multiplicity distribution at maximum.
5146 XNAVE=VINT(131)*PARP(131)
5147 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5148 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5149 WTI(INAVE)=1D0
5150 WTS=WTI(INAVE)
5151 WTN=WTI(INAVE)*INAVE
5152
5153C...Find shape of multiplicity distribution below maximum.
5154 IMIN=INAVE
5155 DO 100 I=INAVE-1,1,-1
5156 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5157 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5158 IF(WTI(I).LT.1D-6) GOTO 110
5159 WTS=WTS+WTI(I)
5160 WTN=WTN+WTI(I)*I
5161 IMIN=I
5162 100 CONTINUE
5163
5164C...Find shape of multiplicity distribution above maximum.
5165 110 IMAX=INAVE
5166 DO 120 I=INAVE+1,200
5167 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5168 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5169 IF(WTI(I).LT.1D-6) GOTO 130
5170 WTS=WTS+WTI(I)
5171 WTN=WTN+WTI(I)*I
5172 IMAX=I
5173 120 CONTINUE
5174 130 VINT(132)=XNAVE
5175 VINT(133)=WTN/WTS
5176 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5177 & WTS/(WTS+WTI(1)/XNAVE)
5178 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5179 IF(MSTP(133).GE.2) VINT(134)=XNAVE
5180
5181C...Pick multiplicity of pileup events.
5182 ELSE
5183 IF(MSTP(133).LE.0) THEN
5184 MINT(81)=MAX(1,MSTP(134))
5185 ELSE
5186 WTR=WTS*PYR(0)
5187 DO 140 I=IMIN,IMAX
5188 MINT(81)=I
5189 WTR=WTR-WTI(I)
5190 IF(WTR.LE.0D0) GOTO 150
5191 140 CONTINUE
5192 150 CONTINUE
5193 ENDIF
5194 ENDIF
5195
5196C...Format statement for error message.
5197 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5198 &'crossing too large, ',1P,D12.4)
5199
5200 RETURN
5201 END
5202
5203C*********************************************************************
5204
5205C...PYSAVE
5206C...Saves and restores parameter and cross section values for the
5207C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
5208C...choice between alternatives.
5209
5210 SUBROUTINE PYSAVE(ISAVE,IGA)
5211
5212C...Double precision and integer declarations.
5213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5214 INTEGER PYK,PYCHGE,PYCOMP
5215C...Commonblocks.
5216 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5217 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5218 COMMON/PYINT1/MINT(400),VINT(400)
5219 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5220 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5221 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/
5222C...Local arrays and saved variables.
5223 DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20),
5224 &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20)
5225 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,INTCP,RECP
5226
5227C...Save list of subprocesses and cross-section information.
5228 IF(ISAVE.EQ.1) THEN
5229 ICP=0
5230 DO 120 I=1,500
5231 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5232 ICP=ICP+1
5233 NSUBCP(IGA,ICP)=I
5234 MSUBCP(IGA,ICP)=MSUB(I)
5235 DO 100 J=1,20
5236 COEFCP(IGA,ICP,J)=COEF(I,J)
5237 100 CONTINUE
5238 DO 110 J=1,3
5239 NGENCP(IGA,ICP,J)=NGEN(I,J)
5240 XSECCP(IGA,ICP,J)=XSEC(I,J)
5241 110 CONTINUE
5242 120 CONTINUE
5243 NCP(IGA)=ICP
5244 DO 130 J=1,3
5245 NGENCP(IGA,0,J)=NGEN(0,J)
5246 XSECCP(IGA,0,J)=XSEC(0,J)
5247 130 CONTINUE
5248C...Save various common process variables.
5249 DO 140 J=1,10
5250 INTCP(IGA,J)=MINT(40+J)
5251 140 CONTINUE
5252 INTCP(IGA,11)=MINT(101)
5253 INTCP(IGA,12)=MINT(102)
5254 INTCP(IGA,13)=MINT(107)
5255 INTCP(IGA,14)=MINT(108)
5256 INTCP(IGA,15)=MINT(123)
5257 RECP(IGA,1)=CKIN(3)
5258
5259C...Save cross-section information only.
5260 ELSEIF(ISAVE.EQ.2) THEN
5261 DO 160 ICP=1,NCP(IGA)
5262 I=NSUBCP(IGA,ICP)
5263 DO 150 J=1,3
5264 NGENCP(IGA,ICP,J)=NGEN(I,J)
5265 XSECCP(IGA,ICP,J)=XSEC(I,J)
5266 150 CONTINUE
5267 160 CONTINUE
5268 DO 170 J=1,3
5269 NGENCP(IGA,0,J)=NGEN(0,J)
5270 XSECCP(IGA,0,J)=XSEC(0,J)
5271 170 CONTINUE
5272
5273C...Choose between allowed alternatives.
5274 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5275 IF(ISAVE.EQ.4) THEN
5276 XSUMCP=0D0
5277 DO 180 IG=1,MINT(121)
5278 XSUMCP=XSUMCP+XSECCP(IG,0,1)
5279 180 CONTINUE
5280 XSUMCP=XSUMCP*PYR(0)
5281 DO 190 IG=1,MINT(121)
5282 IGA=IG
5283 XSUMCP=XSUMCP-XSECCP(IG,0,1)
5284 IF(XSUMCP.LE.0D0) GOTO 200
5285 190 CONTINUE
5286 200 CONTINUE
5287 ENDIF
5288
5289C...Restore cross-section information.
5290 DO 210 I=1,500
5291 MSUB(I)=0
5292 210 CONTINUE
5293 DO 240 ICP=1,NCP(IGA)
5294 I=NSUBCP(IGA,ICP)
5295 MSUB(I)=MSUBCP(IGA,ICP)
5296 DO 220 J=1,20
5297 COEF(I,J)=COEFCP(IGA,ICP,J)
5298 220 CONTINUE
5299 DO 230 J=1,3
5300 NGEN(I,J)=NGENCP(IGA,ICP,J)
5301 XSEC(I,J)=XSECCP(IGA,ICP,J)
5302 230 CONTINUE
5303 240 CONTINUE
5304 DO 250 J=1,3
5305 NGEN(0,J)=NGENCP(IGA,0,J)
5306 XSEC(0,J)=XSECCP(IGA,0,J)
5307 250 CONTINUE
5308
5309C...Restore various common process variables.
5310 DO 260 J=1,10
5311 MINT(40+J)=INTCP(IGA,J)
5312 260 CONTINUE
5313 MINT(101)=INTCP(IGA,11)
5314 MINT(102)=INTCP(IGA,12)
5315 MINT(107)=INTCP(IGA,13)
5316 MINT(108)=INTCP(IGA,14)
5317 MINT(123)=INTCP(IGA,15)
5318 CKIN(3)=RECP(IGA,1)
5319 CKIN(1)=2D0*CKIN(3)
5320
5321C...Sum up cross-section info (for PYSTAT).
5322 ELSEIF(ISAVE.EQ.5) THEN
5323 DO 270 I=1,500
5324 MSUB(I)=0
5325 NGEN(I,1)=0
5326 NGEN(I,3)=0
5327 XSEC(I,3)=0D0
5328 270 CONTINUE
5329 NGEN(0,1)=0
5330 NGEN(0,2)=0
5331 NGEN(0,3)=0
5332 XSEC(0,3)=0
5333 DO 290 IG=1,MINT(121)
5334 DO 280 ICP=1,NCP(IG)
5335 I=NSUBCP(IG,ICP)
5336 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
5337 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
5338 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
5339 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
5340 280 CONTINUE
5341 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
5342 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
5343 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
5344 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
5345 290 CONTINUE
5346 ENDIF
5347
5348 RETURN
5349 END
5350
5351C*********************************************************************
5352
5353C...PYRAND
5354C...Generates quantities characterizing the high-pT scattering at the
5355C...parton level according to the matrix elements. Chooses incoming,
5356C...reacting partons, their momentum fractions and one of the possible
5357C...subprocesses.
5358
5359 SUBROUTINE PYRAND
5360
5361C...Double precision and integer declarations.
5362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5363 INTEGER PYK,PYCHGE,PYCOMP
5364C...Parameter statement to help give large particle numbers.
5365 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
5366C...Commonblocks.
5367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5369 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
5370 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5371 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5372 COMMON/PYINT1/MINT(400),VINT(400)
5373 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5374 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5375 COMMON/PYINT4/MWID(500),WIDS(500,5)
5376 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5377 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5378 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
5379 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5380 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5381 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
5382C...Local arrays.
5383 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
5384
5385C...Parameters and data used in elastic/diffractive treatment.
5386 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
5387 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5388
5389C...Initial values, specifically for (first) semihard interaction.
5390 MINT(10)=0
5391 MINT(17)=0
5392 MINT(18)=0
5393 VINT(143)=1D0
5394 VINT(144)=1D0
5395 MFAIL=0
5396 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
5397 ISUB=0
5398 LOOP=0
5399 100 LOOP=LOOP+1
5400 MINT(51)=0
5401
5402C...Choice of process type - first event of pileup.
5403 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
5404
5405C...For gamma-p or gamma-gamma first pick between alternatives.
5406 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
5407 MINT(122)=IGA
5408
5409C...For gamma + gamma with different nature, flip at random.
5410 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
5411 & PYR(0).GT.0.5D0) THEN
5412 MINTSV=MINT(41)
5413 MINT(41)=MINT(42)
5414 MINT(42)=MINTSV
5415 MINTSV=MINT(45)
5416 MINT(45)=MINT(46)
5417 MINT(46)=MINTSV
5418 MINTSV=MINT(107)
5419 MINT(107)=MINT(108)
5420 MINT(108)=MINTSV
5421 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
5422 ENDIF
5423
5424C...Pick process type.
5425 RSUB=XSEC(0,1)*PYR(0)
5426 DO 110 I=1,500
5427 IF(MSUB(I).NE.1) GOTO 110
5428 ISUB=I
5429 RSUB=RSUB-XSEC(I,1)
5430 IF(RSUB.LE.0D0) GOTO 120
5431 110 CONTINUE
5432 120 IF(ISUB.EQ.95) ISUB=96
5433 IF(ISUB.EQ.96) CALL PYMULT(2)
5434
5435C...Choice of inclusive process type - pileup events.
5436 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
5437 RSUB=VINT(131)*PYR(0)
5438 ISUB=96
5439 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
5440 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
5441 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
5442 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
5443 & ISUB=91
5444 IF(ISUB.EQ.96) CALL PYMULT(2)
5445 ENDIF
5446 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
5447 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
5448 IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
5449 &NGEN(97,1)=NGEN(97,1)+1
5450 MINT(1)=ISUB
5451 ISTSB=ISET(ISUB)
5452
5453C...Random choice of flavour for some SUSY processes.
5454 IF(ISUB.GE.201.AND.ISUB.LE.280) THEN
5455C...~e_L ~nu_e or ~mu_L ~nu_mu.
5456 IF(ISUB.EQ.210) THEN
5457 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
5458 KFPR(ISUB,2)=KFPR(ISUB,1)+1
5459C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
5460 ELSEIF(ISUB.EQ.213) THEN
5461 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
5462 KFPR(ISUB,2)=KFPR(ISUB,1)
5463C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
5464 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
5465 IF(MOD(ISUB,2).EQ.0) THEN
5466 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5467 ELSE
5468 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5469 ENDIF
5470C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
5471 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
5472 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
5473 KSU1=KSUSY1
5474 KSU2=KSUSY1
5475 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
5476 KSU1=KSUSY2
5477 KSU2=KSUSY2
5478 ELSEIF(PYR(0).LT.0.5D0) THEN
5479 KSU1=KSUSY1
5480 KSU2=KSUSY2
5481 ELSE
5482 KSU1=KSUSY2
5483 KSU2=KSUSY1
5484 ENDIF
5485 KFPR(ISUB,1)=KSU1+1+INT(5D0*PYR(0))
5486 KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0))
5487C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b.
5488 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
5489 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5490 KFPR(ISUB,2)=KFPR(ISUB,1)
5491 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
5492 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5493 KFPR(ISUB,2)=KFPR(ISUB,1)
5494 ENDIF
5495 ENDIF
5496
5497C...Find resonances (explicit or implicit in cross-section).
5498 MINT(72)=0
5499 KFR1=0
5500 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5501 KFR1=KFPR(ISUB,1)
5502 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
5503 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5504 KFR1=23
5505 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
5506 & ISUB.EQ.177) THEN
5507 KFR1=24
5508 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5509 KFR1=25
5510 IF(MSTP(46).EQ.5) THEN
5511 KFR1=30
5512 PMAS(30,1)=PARP(45)
5513 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5514 ENDIF
5515 ELSEIF(ISUB.EQ.194) THEN
5516 KFR1=54
5517 ENDIF
5518 CKMX=CKIN(2)
5519 IF(CKMX.LE.0D0) CKMX=VINT(1)
5520 KCR1=PYCOMP(KFR1)
5521 IF(KFR1.NE.0) THEN
5522 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5523 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5524 ENDIF
5525 IF(KFR1.NE.0) THEN
5526 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5527 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5528 MINT(72)=1
5529 MINT(73)=KFR1
5530 VINT(73)=TAUR1
5531 VINT(74)=GAMR1
5532 ENDIF
5533 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
5534 KFR2=23
5535 IF(ISUB.EQ.194) KFR2=56
5536 KCR2=PYCOMP(KFR2)
5537 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5538 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5539 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5540 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5541 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5542 MINT(72)=2
5543 MINT(74)=KFR2
5544 VINT(75)=TAUR2
5545 VINT(76)=GAMR2
5546 ELSEIF(KFR2.NE.0) THEN
5547 KFR1=KFR2
5548 TAUR1=TAUR2
5549 GAMR1=GAMR2
5550 MINT(72)=1
5551 MINT(73)=KFR1
5552 VINT(73)=TAUR1
5553 VINT(74)=GAMR1
5554 ENDIF
5555 ENDIF
5556
5557C...Find product masses and minimum pT of process,
5558C...optionally with broadening according to a truncated Breit-Wigner.
5559 VINT(63)=0D0
5560 VINT(64)=0D0
5561 MINT(71)=0
5562 VINT(71)=CKIN(3)
5563 IF(MINT(82).GE.2) VINT(71)=0D0
5564 VINT(80)=1D0
5565 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5566 NBW=0
5567 DO 140 I=1,2
5568 PMMN(I)=0D0
5569 IF(KFPR(ISUB,I).EQ.0) THEN
5570 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5571 & PARP(41)) THEN
5572 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5573 ELSE
5574 NBW=NBW+1
5575C...This prevents SUSY/t particles from becoming too light.
5576 KFLW=KFPR(ISUB,I)
5577 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5578 KCW=PYCOMP(KFLW)
5579 PMMN(I)=PMAS(KCW,1)
5580 DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5581 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5582 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5583 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5584 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5585 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5586 PMMN(I)=MIN(PMMN(I),PMSUM)
5587 ENDIF
5588 130 CONTINUE
5589 ELSEIF(KFLW.EQ.6) THEN
5590 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5591 ENDIF
5592 ENDIF
5593 140 CONTINUE
5594 IF(NBW.GE.1) THEN
5595 CKIN41=CKIN(41)
5596 CKIN43=CKIN(43)
5597 CKIN(41)=MAX(PMMN(1),CKIN(41))
5598 CKIN(43)=MAX(PMMN(2),CKIN(43))
5599 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5600 CKIN(41)=CKIN41
5601 CKIN(43)=CKIN43
5602 IF(MINT(51).EQ.1) THEN
5603 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5604 IF(MFAIL.EQ.1) THEN
5605 MSTI(61)=1
5606 RETURN
5607 ENDIF
5608 GOTO 100
5609 ENDIF
5610 VINT(63)=PQM3**2
5611 VINT(64)=PQM4**2
5612 ENDIF
5613 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
5614 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5615 ENDIF
5616
5617C...Prepare for additional variable choices in 2 -> 3.
5618 IF(ISTSB.EQ.5) THEN
5619 VINT(201)=0D0
5620 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5621 VINT(206)=VINT(201)
5622 VINT(204)=PMAS(23,1)
5623 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
5624 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
5625 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5626 VINT(209)=VINT(204)
5627 ENDIF
5628
5629C...Select incoming VDM particle (rho/omega/phi/J/psi).
5630 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
5631 &(MINT(123).EQ.2.OR.MINT(123).EQ.5.OR.MINT(123).EQ.7)) THEN
5632 VRN=PYR(0)*SIGT(0,0,5)
5633 IF(MINT(101).LE.1) THEN
5634 I1MN=0
5635 I1MX=0
5636 ELSE
5637 I1MN=1
5638 I1MX=MINT(101)
5639 ENDIF
5640 IF(MINT(102).LE.1) THEN
5641 I2MN=0
5642 I2MX=0
5643 ELSE
5644 I2MN=1
5645 I2MX=MINT(102)
5646 ENDIF
5647 DO 160 I1=I1MN,I1MX
5648 KFV1=110*I1+3
5649 DO 150 I2=I2MN,I2MX
5650 KFV2=110*I2+3
5651 VRN=VRN-SIGT(I1,I2,5)
5652 IF(VRN.LE.0D0) GOTO 170
5653 150 CONTINUE
5654 160 CONTINUE
5655 170 IF(MINT(101).GE.2) MINT(103)=KFV1
5656 IF(MINT(102).GE.2) MINT(104)=KFV2
5657 ENDIF
5658
5659 IF(ISTSB.EQ.0) THEN
5660C...Elastic scattering or single or double diffractive scattering.
5661
5662C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
5663 MINT(103)=MINT(11)
5664 MINT(104)=MINT(12)
5665 PMM(1)=VINT(3)
5666 PMM(2)=VINT(4)
5667 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
5668 JJ=ISUB-90
5669 VRN=PYR(0)*SIGT(0,0,JJ)
5670 IF(MINT(101).LE.1) THEN
5671 I1MN=0
5672 I1MX=0
5673 ELSE
5674 I1MN=1
5675 I1MX=MINT(101)
5676 ENDIF
5677 IF(MINT(102).LE.1) THEN
5678 I2MN=0
5679 I2MX=0
5680 ELSE
5681 I2MN=1
5682 I2MX=MINT(102)
5683 ENDIF
5684 DO 190 I1=I1MN,I1MX
5685 KFV1=110*I1+3
5686 DO 180 I2=I2MN,I2MX
5687 KFV2=110*I2+3
5688 VRN=VRN-SIGT(I1,I2,JJ)
5689 IF(VRN.LE.0D0) GOTO 200
5690 180 CONTINUE
5691 190 CONTINUE
5692 200 IF(MINT(101).GE.2) THEN
5693 MINT(103)=KFV1
5694 PMM(1)=PYMASS(KFV1)
5695 ENDIF
5696 IF(MINT(102).GE.2) THEN
5697 MINT(104)=KFV2
5698 PMM(2)=PYMASS(KFV2)
5699 ENDIF
5700 ENDIF
5701
5702C...Side/sides of diffractive system.
5703 MINT(17)=0
5704 MINT(18)=0
5705 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
5706 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
5707
5708C...Find masses of particles and minimal masses of diffractive states.
5709 DO 210 JT=1,2
5710 PDIF(JT)=PMM(JT)
5711 VINT(66+JT)=PDIF(JT)
5712 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
5713 210 CONTINUE
5714 SH=VINT(2)
5715 SQM1=PMM(1)**2
5716 SQM2=PMM(2)**2
5717 SQM3=PDIF(1)**2
5718 SQM4=PDIF(2)**2
5719 SMRES1=(PMM(1)+PMRC)**2
5720 SMRES2=(PMM(2)+PMRC)**2
5721
5722C...Find elastic slope and lower limit diffractive slope.
5723 IHA=MAX(2,IABS(MINT(103))/110)
5724 IF(IHA.GE.5) IHA=1
5725 IHB=MAX(2,IABS(MINT(104))/110)
5726 IF(IHB.GE.5) IHB=1
5727 IF(ISUB.EQ.91) THEN
5728 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
5729 ELSEIF(ISUB.EQ.92) THEN
5730 BMN=MAX(2D0,2D0*BHAD(IHB))
5731 ELSEIF(ISUB.EQ.93) THEN
5732 BMN=MAX(2D0,2D0*BHAD(IHA))
5733 ELSEIF(ISUB.EQ.94) THEN
5734 BMN=2D0*ALP*4D0
5735 ENDIF
5736
5737C...Determine maximum possible t range and coefficient of generation.
5738 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
5739 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5740 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5741 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5742 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5743 & (SQM1*SQM4-SQM2*SQM3)/SH
5744 THL=-0.5D0*(THA+THB)
5745 THU=THC/THL
5746 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
5747
5748C...Select diffractive mass/masses according to dm^2/m^2.
5749 220 DO 230 JT=1,2
5750 IF(MINT(16+JT).EQ.0) THEN
5751 PDIF(2+JT)=PDIF(JT)
5752 ELSE
5753 PMMIN=PDIF(JT)
5754 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
5755 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
5756 ENDIF
5757 230 CONTINUE
5758 SQM3=PDIF(3)**2
5759 SQM4=PDIF(4)**2
5760
5761C..Additional mass factors, including resonance enhancement.
5762 IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220
5763 IF(ISUB.EQ.92) THEN
5764 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
5765 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5766 ELSEIF(ISUB.EQ.93) THEN
5767 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
5768 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5769 ELSEIF(ISUB.EQ.94) THEN
5770 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
5771 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
5772 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
5773 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
5774 ENDIF
5775
5776C...Select t according to exp(Bmn*t) and correct to right slope.
5777 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
5778 IF(ISUB.GE.92) THEN
5779 IF(ISUB.EQ.92) THEN
5780 BADD=2D0*ALP*LOG(SH/SQM3)
5781 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
5782 ELSEIF(ISUB.EQ.93) THEN
5783 BADD=2D0*ALP*LOG(SH/SQM4)
5784 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
5785 ELSEIF(ISUB.EQ.94) THEN
5786 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
5787 ENDIF
5788 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
5789 ENDIF
5790
5791C...Check whether m^2 and t choices are consistent.
5792 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5793 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5794 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5795 IF(THB.LE.1D-8) GOTO 220
5796 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5797 & (SQM1*SQM4-SQM2*SQM3)/SH
5798 THLM=-0.5D0*(THA+THB)
5799 THUM=THC/THLM
5800 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
5801
5802C...Information to output.
5803 VINT(21)=1D0
5804 VINT(22)=0D0
5805 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
5806 VINT(45)=TH
5807 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
5808 VINT(63)=PDIF(3)**2
5809 VINT(64)=PDIF(4)**2
5810
5811C...Note: in the following, by In is meant the integral over the
5812C...quantity multiplying coefficient cn.
5813C...Choose tau according to h1(tau)/tau, where
5814C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
5815C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
5816C...I1/I5*c5*1/(tau+tau_R') +
5817C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
5818C...I1/I7*c7*tau/(1.-tau), and
5819C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
5820 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
5821 CALL PYKLIM(1)
5822 IF(MINT(51).NE.0) THEN
5823 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5824 IF(MFAIL.EQ.1) THEN
5825 MSTI(61)=1
5826 RETURN
5827 ENDIF
5828 GOTO 100
5829 ENDIF
5830 RTAU=PYR(0)
5831 MTAU=1
5832 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
5833 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
5834 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
5835 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
5836 & MTAU=5
5837 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5838 & COEF(ISUB,5)) MTAU=6
5839 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5840 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
5841 CALL PYKMAP(1,MTAU,PYR(0))
5842
5843C...2 -> 3, 4 processes:
5844C...Choose tau' according to h4(tau,tau')/tau', where
5845C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
5846C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
5847 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5848 CALL PYKLIM(4)
5849 IF(MINT(51).NE.0) THEN
5850 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5851 IF(MFAIL.EQ.1) THEN
5852 MSTI(61)=1
5853 RETURN
5854 ENDIF
5855 GOTO 100
5856 ENDIF
5857 RTAUP=PYR(0)
5858 MTAUP=1
5859 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
5860 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
5861 CALL PYKMAP(4,MTAUP,PYR(0))
5862 ENDIF
5863
5864C...Choose y* according to h2(y*), where
5865C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
5866C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
5867C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
5868C...and c1 + c2 + c3 + c4 + c5 = 1.
5869 CALL PYKLIM(2)
5870 IF(MINT(51).NE.0) THEN
5871 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5872 IF(MFAIL.EQ.1) THEN
5873 MSTI(61)=1
5874 RETURN
5875 ENDIF
5876 GOTO 100
5877 ENDIF
5878 RYST=PYR(0)
5879 MYST=1
5880 IF(RYST.GT.COEF(ISUB,8)) MYST=2
5881 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
5882 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
5883 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
5884 & COEF(ISUB,11)) MYST=5
5885 CALL PYKMAP(2,MYST,PYR(0))
5886
5887C...2 -> 2 processes:
5888C...Choose cos(theta-hat) (cth) according to h3(cth), where
5889C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
5890C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
5891C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
5892C...and c0 + c1 + c2 + c3 + c4 = 1.
5893 CALL PYKLIM(3)
5894 IF(MINT(51).NE.0) THEN
5895 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5896 IF(MFAIL.EQ.1) THEN
5897 MSTI(61)=1
5898 RETURN
5899 ENDIF
5900 GOTO 100
5901 ENDIF
5902 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5903 RCTH=PYR(0)
5904 MCTH=1
5905 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
5906 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
5907 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
5908 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
5909 & COEF(ISUB,16)) MCTH=5
5910 CALL PYKMAP(3,MCTH,PYR(0))
5911 ENDIF
5912
5913C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
5914 IF(ISTSB.EQ.5) THEN
5915 CALL PYKMAP(5,0,0D0)
5916 IF(MINT(51).NE.0) THEN
5917 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5918 IF(MFAIL.EQ.1) THEN
5919 MSTI(61)=1
5920 RETURN
5921 ENDIF
5922 GOTO 100
5923 ENDIF
5924 ENDIF
5925
5926C...Low-pT or multiple interactions (first semihard interaction).
5927 ELSEIF(ISTSB.EQ.9) THEN
5928 CALL PYMULT(3)
5929 ISUB=MINT(1)
5930
5931C...Generate user-defined process: kinematics plus weight.
5932 ELSEIF(ISTSB.EQ.11) THEN
5933 MSTI(51)=0
5934 CALL PYUPEV(ISUB,SIGS)
5935 IF(NUP.LE.0) THEN
5936 MINT(51)=2
5937 MSTI(51)=1
5938 IF(MINT(82).EQ.1) THEN
5939 NGEN(0,1)=NGEN(0,1)-1
5940 NGEN(0,2)=NGEN(0,2)-1
5941 NGEN(ISUB,1)=NGEN(ISUB,1)-1
5942 ENDIF
5943 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5944 RETURN
5945 ENDIF
5946
5947C...Construct 'trivial' kinematical variables needed.
5948 KFL1=KUP(1,2)
5949 KFL2=KUP(2,2)
5950 VINT(41)=2D0*PUP(1,4)/VINT(1)
5951 VINT(42)=2D0*PUP(2,4)/VINT(1)
5952 VINT(21)=VINT(41)*VINT(42)
5953 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
5954 VINT(44)=VINT(21)*VINT(2)
5955 VINT(43)=SQRT(MAX(0D0,VINT(44)))
5956 VINT(56)=Q2UP(0)
5957 VINT(55)=SQRT(MAX(0D0,VINT(56)))
5958
5959C...Construct other kinematical variables needed (approximately).
5960 VINT(23)=0D0
5961 VINT(26)=VINT(21)
5962 VINT(45)=-0.5D0*VINT(44)
5963 VINT(46)=-0.5D0*VINT(44)
5964 VINT(49)=VINT(43)
5965 VINT(50)=VINT(44)
5966 VINT(51)=VINT(55)
5967 VINT(52)=VINT(56)
5968 VINT(53)=VINT(55)
5969 VINT(54)=VINT(56)
5970 VINT(25)=0D0
5971 VINT(48)=0D0
5972 DO 240 IUP=3,NUP
5973 IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
5974 & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1)
5975 IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
5976 & PUP(IUP,2)**2)
5977 240 CONTINUE
5978 VINT(47)=SQRT(VINT(48))
5979
5980C...Calculate parton distribution weights.
5981 IF(MINT(47).GE.2) THEN
5982 DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
5983 MINT(105)=MINT(102+I)
5984 MINT(109)=MINT(106+I)
5985 IF(MSTP(57).LE.1) THEN
5986 CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
5987 ELSE
5988 CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
5989 ENDIF
5990 DO 250 KFL=-25,25
5991 XSFX(I,KFL)=XPQ(KFL)
5992 250 CONTINUE
5993 260 CONTINUE
5994 ENDIF
5995 ENDIF
5996
5997C...Choose azimuthal angle.
5998 VINT(24)=PARU(2)*PYR(0)
5999
6000C...Check against user cuts on kinematics at parton level.
6001 MINT(51)=0
6002 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
6003 IF(MINT(51).NE.0) THEN
6004 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6005 IF(MFAIL.EQ.1) THEN
6006 MSTI(61)=1
6007 RETURN
6008 ENDIF
6009 GOTO 100
6010 ENDIF
6011 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
6012 MCUT=0
6013 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
6014 & CALL PYKCUT(MCUT)
6015 IF(MCUT.NE.0) THEN
6016 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6017 IF(MFAIL.EQ.1) THEN
6018 MSTI(61)=1
6019 RETURN
6020 ENDIF
6021 GOTO 100
6022 ENDIF
6023 ENDIF
6024
6025C...Calculate differential cross-section for different subprocesses.
6026 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
6027 SIGSOR=SIGS
6028 SIGLPT=SIGT(0,0,5)
6029
6030C...Multiply cross-section by user-defined weights.
6031 IF(MSTP(173).EQ.1) THEN
6032 SIGS=PARP(173)*SIGS
6033 DO 270 ICHN=1,NCHN
6034 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
6035 270 CONTINUE
6036 SIGLPT=PARP(173)*SIGLPT
6037 ENDIF
6038 WTXS=1D0
6039 SIGSWT=SIGS
6040 VINT(99)=1D0
6041 VINT(100)=1D0
6042 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
6043 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
6044 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
6045 SIGSWT=WTXS*SIGS
6046 VINT(99)=WTXS
6047 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
6048 ENDIF
6049
6050C...Calculations for Monte Carlo estimate of all cross-sections.
6051 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
6052 IF(MSTP(142).LE.1) THEN
6053 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6054 ELSE
6055 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
6056 ENDIF
6057 ELSEIF(MINT(82).EQ.1) THEN
6058 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6059 ENDIF
6060 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
6061 &XSEC(97,2)=XSEC(97,2)+SIGLPT
6062
6063C...Multiple interactions: store results of cross-section calculation.
6064 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
6065 VINT(153)=SIGSOR
6066 CALL PYMULT(4)
6067 ENDIF
6068
6069C...Check that weight not negative.
6070 VIOL=SIGSWT/XSEC(ISUB,1)
6071 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
6072 IF(MSTP(123).LE.0) THEN
6073 IF(VIOL.LT.-1D-3) THEN
6074 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
6075 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6076 & VINT(22),VINT(23),VINT(26)
6077 STOP
6078 ENDIF
6079 ELSE
6080 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
6081 VINT(109)=VIOL
6082 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
6083 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6084 & VINT(22),VINT(23),VINT(26)
6085 ENDIF
6086 ENDIF
6087
6088C...Weighting using estimate of maximum of differential cross-section.
6089 IF(MFAIL.EQ.0) THEN
6090 IF(VIOL.LT.PYR(0)) THEN
6091 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6092 GOTO 100
6093 ENDIF
6094 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
6095 IF(VIOL.LT.PYR(0)) THEN
6096 MSTI(61)=1
6097 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6098 RETURN
6099 ENDIF
6100 ELSE
6101 RATND=SIGLPT/XSEC(95,1)
6102 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
6103 MSTI(61)=1
6104 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6105 RETURN
6106 ENDIF
6107 VIOL=VIOL/RATND
6108 IF(VIOL.LT.PYR(0)) THEN
6109 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6110 GOTO 100
6111 ENDIF
6112 ENDIF
6113
6114C...Check for possible violation of estimated maximum of differential
6115C...cross-section used in weighting.
6116 IF(MSTP(123).LE.0) THEN
6117 IF(VIOL.GT.1D0) THEN
6118 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
6119 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6120 & VINT(22),VINT(23),VINT(26)
6121 STOP
6122 ENDIF
6123 ELSEIF(MSTP(123).EQ.1) THEN
6124 IF(VIOL.GT.VINT(108)) THEN
6125 VINT(108)=VIOL
6126 IF(VIOL.GT.1D0) THEN
6127 MINT(10)=1
6128 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6129 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6130 & VINT(22),VINT(23),VINT(26)
6131 ENDIF
6132 ENDIF
6133 ELSEIF(VIOL.GT.VINT(108)) THEN
6134 VINT(108)=VIOL
6135 IF(VIOL.GT.1D0) THEN
6136 MINT(10)=1
6137 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
6138 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
6139 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
6140 & XSEC(0,1)=XSEC(0,1)+XDIF
6141 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6142 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6143 & VINT(22),VINT(23),VINT(26)
6144 IF(ISUB.LE.9) THEN
6145 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
6146 ELSEIF(ISUB.LE.99) THEN
6147 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
6148 ELSE
6149 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
6150 ENDIF
6151 VINT(108)=1D0
6152 ENDIF
6153 ENDIF
6154
6155C...Multiple interactions: choose impact parameter.
6156 VINT(148)=1D0
6157 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
6158 &MSTP(82).GE.3) THEN
6159 CALL PYMULT(5)
6160 IF(VINT(150).LT.PYR(0)) THEN
6161 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6162 IF(MFAIL.EQ.1) THEN
6163 MSTI(61)=1
6164 RETURN
6165 ENDIF
6166 GOTO 100
6167 ENDIF
6168 ENDIF
6169 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
6170 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
6171 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
6172 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
6173 ENDIF
6174 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
6175
6176C...Choose flavour of reacting partons (and subprocess).
6177 IF(ISTSB.GE.11) GOTO 290
6178 RSIGS=SIGS*PYR(0)
6179 QT2=VINT(48)
6180 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
6181 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
6182 &PYR(0).GT.RQQBAR)) THEN
6183 DO 280 ICHN=1,NCHN
6184 KFL1=ISIG(ICHN,1)
6185 KFL2=ISIG(ICHN,2)
6186 MINT(2)=ISIG(ICHN,3)
6187 RSIGS=RSIGS-SIGH(ICHN)
6188 IF(RSIGS.LE.0D0) GOTO 290
6189 280 CONTINUE
6190
6191C...Multiple interactions: choose qqbar preferentially at small pT.
6192 ELSEIF(ISUB.EQ.96) THEN
6193 MINT(105)=MINT(103)
6194 MINT(109)=MINT(107)
6195 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
6196 MINT(105)=MINT(104)
6197 MINT(109)=MINT(108)
6198 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
6199 MINT(1)=11
6200 MINT(2)=1
6201 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
6202
6203C...Low-pT: choose string drawing configuration.
6204 ELSE
6205 KFL1=21
6206 KFL2=21
6207 RSIGS=6D0*PYR(0)
6208 MINT(2)=1
6209 IF(RSIGS.GT.1D0) MINT(2)=2
6210 IF(RSIGS.GT.2D0) MINT(2)=3
6211 ENDIF
6212
6213C...Reassign QCD process. Partons before initial state radiation.
6214 290 IF(MINT(2).GT.10) THEN
6215 MINT(1)=MINT(2)/10
6216 MINT(2)=MOD(MINT(2),10)
6217 ENDIF
6218 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
6219 &NGEN(MINT(1),2)+1
6220 MINT(15)=KFL1
6221 MINT(16)=KFL2
6222 MINT(13)=MINT(15)
6223 MINT(14)=MINT(16)
6224 VINT(141)=VINT(41)
6225 VINT(142)=VINT(42)
6226 VINT(151)=0D0
6227 VINT(152)=0D0
6228
6229C...Calculate x value of photon for parton inside photon inside e.
6230 DO 320 JT=1,2
6231 MINT(18+JT)=0
6232 VINT(154+JT)=0D0
6233 MSPLI=0
6234 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
6235 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
6236 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
6237 IF(MSPLI.EQ.2) THEN
6238 KFLH=MINT(14+JT)
6239 XHRD=VINT(140+JT)
6240 Q2HRD=VINT(54)
6241 MINT(105)=MINT(102+JT)
6242 MINT(109)=MINT(106+JT)
6243 IF(MSTP(57).LE.1) THEN
6244 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
6245 ELSE
6246 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
6247 ENDIF
6248 WTMX=4D0*XPQ(KFLH)
6249 IF(MSTP(13).EQ.2) THEN
6250 Q2PMS=Q2HRD/PMAS(11,1)**2
6251 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
6252 ENDIF
6253 300 XE=XHRD**PYR(0)
6254 XG=MIN(0.999999D0,XHRD/XE)
6255 IF(MSTP(57).LE.1) THEN
6256 CALL PYPDFU(22,XG,Q2HRD,XPQ)
6257 ELSE
6258 CALL PYPDFL(22,XG,Q2HRD,XPQ)
6259 ENDIF
6260 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
6261 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
6262 IF(WT.LT.PYR(0)*WTMX) GOTO 300
6263 MINT(18+JT)=1
6264 VINT(154+JT)=XE
6265 DO 310 KFLS=-25,25
6266 XSFX(JT,KFLS)=XPQ(KFLS)
6267 310 CONTINUE
6268 ENDIF
6269 320 CONTINUE
6270
6271C...Pick scale where photon is resolved.
6272 IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2*
6273 &(VINT(54)/PARP(15)**2)**PYR(0)
6274 IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2*
6275 &(VINT(54)/PARP(15)**2)**PYR(0)
6276 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6277
6278C...Format statements for differential cross-section maximum violations.
6279 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
6280 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6281 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
6282 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
6283 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
6284 &'in event',1X,I7)
6285 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
6286 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6287 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
6288 &'in event',1X,I7)
6289 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
6290 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
6291 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
6292
6293 RETURN
6294 END
6295
6296C*********************************************************************
6297
6298C...PYSCAT
6299C...Finds outgoing flavours and event type; sets up the kinematics
6300C...and colour flow of the hard scattering
6301
6302 SUBROUTINE PYSCAT
6303
6304C...Double precision and integer declarations
6305 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6306 INTEGER PYK,PYCHGE,PYCOMP
6307C...Parameter statement to help give large particle numbers.
6308 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6309C...Commonblocks
6310 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6311 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6312 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6313 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6314 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6315 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6316 COMMON/PYINT1/MINT(400),VINT(400)
6317 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6318 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6319 COMMON/PYINT4/MWID(500),WIDS(500,5)
6320 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6321 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6322 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
6323 &SFMIX(16,4)
6324 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
6325 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
6326C...Local arrays and saved variables
6327 DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
6328 &PHI(2),KUPPO(20),VINTSV(41:66)
6329 SAVE VINTSV
6330
6331C...Read out process
6332 ISUB=MINT(1)
6333 ISUBSV=ISUB
6334
6335C...Restore information for low-pT processes
6336 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
6337 DO 100 J=41,66
6338 100 VINT(J)=VINTSV(J)
6339 ENDIF
6340
6341C...Convert H' or A process into equivalent H one
6342 IHIGG=1
6343 KFHIGG=25
6344 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
6345 &ISUB.LE.190)) THEN
6346 IHIGG=2
6347 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
6348 KFHIGG=33+IHIGG
6349 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
6350 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
6351 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
6352 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
6353 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
6354 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
6355 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
6356 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
6357 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
6358 ENDIF
6359
6360C...Choice of subprocess, number of documentation lines
6361 IDOC=6+ISET(ISUB)
6362 IF(ISUB.EQ.95) IDOC=8
6363 IF(ISET(ISUB).EQ.5) IDOC=9
6364 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
6365 MINT(3)=IDOC-6
6366 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
6367 MINT(4)=IDOC
6368 IPU1=MINT(84)+1
6369 IPU2=MINT(84)+2
6370 IPU3=MINT(84)+3
6371 IPU4=MINT(84)+4
6372 IPU5=MINT(84)+5
6373 IPU6=MINT(84)+6
6374
6375C...Reset K, P and V vectors. Store incoming particles
6376 DO 120 JT=1,MSTP(126)+20
6377 I=MINT(83)+JT
6378 DO 110 J=1,5
6379 K(I,J)=0
6380 P(I,J)=0D0
6381 V(I,J)=0D0
6382 110 CONTINUE
6383 120 CONTINUE
6384 DO 140 JT=1,2
6385 I=MINT(83)+JT
6386 K(I,1)=21
6387 K(I,2)=MINT(10+JT)
6388 DO 130 J=1,5
6389 P(I,J)=VINT(285+5*JT+J)
6390 130 CONTINUE
6391 140 CONTINUE
6392 MINT(6)=2
6393 KFRES=0
6394
6395C...Store incoming partons in their CM-frame
6396 SH=VINT(44)
6397 SHR=SQRT(SH)
6398 SHP=VINT(26)*VINT(2)
6399 SHPR=SQRT(SHP)
6400 SHUSER=SHR
6401 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
6402 DO 150 JT=1,2
6403 I=MINT(84)+JT
6404 K(I,1)=14
6405 K(I,2)=MINT(14+JT)
6406 K(I,3)=MINT(83)+2+JT
6407 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
6408 P(I,4)=0.5D0*SHUSER
6409 150 CONTINUE
6410
6411C...Copy incoming partons to documentation lines
6412 DO 170 JT=1,2
6413 I1=MINT(83)+4+JT
6414 I2=MINT(84)+JT
6415 K(I1,1)=21
6416 K(I1,2)=K(I2,2)
6417 K(I1,3)=I1-2
6418 DO 160 J=1,5
6419 P(I1,J)=P(I2,J)
6420 160 CONTINUE
6421 170 CONTINUE
6422
6423C...Choose new quark/lepton flavour for relevant annihilation graphs
6424 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58) THEN
6425 IGLGA=21
6426 IF(ISUB.EQ.58) IGLGA=22
6427 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
6428 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
6429 DO 190 I=1,MDCY(IGLGA,3)
6430 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
6431 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
6432 IF(RKFL.LE.0D0) GOTO 200
6433 190 CONTINUE
6434 200 CONTINUE
6435 IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
6436 & IABS(KFLF).GE.3) THEN
6437 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
6438 & VINT(44)**2
6439 FACCIB=VINT(46)**2/PARU(155)**4
6440 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
6441 ELSEIF(ISUB.EQ.54) THEN
6442 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
6443 ELSEIF(ISUB.EQ.58) THEN
6444 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
6445 ENDIF
6446 ENDIF
6447
6448C...Final state flavours and colour flow: default values
6449 JS=1
6450 MINT(21)=MINT(15)
6451 MINT(22)=MINT(16)
6452 MINT(23)=0
6453 MINT(24)=0
6454 KCC=20
6455 KCS=ISIGN(1,MINT(15))
6456
6457 IF(ISET(ISUB).EQ.11) THEN
6458C...User-defined processes: find products
6459 IRUP=0
6460 DO 210 IUP=3,NUP
6461 IF(KUP(IUP,1).NE.1) THEN
6462 ELSEIF(IRUP.LE.5) THEN
6463 IRUP=IRUP+1
6464 MINT(20+IRUP)=KUP(IUP,2)
6465 ENDIF
6466 210 CONTINUE
6467
6468 ELSEIF(ISUB.LE.10) THEN
6469 IF(ISUB.EQ.1) THEN
6470C...f + fbar -> gamma*/Z0
6471 KFRES=23
6472
6473 ELSEIF(ISUB.EQ.2) THEN
6474C...f + fbar' -> W+/-
6475 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6476 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6477 KFRES=ISIGN(24,KCH1+KCH2)
6478
6479 ELSEIF(ISUB.EQ.3) THEN
6480C...f + fbar -> h0 (or H0, or A0)
6481 KFRES=KFHIGG
6482
6483 ELSEIF(ISUB.EQ.4) THEN
6484C...gamma + W+/- -> W+/-
6485
6486 ELSEIF(ISUB.EQ.5) THEN
6487C...Z0 + Z0 -> h0
6488 XH=SH/SHP
6489 MINT(21)=MINT(15)
6490 MINT(22)=MINT(16)
6491 PMQ(1)=PYMASS(MINT(21))
6492 PMQ(2)=PYMASS(MINT(22))
6493 220 JT=INT(1.5D0+PYR(0))
6494 ZMIN=2D0*PMQ(JT)/SHPR
6495 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6496 & (SHPR*(SHPR-PMQ(3-JT)))
6497 ZMAX=MIN(1D0-XH,ZMAX)
6498 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6499 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6500 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
6501 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6502 IF(SQC1.LT.1.D-8) GOTO 220
6503 C1=SQRT(SQC1)
6504 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6505 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6506 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6507 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6508 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6509 IF(SQC1.LT.1.D-8) GOTO 220
6510 C1=SQRT(SQC1)
6511 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6512 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6513 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6514 PHIR=PARU(2)*PYR(0)
6515 CPHI=COS(PHIR)
6516 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6517 & SQRT(1D0-CTHE(2)**2)*CPHI
6518 Z1=2D0-Z(JT)
6519 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6520 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6521 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6522 & PMQ(3-JT)**2/SHP))
6523 ZMIN=2D0*PMQ(3-JT)/SHPR
6524 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6525 ZMAX=MIN(1D0-XH,ZMAX)
6526 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
6527 KCC=22
6528 KFRES=25
6529
6530 ELSEIF(ISUB.EQ.6) THEN
6531C...Z0 + W+/- -> W+/-
6532
6533 ELSEIF(ISUB.EQ.7) THEN
6534C...W+ + W- -> Z0
6535
6536 ELSEIF(ISUB.EQ.8) THEN
6537C...W+ + W- -> h0
6538 XH=SH/SHP
6539 230 DO 260 JT=1,2
6540 I=MINT(14+JT)
6541 IA=IABS(I)
6542 IF(IA.LE.10) THEN
6543 RVCKM=VINT(180+I)*PYR(0)
6544 DO 240 J=1,MSTP(1)
6545 IB=2*J-1+MOD(IA,2)
6546 IPM=(5-ISIGN(1,I))/2
6547 IDC=J+MDCY(IA,2)+2
6548 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
6549 MINT(20+JT)=ISIGN(IB,I)
6550 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6551 IF(RVCKM.LE.0D0) GOTO 250
6552 240 CONTINUE
6553 ELSE
6554 IB=2*((IA+1)/2)-1+MOD(IA,2)
6555 MINT(20+JT)=ISIGN(IB,I)
6556 ENDIF
6557 250 PMQ(JT)=PYMASS(MINT(20+JT))
6558 260 CONTINUE
6559 JT=INT(1.5D0+PYR(0))
6560 ZMIN=2D0*PMQ(JT)/SHPR
6561 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6562 & (SHPR*(SHPR-PMQ(3-JT)))
6563 ZMAX=MIN(1D0-XH,ZMAX)
6564 IF(ZMIN.GE.ZMAX) GOTO 230
6565 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6566 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6567 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
6568 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6569 IF(SQC1.LT.1.D-8) GOTO 230
6570 C1=SQRT(SQC1)
6571 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6572 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6573 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6574 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6575 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6576 IF(SQC1.LT.1.D-8) GOTO 230
6577 C1=SQRT(SQC1)
6578 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6579 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6580 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6581 PHIR=PARU(2)*PYR(0)
6582 CPHI=COS(PHIR)
6583 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6584 & SQRT(1D0-CTHE(2)**2)*CPHI
6585 Z1=2D0-Z(JT)
6586 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6587 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6588 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6589 & PMQ(3-JT)**2/SHP))
6590 ZMIN=2D0*PMQ(3-JT)/SHPR
6591 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6592 ZMAX=MIN(1D0-XH,ZMAX)
6593 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
6594 KCC=22
6595 KFRES=25
6596
6597 ELSEIF(ISUB.EQ.10) THEN
6598C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
6599 IF(MINT(2).EQ.1) THEN
6600 KCC=22
6601 ELSE
6602C...W exchange: need to mix flavours according to CKM matrix
6603 DO 280 JT=1,2
6604 I=MINT(14+JT)
6605 IA=IABS(I)
6606 IF(IA.LE.10) THEN
6607 RVCKM=VINT(180+I)*PYR(0)
6608 DO 270 J=1,MSTP(1)
6609 IB=2*J-1+MOD(IA,2)
6610 IPM=(5-ISIGN(1,I))/2
6611 IDC=J+MDCY(IA,2)+2
6612 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
6613 MINT(20+JT)=ISIGN(IB,I)
6614 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6615 IF(RVCKM.LE.0D0) GOTO 280
6616 270 CONTINUE
6617 ELSE
6618 IB=2*((IA+1)/2)-1+MOD(IA,2)
6619 MINT(20+JT)=ISIGN(IB,I)
6620 ENDIF
6621 280 CONTINUE
6622 KCC=22
6623 ENDIF
6624 ENDIF
6625
6626 ELSEIF(ISUB.LE.20) THEN
6627 IF(ISUB.EQ.11) THEN
6628C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
6629 KCC=MINT(2)
6630 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
6631
6632 ELSEIF(ISUB.EQ.12) THEN
6633C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
6634 MINT(21)=ISIGN(KFLF,MINT(15))
6635 MINT(22)=-MINT(21)
6636 KCC=4
6637
6638 ELSEIF(ISUB.EQ.13) THEN
6639C...f + fbar -> g + g; th arbitrary
6640 MINT(21)=21
6641 MINT(22)=21
6642 KCC=MINT(2)+4
6643
6644 ELSEIF(ISUB.EQ.14) THEN
6645C...f + fbar -> g + gamma; th arbitrary
6646 IF(PYR(0).GT.0.5D0) JS=2
6647 MINT(20+JS)=21
6648 MINT(23-JS)=22
6649 KCC=17+JS
6650
6651 ELSEIF(ISUB.EQ.15) THEN
6652C...f + fbar -> g + Z0; th arbitrary
6653 IF(PYR(0).GT.0.5D0) JS=2
6654 MINT(20+JS)=21
6655 MINT(23-JS)=23
6656 KCC=17+JS
6657
6658 ELSEIF(ISUB.EQ.16) THEN
6659C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6660 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6661 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6662 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6663 MINT(20+JS)=21
6664 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6665 KCC=17+JS
6666
6667 ELSEIF(ISUB.EQ.17) THEN
6668C...f + fbar -> g + h0; th arbitrary
6669 IF(PYR(0).GT.0.5D0) JS=2
6670 MINT(20+JS)=21
6671 MINT(23-JS)=25
6672 KCC=17+JS
6673
6674 ELSEIF(ISUB.EQ.18) THEN
6675C...f + fbar -> gamma + gamma; th arbitrary
6676 MINT(21)=22
6677 MINT(22)=22
6678
6679 ELSEIF(ISUB.EQ.19) THEN
6680C...f + fbar -> gamma + Z0; th arbitrary
6681 IF(PYR(0).GT.0.5D0) JS=2
6682 MINT(20+JS)=22
6683 MINT(23-JS)=23
6684
6685 ELSEIF(ISUB.EQ.20) THEN
6686C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
6687C...(p(fbar')-p(W+))**2
6688 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6689 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6690 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6691 MINT(20+JS)=22
6692 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6693 ENDIF
6694
6695 ELSEIF(ISUB.LE.30) THEN
6696 IF(ISUB.EQ.21) THEN
6697C...f + fbar -> gamma + h0; th arbitrary
6698 IF(PYR(0).GT.0.5D0) JS=2
6699 MINT(20+JS)=22
6700 MINT(23-JS)=25
6701
6702 ELSEIF(ISUB.EQ.22) THEN
6703C...f + fbar -> Z0 + Z0; th arbitrary
6704 MINT(21)=23
6705 MINT(22)=23
6706
6707 ELSEIF(ISUB.EQ.23) THEN
6708C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6709 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6710 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6711 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6712 MINT(20+JS)=23
6713 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6714
6715 ELSEIF(ISUB.EQ.24) THEN
6716C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
6717 IF(PYR(0).GT.0.5D0) JS=2
6718 MINT(20+JS)=23
6719 MINT(23-JS)=KFHIGG
6720
6721 ELSEIF(ISUB.EQ.25) THEN
6722C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
6723 MINT(21)=-ISIGN(24,MINT(15))
6724 MINT(22)=-MINT(21)
6725
6726 ELSEIF(ISUB.EQ.26) THEN
6727C...f + fbar' -> W+/- + h0 (or H0, or A0);
6728C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6729 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6730 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6731 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
6732 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
6733 MINT(23-JS)=KFHIGG
6734
6735 ELSEIF(ISUB.EQ.27) THEN
6736C...f + fbar -> h0 + h0
6737
6738 ELSEIF(ISUB.EQ.28) THEN
6739C...f + g -> f + g; th = (p(f)-p(f))**2
6740 KCC=MINT(2)+6
6741 IF(MINT(15).EQ.21) KCC=KCC+2
6742 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
6743 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
6744
6745 ELSEIF(ISUB.EQ.29) THEN
6746C...f + g -> f + gamma; th = (p(f)-p(f))**2
6747 IF(MINT(15).EQ.21) JS=2
6748 MINT(23-JS)=22
6749 KCC=15+JS
6750 KCS=ISIGN(1,MINT(14+JS))
6751
6752 ELSEIF(ISUB.EQ.30) THEN
6753C...f + g -> f + Z0; th = (p(f)-p(f))**2
6754 IF(MINT(15).EQ.21) JS=2
6755 MINT(23-JS)=23
6756 KCC=15+JS
6757 KCS=ISIGN(1,MINT(14+JS))
6758 ENDIF
6759
6760 ELSEIF(ISUB.LE.40) THEN
6761 IF(ISUB.EQ.31) THEN
6762C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
6763 IF(MINT(15).EQ.21) JS=2
6764 I=MINT(14+JS)
6765 IA=IABS(I)
6766 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6767 RVCKM=VINT(180+I)*PYR(0)
6768 DO 290 J=1,MSTP(1)
6769 IB=2*J-1+MOD(IA,2)
6770 IPM=(5-ISIGN(1,I))/2
6771 IDC=J+MDCY(IA,2)+2
6772 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
6773 MINT(20+JS)=ISIGN(IB,I)
6774 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6775 IF(RVCKM.LE.0D0) GOTO 300
6776 290 CONTINUE
6777 300 KCC=15+JS
6778 KCS=ISIGN(1,MINT(14+JS))
6779
6780 ELSEIF(ISUB.EQ.32) THEN
6781C...f + g -> f + h0; th = (p(f)-p(f))**2
6782 IF(MINT(15).EQ.21) JS=2
6783 MINT(23-JS)=25
6784 KCC=15+JS
6785 KCS=ISIGN(1,MINT(14+JS))
6786
6787 ELSEIF(ISUB.EQ.33) THEN
6788C...f + gamma -> f + g; th=(p(f)-p(f))**2
6789 IF(MINT(15).EQ.22) JS=2
6790 MINT(23-JS)=21
6791 KCC=24+JS
6792 KCS=ISIGN(1,MINT(14+JS))
6793
6794 ELSEIF(ISUB.EQ.34) THEN
6795C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
6796 IF(MINT(15).EQ.22) JS=2
6797 KCC=22
6798 KCS=ISIGN(1,MINT(14+JS))
6799
6800 ELSEIF(ISUB.EQ.35) THEN
6801C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
6802 IF(MINT(15).EQ.22) JS=2
6803 MINT(23-JS)=23
6804 KCC=22
6805
6806 ELSEIF(ISUB.EQ.36) THEN
6807C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
6808 IF(MINT(15).EQ.22) JS=2
6809 I=MINT(14+JS)
6810 IA=IABS(I)
6811 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6812 IF(IA.LE.10) THEN
6813 RVCKM=VINT(180+I)*PYR(0)
6814 DO 310 J=1,MSTP(1)
6815 IB=2*J-1+MOD(IA,2)
6816 IPM=(5-ISIGN(1,I))/2
6817 IDC=J+MDCY(IA,2)+2
6818 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
6819 MINT(20+JS)=ISIGN(IB,I)
6820 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6821 IF(RVCKM.LE.0D0) GOTO 320
6822 310 CONTINUE
6823 ELSE
6824 IB=2*((IA+1)/2)-1+MOD(IA,2)
6825 MINT(20+JS)=ISIGN(IB,I)
6826 ENDIF
6827 320 KCC=22
6828
6829 ELSEIF(ISUB.EQ.37) THEN
6830C...f + gamma -> f + h0
6831
6832 ELSEIF(ISUB.EQ.38) THEN
6833C...f + Z0 -> f + g
6834
6835 ELSEIF(ISUB.EQ.39) THEN
6836C...f + Z0 -> f + gamma
6837
6838 ELSEIF(ISUB.EQ.40) THEN
6839C...f + Z0 -> f + Z0
6840 ENDIF
6841
6842 ELSEIF(ISUB.LE.50) THEN
6843 IF(ISUB.EQ.41) THEN
6844C...f + Z0 -> f' + W+/-
6845
6846 ELSEIF(ISUB.EQ.42) THEN
6847C...f + Z0 -> f + h0
6848
6849 ELSEIF(ISUB.EQ.43) THEN
6850C...f + W+/- -> f' + g
6851
6852 ELSEIF(ISUB.EQ.44) THEN
6853C...f + W+/- -> f' + gamma
6854
6855 ELSEIF(ISUB.EQ.45) THEN
6856C...f + W+/- -> f' + Z0
6857
6858 ELSEIF(ISUB.EQ.46) THEN
6859C...f + W+/- -> f' + W+/-
6860
6861 ELSEIF(ISUB.EQ.47) THEN
6862C...f + W+/- -> f' + h0
6863
6864 ELSEIF(ISUB.EQ.48) THEN
6865C...f + h0 -> f + g
6866
6867 ELSEIF(ISUB.EQ.49) THEN
6868C...f + h0 -> f + gamma
6869
6870 ELSEIF(ISUB.EQ.50) THEN
6871C...f + h0 -> f + Z0
6872 ENDIF
6873
6874 ELSEIF(ISUB.LE.60) THEN
6875 IF(ISUB.EQ.51) THEN
6876C...f + h0 -> f' + W+/-
6877
6878 ELSEIF(ISUB.EQ.52) THEN
6879C...f + h0 -> f + h0
6880
6881 ELSEIF(ISUB.EQ.53) THEN
6882C...g + g -> f + fbar; th arbitrary
6883 KCS=(-1)**INT(1.5D0+PYR(0))
6884 MINT(21)=ISIGN(KFLF,KCS)
6885 MINT(22)=-MINT(21)
6886 KCC=MINT(2)+10
6887
6888 ELSEIF(ISUB.EQ.54) THEN
6889C...g + gamma -> f + fbar; th arbitrary
6890 KCS=(-1)**INT(1.5D0+PYR(0))
6891 MINT(21)=ISIGN(KFLF,KCS)
6892 MINT(22)=-MINT(21)
6893 KCC=27
6894 IF(MINT(16).EQ.21) KCC=28
6895
6896 ELSEIF(ISUB.EQ.55) THEN
6897C...g + Z0 -> f + fbar
6898
6899 ELSEIF(ISUB.EQ.56) THEN
6900C...g + W+/- -> f + fbar'
6901
6902 ELSEIF(ISUB.EQ.57) THEN
6903C...g + h0 -> f + fbar
6904
6905 ELSEIF(ISUB.EQ.58) THEN
6906C...gamma + gamma -> f + fbar; th arbitrary
6907 KCS=(-1)**INT(1.5D0+PYR(0))
6908 MINT(21)=ISIGN(KFLF,KCS)
6909 MINT(22)=-MINT(21)
6910 KCC=21
6911
6912 ELSEIF(ISUB.EQ.59) THEN
6913C...gamma + Z0 -> f + fbar
6914
6915 ELSEIF(ISUB.EQ.60) THEN
6916C...gamma + W+/- -> f + fbar'
6917 ENDIF
6918
6919 ELSEIF(ISUB.LE.70) THEN
6920 IF(ISUB.EQ.61) THEN
6921C...gamma + h0 -> f + fbar
6922
6923 ELSEIF(ISUB.EQ.62) THEN
6924C...Z0 + Z0 -> f + fbar
6925
6926 ELSEIF(ISUB.EQ.63) THEN
6927C...Z0 + W+/- -> f + fbar'
6928
6929 ELSEIF(ISUB.EQ.64) THEN
6930C...Z0 + h0 -> f + fbar
6931
6932 ELSEIF(ISUB.EQ.65) THEN
6933C...W+ + W- -> f + fbar
6934
6935 ELSEIF(ISUB.EQ.66) THEN
6936C...W+/- + h0 -> f + fbar'
6937
6938 ELSEIF(ISUB.EQ.67) THEN
6939C...h0 + h0 -> f + fbar
6940
6941 ELSEIF(ISUB.EQ.68) THEN
6942C...g + g -> g + g; th arbitrary
6943 KCC=MINT(2)+12
6944 KCS=(-1)**INT(1.5D0+PYR(0))
6945
6946 ELSEIF(ISUB.EQ.69) THEN
6947C...gamma + gamma -> W+ + W-; th arbitrary
6948 MINT(21)=24
6949 MINT(22)=-24
6950 KCC=21
6951
6952 ELSEIF(ISUB.EQ.70) THEN
6953C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
6954 IF(MINT(15).EQ.22) MINT(21)=23
6955 IF(MINT(16).EQ.22) MINT(22)=23
6956 KCC=21
6957 ENDIF
6958
6959 ELSEIF(ISUB.LE.80) THEN
6960 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
6961C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
6962 XH=SH/SHP
6963 MINT(21)=MINT(15)
6964 MINT(22)=MINT(16)
6965 PMQ(1)=PYMASS(MINT(21))
6966 PMQ(2)=PYMASS(MINT(22))
6967 330 JT=INT(1.5D0+PYR(0))
6968 ZMIN=2D0*PMQ(JT)/SHPR
6969 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6970 & (SHPR*(SHPR-PMQ(3-JT)))
6971 ZMAX=MIN(1D0-XH,ZMAX)
6972 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6973 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6974 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
6975 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6976 IF(SQC1.LT.1.D-8) GOTO 330
6977 C1=SQRT(SQC1)
6978 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6979 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6980 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6981 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6982 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6983 IF(SQC1.LT.1.D-8) GOTO 330
6984 C1=SQRT(SQC1)
6985 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6986 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6987 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6988 PHIR=PARU(2)*PYR(0)
6989 CPHI=COS(PHIR)
6990 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6991 & SQRT(1D0-CTHE(2)**2)*CPHI
6992 Z1=2D0-Z(JT)
6993 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6994 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6995 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6996 & PMQ(3-JT)**2/SHP))
6997 ZMIN=2D0*PMQ(3-JT)/SHPR
6998 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6999 ZMAX=MIN(1D0-XH,ZMAX)
7000 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
7001 KCC=22
7002
7003 ELSEIF(ISUB.EQ.73) THEN
7004C...Z0 + W+/- -> Z0 + W+/-
7005 JS=MINT(2)
7006 XH=SH/SHP
7007 340 JT=3-MINT(2)
7008 I=MINT(14+JT)
7009 IA=IABS(I)
7010 IF(IA.LE.10) THEN
7011 RVCKM=VINT(180+I)*PYR(0)
7012 DO 350 J=1,MSTP(1)
7013 IB=2*J-1+MOD(IA,2)
7014 IPM=(5-ISIGN(1,I))/2
7015 IDC=J+MDCY(IA,2)+2
7016 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
7017 MINT(20+JT)=ISIGN(IB,I)
7018 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7019 IF(RVCKM.LE.0D0) GOTO 360
7020 350 CONTINUE
7021 ELSE
7022 IB=2*((IA+1)/2)-1+MOD(IA,2)
7023 MINT(20+JT)=ISIGN(IB,I)
7024 ENDIF
7025 360 PMQ(JT)=PYMASS(MINT(20+JT))
7026 MINT(23-JT)=MINT(17-JT)
7027 PMQ(3-JT)=PYMASS(MINT(23-JT))
7028 JT=INT(1.5D0+PYR(0))
7029 ZMIN=2D0*PMQ(JT)/SHPR
7030 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7031 & (SHPR*(SHPR-PMQ(3-JT)))
7032 ZMAX=MIN(1D0-XH,ZMAX)
7033 IF(ZMIN.GE.ZMAX) GOTO 340
7034 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7035 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7036 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
7037 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7038 IF(SQC1.LT.1.D-8) GOTO 340
7039 C1=SQRT(SQC1)
7040 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7041 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7042 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7043 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7044 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7045 IF(SQC1.LT.1.D-8) GOTO 340
7046 C1=SQRT(SQC1)
7047 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7048 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7049 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7050 PHIR=PARU(2)*PYR(0)
7051 CPHI=COS(PHIR)
7052 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7053 & SQRT(1D0-CTHE(2)**2)*CPHI
7054 Z1=2D0-Z(JT)
7055 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7056 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7057 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7058 & PMQ(3-JT)**2/SHP))
7059 ZMIN=2D0*PMQ(3-JT)/SHPR
7060 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7061 ZMAX=MIN(1D0-XH,ZMAX)
7062 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
7063 KCC=22
7064
7065 ELSEIF(ISUB.EQ.74) THEN
7066C...Z0 + h0 -> Z0 + h0
7067
7068 ELSEIF(ISUB.EQ.75) THEN
7069C...W+ + W- -> gamma + gamma
7070
7071 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
7072C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
7073 XH=SH/SHP
7074 370 DO 400 JT=1,2
7075 I=MINT(14+JT)
7076 IA=IABS(I)
7077 IF(IA.LE.10) THEN
7078 RVCKM=VINT(180+I)*PYR(0)
7079 DO 380 J=1,MSTP(1)
7080 IB=2*J-1+MOD(IA,2)
7081 IPM=(5-ISIGN(1,I))/2
7082 IDC=J+MDCY(IA,2)+2
7083 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
7084 MINT(20+JT)=ISIGN(IB,I)
7085 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7086 IF(RVCKM.LE.0D0) GOTO 390
7087 380 CONTINUE
7088 ELSE
7089 IB=2*((IA+1)/2)-1+MOD(IA,2)
7090 MINT(20+JT)=ISIGN(IB,I)
7091 ENDIF
7092 390 PMQ(JT)=PYMASS(MINT(20+JT))
7093 400 CONTINUE
7094 JT=INT(1.5D0+PYR(0))
7095 ZMIN=2D0*PMQ(JT)/SHPR
7096 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7097 & (SHPR*(SHPR-PMQ(3-JT)))
7098 ZMAX=MIN(1D0-XH,ZMAX)
7099 IF(ZMIN.GE.ZMAX) GOTO 370
7100 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7101 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7102 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
7103 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7104 IF(SQC1.LT.1.D-8) GOTO 370
7105 C1=SQRT(SQC1)
7106 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7107 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7108 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7109 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7110 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7111 IF(SQC1.LT.1.D-8) GOTO 370
7112 C1=SQRT(SQC1)
7113 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7114 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7115 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7116 PHIR=PARU(2)*PYR(0)
7117 CPHI=COS(PHIR)
7118 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7119 & SQRT(1D0-CTHE(2)**2)*CPHI
7120 Z1=2D0-Z(JT)
7121 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7122 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7123 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7124 & PMQ(3-JT)**2/SHP))
7125 ZMIN=2D0*PMQ(3-JT)/SHPR
7126 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7127 ZMAX=MIN(1D0-XH,ZMAX)
7128 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
7129 KCC=22
7130
7131 ELSEIF(ISUB.EQ.78) THEN
7132C...W+/- + h0 -> W+/- + h0
7133
7134 ELSEIF(ISUB.EQ.79) THEN
7135C...h0 + h0 -> h0 + h0
7136
7137 ELSEIF(ISUB.EQ.80) THEN
7138C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
7139 IF(MINT(15).EQ.22) JS=2
7140 I=MINT(14+JS)
7141 IA=IABS(I)
7142 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
7143 IB=3-IA
7144 MINT(20+JS)=ISIGN(IB,I)
7145 KCC=22
7146 ENDIF
7147
7148 ELSEIF(ISUB.LE.90) THEN
7149 IF(ISUB.EQ.81) THEN
7150C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
7151 MINT(21)=ISIGN(MINT(55),MINT(15))
7152 MINT(22)=-MINT(21)
7153 KCC=4
7154
7155 ELSEIF(ISUB.EQ.82) THEN
7156C...g + g -> Q + Qbar; th arbitrary
7157 KCS=(-1)**INT(1.5D0+PYR(0))
7158 MINT(21)=ISIGN(MINT(55),KCS)
7159 MINT(22)=-MINT(21)
7160 KCC=MINT(2)+10
7161
7162 ELSEIF(ISUB.EQ.83) THEN
7163C...f + q -> f' + Q; th = (p(f) - p(f'))**2
7164 KFOLD=MINT(16)
7165 IF(MINT(2).EQ.2) KFOLD=MINT(15)
7166 KFAOLD=IABS(KFOLD)
7167 IF(KFAOLD.GT.10) THEN
7168 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
7169 ELSE
7170 RCKM=VINT(180+KFOLD)*PYR(0)
7171 IPM=(5-ISIGN(1,KFOLD))/2
7172 KFANEW=-MOD(KFAOLD+1,2)
7173 410 KFANEW=KFANEW+2
7174 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
7175 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
7176 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
7177 & VCKM(KFAOLD/2,(KFANEW+1)/2)
7178 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
7179 & VCKM(KFANEW/2,(KFAOLD+1)/2)
7180 ENDIF
7181 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
7182 ENDIF
7183 IF(MINT(2).EQ.1) THEN
7184 MINT(21)=ISIGN(MINT(55),MINT(15))
7185 MINT(22)=ISIGN(KFANEW,MINT(16))
7186 ELSE
7187 MINT(21)=ISIGN(KFANEW,MINT(15))
7188 MINT(22)=ISIGN(MINT(55),MINT(16))
7189 JS=2
7190 ENDIF
7191 KCC=22
7192
7193 ELSEIF(ISUB.EQ.84) THEN
7194C...g + gamma -> Q + Qbar; th arbitary
7195 KCS=(-1)**INT(1.5D0+PYR(0))
7196 MINT(21)=ISIGN(MINT(55),KCS)
7197 MINT(22)=-MINT(21)
7198 KCC=27
7199 IF(MINT(16).EQ.21) KCC=28
7200
7201 ELSEIF(ISUB.EQ.85) THEN
7202C...gamma + gamma -> F + Fbar; th arbitary
7203 KCS=(-1)**INT(1.5D0+PYR(0))
7204 MINT(21)=ISIGN(MINT(56),KCS)
7205 MINT(22)=-MINT(21)
7206 KCC=21
7207
7208 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
7209C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
7210 MINT(21)=KFPR(ISUB,1)
7211 MINT(22)=KFPR(ISUB,2)
7212 KCC=24
7213 KCS=(-1)**INT(1.5D0+PYR(0))
7214 ENDIF
7215
7216 ELSEIF(ISUB.LE.100) THEN
7217 IF(ISUB.EQ.95) THEN
7218C...Low-pT ( = energyless g + g -> g + g)
7219 KCC=MINT(2)+12
7220 KCS=(-1)**INT(1.5D0+PYR(0))
7221
7222 ELSEIF(ISUB.EQ.96) THEN
7223C...Multiple interactions (should be reassigned to QCD process)
7224 ENDIF
7225
7226 ELSEIF(ISUB.LE.110) THEN
7227 IF(ISUB.EQ.101) THEN
7228C...g + g -> gamma*/Z0
7229 KCC=21
7230 KFRES=22
7231
7232 ELSEIF(ISUB.EQ.102) THEN
7233C...g + g -> h0 (or H0, or A0)
7234 KCC=21
7235 KFRES=KFHIGG
7236
7237 ELSEIF(ISUB.EQ.103) THEN
7238C...gamma + gamma -> h0 (or H0, or A0)
7239 KCC=21
7240 KFRES=KFHIGG
7241
7242 ELSEIF(ISUB.EQ.106) THEN
7243C...g + g -> J/Psi + gamma
7244 MINT(21)=KFPR(ISUB,1)
7245 MINT(22)=KFPR(ISUB,2)
7246 KCC=21
7247
7248 ELSEIF(ISUB.EQ.107) THEN
7249C...g + gamma -> J/Psi + g
7250 MINT(21)=KFPR(ISUB,1)
7251 MINT(22)=KFPR(ISUB,2)
7252 KCC=22
7253 IF(MINT(16).EQ.22) KCC=33
7254
7255 ELSEIF(ISUB.EQ.108) THEN
7256C...gamma + gamma -> J/Psi + gamma
7257 MINT(21)=KFPR(ISUB,1)
7258 MINT(22)=KFPR(ISUB,2)
7259
7260 ELSEIF(ISUB.EQ.110) THEN
7261C...f + fbar -> gamma + h0; th arbitrary
7262 IF(PYR(0).GT.0.5D0) JS=2
7263 MINT(20+JS)=22
7264 MINT(23-JS)=KFHIGG
7265 ENDIF
7266
7267 ELSEIF(ISUB.LE.120) THEN
7268 IF(ISUB.EQ.111) THEN
7269C...f + fbar -> g + h0; th arbitrary
7270 IF(PYR(0).GT.0.5D0) JS=2
7271 MINT(20+JS)=21
7272 MINT(23-JS)=25
7273 KCC=17+JS
7274
7275 ELSEIF(ISUB.EQ.112) THEN
7276C...f + g -> f + h0; th = (p(f) - p(f))**2
7277 IF(MINT(15).EQ.21) JS=2
7278 MINT(23-JS)=25
7279 KCC=15+JS
7280 KCS=ISIGN(1,MINT(14+JS))
7281
7282 ELSEIF(ISUB.EQ.113) THEN
7283C...g + g -> g + h0; th arbitrary
7284 IF(PYR(0).GT.0.5D0) JS=2
7285 MINT(23-JS)=25
7286 KCC=22+JS
7287 KCS=(-1)**INT(1.5D0+PYR(0))
7288
7289 ELSEIF(ISUB.EQ.114) THEN
7290C...g + g -> gamma + gamma; th arbitrary
7291 IF(PYR(0).GT.0.5D0) JS=2
7292 MINT(21)=22
7293 MINT(22)=22
7294 KCC=21
7295
7296 ELSEIF(ISUB.EQ.115) THEN
7297C...g + g -> g + gamma; th arbitrary
7298 IF(PYR(0).GT.0.5D0) JS=2
7299 MINT(23-JS)=22
7300 KCC=22+JS
7301 KCS=(-1)**INT(1.5D0+PYR(0))
7302
7303 ELSEIF(ISUB.EQ.116) THEN
7304C...g + g -> gamma + Z0
7305
7306 ELSEIF(ISUB.EQ.117) THEN
7307C...g + g -> Z0 + Z0
7308
7309 ELSEIF(ISUB.EQ.118) THEN
7310C...g + g -> W+ + W-
7311 ENDIF
7312
7313 ELSEIF(ISUB.LE.140) THEN
7314 IF(ISUB.EQ.121) THEN
7315C...g + g -> Q + Qbar + h0
7316 KCS=(-1)**INT(1.5D0+PYR(0))
7317 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
7318 MINT(22)=-MINT(21)
7319 KCC=11+INT(0.5D0+PYR(0))
7320 KFRES=KFHIGG
7321
7322 ELSEIF(ISUB.EQ.122) THEN
7323C...q + qbar -> Q + Qbar + h0
7324 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
7325 MINT(22)=-MINT(21)
7326 KCC=4
7327 KFRES=KFHIGG
7328
7329 ELSEIF(ISUB.EQ.123) THEN
7330C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
7331C...inner process)
7332 KCC=22
7333 KFRES=KFHIGG
7334
7335 ELSEIF(ISUB.EQ.124) THEN
7336C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
7337C...inner process)
7338 DO 430 JT=1,2
7339 I=MINT(14+JT)
7340 IA=IABS(I)
7341 IF(IA.LE.10) THEN
7342 RVCKM=VINT(180+I)*PYR(0)
7343 DO 420 J=1,MSTP(1)
7344 IB=2*J-1+MOD(IA,2)
7345 IPM=(5-ISIGN(1,I))/2
7346 IDC=J+MDCY(IA,2)+2
7347 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
7348 MINT(20+JT)=ISIGN(IB,I)
7349 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7350 IF(RVCKM.LE.0D0) GOTO 430
7351 420 CONTINUE
7352 ELSE
7353 IB=2*((IA+1)/2)-1+MOD(IA,2)
7354 MINT(20+JT)=ISIGN(IB,I)
7355 ENDIF
7356 430 CONTINUE
7357 KCC=22
7358 KFRES=KFHIGG
7359
7360 ELSEIF(ISUB.EQ.131) THEN
7361C...g + g -> Z0 + q + qbar
7362 ENDIF
7363
7364 ELSEIF(ISUB.LE.160) THEN
7365 IF(ISUB.EQ.141) THEN
7366C...f + fbar -> gamma*/Z0/Z'0
7367 KFRES=32
7368
7369 ELSEIF(ISUB.EQ.142) THEN
7370C...f + fbar' -> W'+/-
7371 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7372 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7373 KFRES=ISIGN(34,KCH1+KCH2)
7374
7375 ELSEIF(ISUB.EQ.143) THEN
7376C...f + fbar' -> H+/-
7377 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7378 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7379 KFRES=ISIGN(37,KCH1+KCH2)
7380
7381 ELSEIF(ISUB.EQ.144) THEN
7382C...f + fbar' -> R
7383 KFRES=ISIGN(40,MINT(15)+MINT(16))
7384
7385 ELSEIF(ISUB.EQ.145) THEN
7386C...q + l -> LQ (leptoquark)
7387 IF(IABS(MINT(16)).LE.8) JS=2
7388 KFRES=ISIGN(39,MINT(14+JS))
7389 KCC=28+JS
7390 KCS=ISIGN(1,MINT(14+JS))
7391
7392 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
7393C...q + g -> q* (excited quark)
7394 IF(MINT(15).EQ.21) JS=2
7395 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
7396 KCC=30+JS
7397 KCS=ISIGN(1,MINT(14+JS))
7398
7399 ELSEIF(ISUB.EQ.149) THEN
7400C...g + g -> eta_techni
7401 KFRES=38
7402 KCC=23
7403 KCS=(-1)**INT(1.5D0+PYR(0))
7404 ENDIF
7405
7406 ELSEIF(ISUB.LE.200) THEN
7407 IF(ISUB.EQ.161) THEN
7408C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
7409 IF(MINT(15).EQ.21) JS=2
7410 I=MINT(14+JS)
7411 IA=IABS(I)
7412 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
7413 IB=IA+MOD(IA,2)-MOD(IA+1,2)
7414 MINT(20+JS)=ISIGN(IB,I)
7415 KCC=15+JS
7416 KCS=ISIGN(1,MINT(14+JS))
7417
7418 ELSEIF(ISUB.EQ.162) THEN
7419C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
7420 IF(MINT(15).EQ.21) JS=2
7421 MINT(20+JS)=ISIGN(39,MINT(14+JS))
7422 KFLQL=KFDP(MDCY(39,2),2)
7423 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
7424 KCC=15+JS
7425 KCS=ISIGN(1,MINT(14+JS))
7426
7427 ELSEIF(ISUB.EQ.163) THEN
7428C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
7429 KCS=(-1)**INT(1.5D0+PYR(0))
7430 MINT(21)=ISIGN(39,KCS)
7431 MINT(22)=-MINT(21)
7432 KCC=MINT(2)+10
7433
7434 ELSEIF(ISUB.EQ.164) THEN
7435C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
7436 MINT(21)=ISIGN(39,MINT(15))
7437 MINT(22)=-MINT(21)
7438 KCC=4
7439
7440 ELSEIF(ISUB.EQ.165) THEN
7441C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
7442 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7443 MINT(22)=-MINT(21)
7444
7445 ELSEIF(ISUB.EQ.166) THEN
7446C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
7447 IF(MOD(MINT(15),2).EQ.0) THEN
7448 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
7449 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
7450 ELSE
7451 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7452 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
7453 ENDIF
7454
7455 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
7456C...q + q' -> q" + q* (excited quark)
7457 KFQSTR=KFPR(ISUB,2)
7458 KFQEXC=MOD(KFQSTR,KEXCIT)
7459 JS=MINT(2)
7460 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
7461 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
7462 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
7463 KCC=22
7464
7465 ELSEIF(ISUB.EQ.191) THEN
7466C...f + fbar -> rho_tech0.
7467 KFRES=54
7468
7469 ELSEIF(ISUB.EQ.192) THEN
7470C...f + fbar' -> rho_tech+/-
7471 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7472 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7473 KFRES=ISIGN(55,KCH1+KCH2)
7474
7475 ELSEIF(ISUB.EQ.193) THEN
7476C...f + fbar -> omega_tech0.
7477 KFRES=56
7478
7479 ELSEIF(ISUB.EQ.194) THEN
7480C...f + fbar -> f' + fbar' via mixture of s-channel
7481C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
7482 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7483 MINT(22)=-MINT(21)
7484 ENDIF
7485
7486CMRENNA++
7487 ELSEIF(ISUB.LE.215) THEN
7488 IF(ISUB.EQ.201) THEN
7489C...f + fbar -> ~e_L + ~e_Lbar
7490 MINT(21)=ISIGN(KSUSY1+11,KCS)
7491 MINT(22)=-MINT(21)
7492
7493 ELSEIF(ISUB.EQ.202) THEN
7494C...f + fbar -> ~e_R + ~e_Rbar
7495 MINT(21)=ISIGN(KSUSY2+11,KCS)
7496 MINT(22)=-MINT(21)
7497
7498 ELSEIF(ISUB.EQ.203) THEN
7499C...f + fbar -> ~e_R + ~e_Lbar
7500 KCS=1
7501 IF(MINT(2).EQ.2) KCS=-1
7502 MINT(21)=ISIGN(KSUSY1+11,KCS)
7503 MINT(22)=-ISIGN(KSUSY2+11,KCS)
7504
7505 ELSEIF(ISUB.EQ.204) THEN
7506C...f + fbar -> ~mu_L + ~mu_Lbar
7507 MINT(21)=ISIGN(KSUSY1+13,KCS)
7508 MINT(22)=-MINT(21)
7509
7510 ELSEIF(ISUB.EQ.205) THEN
7511C...f + fbar -> ~mu_R + ~mu_Rbar
7512 MINT(21)=ISIGN(KSUSY2+13,KCS)
7513 MINT(22)=-MINT(21)
7514
7515 ELSEIF(ISUB.EQ.206) THEN
7516C...f + fbar -> ~mu_L + ~mu_Rbar
7517 KCS=1
7518 IF(MINT(2).EQ.2) KCS=-1
7519 MINT(21)=ISIGN(KSUSY1+13,KCS)
7520 MINT(22)=-ISIGN(KSUSY2+13,KCS)
7521
7522 ELSEIF(ISUB.EQ.207) THEN
7523C...f + fbar -> ~tau_1 + ~tau_1bar
7524 MINT(21)=ISIGN(KSUSY1+15,KCS)
7525 MINT(22)=-MINT(21)
7526
7527 ELSEIF(ISUB.EQ.208) THEN
7528C...f + fbar -> ~tau_2 + ~tau_2bar
7529 MINT(21)=ISIGN(KSUSY2+15,KCS)
7530 MINT(22)=-MINT(21)
7531
7532 ELSEIF(ISUB.EQ.209) THEN
7533C...f + fbar -> ~tau_1 + ~tau_2bar
7534 KCS=1
7535 IF(MINT(2).EQ.2) KCS=-1
7536 MINT(21)=ISIGN(KSUSY1+15,KCS)
7537 MINT(22)=-ISIGN(KSUSY2+15,KCS)
7538
7539 ELSEIF(ISUB.EQ.210) THEN
7540C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
7541 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7542 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7543 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
7544 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
7545
7546 ELSEIF(ISUB.EQ.211) THEN
7547C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
7548 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7549 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7550 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
7551 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7552
7553 ELSEIF(ISUB.EQ.212) THEN
7554C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
7555 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7556 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7557 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
7558 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7559
7560 ELSEIF(ISUB.EQ.213) THEN
7561C...f + fbar -> ~nul + ~nulbar
7562 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7563 MINT(22)=-MINT(21)
7564
7565 ELSEIF(ISUB.EQ.214) THEN
7566C...f + fbar -> ~nutau + ~nutaubar
7567 MINT(21)=ISIGN(KSUSY1+16,KCS)
7568 MINT(22)=-MINT(21)
7569 ENDIF
7570
7571 ELSEIF(ISUB.LE.225) THEN
7572 IF(ISUB.EQ.216) THEN
7573C...f + fbar -> ~chi01 + ~chi01
7574 MINT(21)=KSUSY1+22
7575 MINT(22)=KSUSY1+22
7576
7577 ELSEIF(ISUB.EQ.217) THEN
7578C...f + fbar -> ~chi02 + ~chi02
7579 MINT(21)=KSUSY1+23
7580 MINT(22)=KSUSY1+23
7581
7582 ELSEIF(ISUB.EQ.218 ) THEN
7583C...f + fbar -> ~chi03 + ~chi03
7584 MINT(21)=KSUSY1+25
7585 MINT(22)=KSUSY1+25
7586
7587 ELSEIF(ISUB.EQ.219 ) THEN
7588C...f + fbar -> ~chi04 + ~chi04
7589 MINT(21)=KSUSY1+35
7590 MINT(22)=KSUSY1+35
7591
7592 ELSEIF(ISUB.EQ.220 ) THEN
7593C...f + fbar -> ~chi01 + ~chi02
7594 IF(PYR(0).GT.0.5D0) JS=2
7595 MINT(20+JS)=KSUSY1+22
7596 MINT(23-JS)=KSUSY1+23
7597
7598 ELSEIF(ISUB.EQ.221 ) THEN
7599C...f + fbar -> ~chi01 + ~chi03
7600 IF(PYR(0).GT.0.5D0) JS=2
7601 MINT(20+JS)=KSUSY1+22
7602 MINT(23-JS)=KSUSY1+25
7603
7604 ELSEIF(ISUB.EQ.222) THEN
7605C...f + fbar -> ~chi01 + ~chi04
7606 IF(PYR(0).GT.0.5D0) JS=2
7607 MINT(20+JS)=KSUSY1+22
7608 MINT(23-JS)=KSUSY1+35
7609
7610 ELSEIF(ISUB.EQ.223) THEN
7611C...f + fbar -> ~chi02 + ~chi03
7612 IF(PYR(0).GT.0.5D0) JS=2
7613 MINT(20+JS)=KSUSY1+23
7614 MINT(23-JS)=KSUSY1+25
7615
7616 ELSEIF(ISUB.EQ.224) THEN
7617C...f + fbar -> ~chi02 + ~chi04
7618 IF(PYR(0).GT.0.5D0) JS=2
7619 MINT(20+JS)=KSUSY1+23
7620 MINT(23-JS)=KSUSY1+35
7621
7622 ELSEIF(ISUB.EQ.225) THEN
7623C...f + fbar -> ~chi03 + ~chi04
7624 IF(PYR(0).GT.0.5D0) JS=2
7625 MINT(20+JS)=KSUSY1+25
7626 MINT(23-JS)=KSUSY1+35
7627 ENDIF
7628
7629 ELSEIF(ISUB.LE.236) THEN
7630 IF(ISUB.EQ.226) THEN
7631C...f + fbar -> ~chi+-1 + ~chi-+1
7632C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
7633 MINT(21)=ISIGN(KSUSY1+24,MINT(15))
7634 MINT(22)=-MINT(21)
7635
7636 ELSEIF(ISUB.EQ.227) THEN
7637C...f + fbar -> ~chi+-2 + ~chi-+2
7638 MINT(21)=ISIGN(KSUSY1+37,MINT(15))
7639 MINT(22)=-MINT(21)
7640
7641 ELSEIF(ISUB.EQ.228) THEN
7642C...f + fbar -> ~chi+-1 + ~chi-+2
7643C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
7644C...js=1 if pyr<.5, js=2 if pyr>.5
7645C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
7646C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
7647C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
7648C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
7649 KCH1=ISIGN(1,MINT(15))
7650 KCH2=INT(1-KCH1)/2
7651 IF(MINT(2).EQ.1) THEN
7652 MINT(22-KCH2)= -(KSUSY1+24)
7653 MINT(21+KCH2)= KSUSY1+37
7654 IF(KCH2.EQ.0) JS=2
7655 ELSE
7656 MINT(21+KCH2)= KSUSY1+24
7657 MINT(22-KCH2)= -(KSUSY1+37)
7658 IF(KCH2.EQ.1) JS=2
7659 ENDIF
7660
7661 ELSEIF(ISUB.EQ.229) THEN
7662C...q + qbar' -> ~chi01 + ~chi+-1
7663C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
7664 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7665 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7666C...CHECK THIS
7667 IF(MOD(MINT(15),2).NE.0) JS=2
7668 MINT(20+JS)=KSUSY1+22
7669 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7670
7671 ELSEIF(ISUB.EQ.230) THEN
7672C...q + qbar' -> ~chi02 + ~chi+-1
7673 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7674 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7675 IF(MOD(MINT(15),2).NE.0) JS=2
7676 MINT(20+JS)=KSUSY1+23
7677 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7678
7679 ELSEIF(ISUB.EQ.231) THEN
7680C...q + qbar' -> ~chi03 + ~chi+-1
7681 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7682 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7683 IF(MOD(MINT(15),2).NE.0) JS=2
7684 MINT(20+JS)=KSUSY1+25
7685 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7686
7687 ELSEIF(ISUB.EQ.232) THEN
7688C...q + qbar' -> ~chi04 + ~chi+-1
7689 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7690 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7691 IF(MOD(MINT(15),2).NE.0) JS=2
7692 MINT(20+JS)=KSUSY1+35
7693 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7694
7695 ELSEIF(ISUB.EQ.233) THEN
7696C...q + qbar' -> ~chi01 + ~chi+-2
7697 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7698 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7699 IF(MOD(MINT(15),2).NE.0) JS=2
7700 MINT(20+JS)=KSUSY1+22
7701 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7702
7703 ELSEIF(ISUB.EQ.234) THEN
7704C...q + qbar' -> ~chi02 + ~chi+-2
7705 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7706 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7707 IF(MOD(MINT(15),2).NE.0) JS=2
7708 MINT(20+JS)=KSUSY1+23
7709 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7710
7711 ELSEIF(ISUB.EQ.235) THEN
7712C...q + qbar' -> ~chi03 + ~chi+-2
7713 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7714 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7715 IF(MOD(MINT(15),2).NE.0) JS=2
7716 MINT(20+JS)=KSUSY1+25
7717 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7718
7719 ELSEIF(ISUB.EQ.236) THEN
7720C...q + qbar' -> ~chi04 + ~chi+-2
7721 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7722 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7723 IF(MOD(MINT(15),2).NE.0) JS=2
7724 MINT(20+JS)=KSUSY1+35
7725 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7726 ENDIF
7727
7728 ELSEIF(ISUB.LE.245) THEN
7729 IF(ISUB.EQ.237) THEN
7730C...q + qbar -> ~chi01 + ~g
7731C...th arbitrary
7732 IF(PYR(0).GT.0.5D0) JS=2
7733 MINT(20+JS)=KSUSY1+21
7734 MINT(23-JS)=KSUSY1+22
7735 KCC=17+JS
7736
7737 ELSEIF(ISUB.EQ.238) THEN
7738C...q + qbar -> ~chi02 + ~g
7739C...th arbitrary
7740 IF(PYR(0).GT.0.5D0) JS=2
7741 MINT(20+JS)=KSUSY1+21
7742 MINT(23-JS)=KSUSY1+23
7743 KCC=17+JS
7744
7745 ELSEIF(ISUB.EQ.239) THEN
7746C...q + qbar -> ~chi03 + ~g
7747C...th arbitrary
7748 IF(PYR(0).GT.0.5D0) JS=2
7749 MINT(20+JS)=KSUSY1+21
7750 MINT(23-JS)=KSUSY1+25
7751 KCC=17+JS
7752
7753 ELSEIF(ISUB.EQ.240) THEN
7754C...q + qbar -> ~chi04 + ~g
7755C...th arbitrary
7756 IF(PYR(0).GT.0.5D0) JS=2
7757 MINT(20+JS)=KSUSY1+21
7758 MINT(23-JS)=KSUSY1+35
7759 KCC=17+JS
7760
7761 ELSEIF(ISUB.EQ.241) THEN
7762C...q + qbar' -> ~chi+-1 + ~g
7763C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7764C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7765C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7766C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7767C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7768 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7769 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7770 JS=1
7771 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7772 MINT(20+JS)=KSUSY1+21
7773 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7774 KCC=17+JS
7775
7776 ELSEIF(ISUB.EQ.242) THEN
7777C...q + qbar' -> ~chi+-2 + ~g
7778C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7779C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7780C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7781C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7782C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7783 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7784 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7785 JS=1
7786 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7787 MINT(20+JS)=KSUSY1+21
7788 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7789 KCC=17+JS
7790
7791 ELSEIF(ISUB.EQ.243) THEN
7792C...q + qbar -> ~g + ~g ; th arbitrary
7793 MINT(21)=KSUSY1+21
7794 MINT(22)=KSUSY1+21
7795 KCC=MINT(2)+4
7796
7797 ELSEIF(ISUB.EQ.244) THEN
7798C...g + g -> ~g + ~g ; th arbitrary
7799 KCC=MINT(2)+12
7800 KCS=(-1)**INT(1.5D0+PYR(0))
7801 MINT(21)=KSUSY1+21
7802 MINT(22)=KSUSY1+21
7803 ENDIF
7804
7805 ELSEIF(ISUB.LE.260) THEN
7806 IF(ISUB.EQ.246) THEN
7807C...qj + g -> ~qj_L + ~chi01
7808 IF(MINT(15).EQ.21) JS=2
7809 I=MINT(14+JS)
7810 IA=IABS(I)
7811 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7812 MINT(23-JS)=KSUSY1+22
7813 KCC=15+JS
7814 KCS=ISIGN(1,MINT(14+JS))
7815
7816 ELSEIF(ISUB.EQ.247) THEN
7817C...qj + g -> ~qj_R + ~chi01
7818 IF(MINT(15).EQ.21) JS=2
7819 I=MINT(14+JS)
7820 IA=IABS(I)
7821 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7822 MINT(23-JS)=KSUSY1+22
7823 KCC=15+JS
7824 KCS=ISIGN(1,MINT(14+JS))
7825
7826 ELSEIF(ISUB.EQ.248) THEN
7827C...qj + g -> ~qj_L + ~chi02
7828 IF(MINT(15).EQ.21) JS=2
7829 I=MINT(14+JS)
7830 IA=IABS(I)
7831 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7832 MINT(23-JS)=KSUSY1+23
7833 KCC=15+JS
7834 KCS=ISIGN(1,MINT(14+JS))
7835
7836 ELSEIF(ISUB.EQ.249) THEN
7837C...qj + g -> ~qj_R + ~chi02
7838 IF(MINT(15).EQ.21) JS=2
7839 I=MINT(14+JS)
7840 IA=IABS(I)
7841 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7842 MINT(23-JS)=KSUSY1+23
7843 KCC=15+JS
7844 KCS=ISIGN(1,MINT(14+JS))
7845
7846 ELSEIF(ISUB.EQ.250) THEN
7847C...qj + g -> ~qj_L + ~chi03
7848 IF(MINT(15).EQ.21) JS=2
7849 I=MINT(14+JS)
7850 IA=IABS(I)
7851 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7852 MINT(23-JS)=KSUSY1+25
7853 KCC=15+JS
7854 KCS=ISIGN(1,MINT(14+JS))
7855
7856 ELSEIF(ISUB.EQ.251) THEN
7857C...qj + g -> ~qj_R + ~chi03
7858 IF(MINT(15).EQ.21) JS=2
7859 I=MINT(14+JS)
7860 IA=IABS(I)
7861 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7862 MINT(23-JS)=KSUSY1+25
7863 KCC=15+JS
7864 KCS=ISIGN(1,MINT(14+JS))
7865
7866 ELSEIF(ISUB.EQ.252) THEN
7867C...qj + g -> ~qj_L + ~chi04
7868 IF(MINT(15).EQ.21) JS=2
7869 I=MINT(14+JS)
7870 IA=IABS(I)
7871 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7872 MINT(23-JS)=KSUSY1+35
7873 KCC=15+JS
7874 KCS=ISIGN(1,MINT(14+JS))
7875
7876 ELSEIF(ISUB.EQ.253) THEN
7877C...qj + g -> ~qj_R + ~chi04
7878 IF(MINT(15).EQ.21) JS=2
7879 I=MINT(14+JS)
7880 IA=IABS(I)
7881 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7882 MINT(23-JS)=KSUSY1+35
7883 KCC=15+JS
7884 KCS=ISIGN(1,MINT(14+JS))
7885
7886 ELSEIF(ISUB.EQ.254) THEN
7887C...qj + g -> ~qk_L + ~chi+-1
7888 IF(MINT(15).EQ.21) JS=2
7889 I=MINT(14+JS)
7890 IA=IABS(I)
7891 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7892 IB=-IA+INT((IA+1)/2)*4-1
7893 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7894 KCC=15+JS
7895 KCS=ISIGN(1,MINT(14+JS))
7896
7897 ELSEIF(ISUB.EQ.255) THEN
7898C...qj + g -> ~qk_L + ~chi+-1
7899 IF(MINT(15).EQ.21) JS=2
7900 I=MINT(14+JS)
7901 IA=IABS(I)
7902 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7903 IB=-IA+INT((IA+1)/2)*4-1
7904 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7905 KCC=15+JS
7906 KCS=ISIGN(1,MINT(14+JS))
7907
7908 ELSEIF(ISUB.EQ.256) THEN
7909C...qj + g -> ~qk_L + ~chi+-2
7910 IF(MINT(15).EQ.21) JS=2
7911 I=MINT(14+JS)
7912 IA=IABS(I)
7913 IB=-IA+INT((IA+1)/2)*4-1
7914 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7915 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7916 KCC=15+JS
7917 KCS=ISIGN(1,MINT(14+JS))
7918
7919 ELSEIF(ISUB.EQ.257) THEN
7920C...qj + g -> ~qk_R + ~chi+-2
7921 IF(MINT(15).EQ.21) JS=2
7922 I=MINT(14+JS)
7923 IA=IABS(I)
7924 IB=-IA+INT((IA+1)/2)*4-1
7925 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7926 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7927 KCC=15+JS
7928 KCS=ISIGN(1,MINT(14+JS))
7929
7930 ELSEIF(ISUB.EQ.258) THEN
7931C...qj + g -> ~qj_L + ~g
7932 IF(MINT(15).EQ.21) JS=2
7933 I=MINT(14+JS)
7934 IA=IABS(I)
7935 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7936 MINT(23-JS)=KSUSY1+21
7937 KCC=MINT(2)+6
7938 IF(JS.EQ.2) KCC=KCC+2
7939 KCS=ISIGN(1,I)
7940
7941 ELSEIF(ISUB.EQ.259) THEN
7942C...qj + g -> ~qj_R + ~g
7943 IF(MINT(15).EQ.21) JS=2
7944 I=MINT(14+JS)
7945 IA=IABS(I)
7946 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7947 MINT(23-JS)=KSUSY1+21
7948 KCC=MINT(2)+6
7949 IF(JS.EQ.2) KCC=KCC+2
7950 KCS=ISIGN(1,I)
7951 ENDIF
7952
7953 ELSEIF(ISUB.LE.270) THEN
7954 IF(ISUB.EQ.261) THEN
7955C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
7956 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7957 MINT(22)=-MINT(21)
7958C...Correct color combination
7959 IF(MINT(43).EQ.4) KCC=4
7960
7961 ELSEIF(ISUB.EQ.262) THEN
7962C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
7963 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7964 MINT(22)=-MINT(21)
7965C...Correct color combination
7966 IF(MINT(43).EQ.4) KCC=4
7967
7968 ELSEIF(ISUB.EQ.263) THEN
7969C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
7970 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
7971 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
7972 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7973 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
7974 ELSE
7975 JS=2
7976 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
7977 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
7978 ENDIF
7979C...Correct color combination
7980 IF(MINT(43).EQ.4) KCC=4
7981
7982 ELSEIF(ISUB.EQ.264) THEN
7983C...g + g -> ~t_1 + ~t_1bar; th arbitrary
7984 KCS=(-1)**INT(1.5D0+PYR(0))
7985 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7986 MINT(22)=-MINT(21)
7987 KCC=MINT(2)+10
7988
7989 ELSEIF(ISUB.EQ.265) THEN
7990C...g + g -> ~t_2 + ~t_2bar; th arbitrary
7991 KCS=(-1)**INT(1.5D0+PYR(0))
7992 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7993 MINT(22)=-MINT(21)
7994 KCC=MINT(2)+10
7995 ENDIF
7996
7997 ELSEIF(ISUB.LE.280) THEN
7998 IF(ISUB.EQ.271) THEN
7999C...qi + qj -> ~qi_L + ~qj_L
8000 KCC=MINT(2)
8001 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8002 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8003 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8004
8005 ELSEIF(ISUB.EQ.272) THEN
8006C...qi + qj -> ~qi_R + ~qj_R
8007 KCC=MINT(2)
8008 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8009 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8010 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8011
8012 ELSEIF(ISUB.EQ.273) THEN
8013C...qi + qj -> ~qi_L + ~qj_R
8014 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8015 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8016 KCC=MINT(2)
8017 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8018
8019 ELSEIF(ISUB.EQ.274) THEN
8020C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
8021 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8022 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8023 KCC=MINT(2)
8024 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8025
8026 ELSEIF(ISUB.EQ.275) THEN
8027C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8028 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8029 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8030 KCC=MINT(2)
8031 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8032
8033 ELSEIF(ISUB.EQ.276) THEN
8034C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8035 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8036 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8037 KCC=MINT(2)
8038 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8039
8040 ELSEIF(ISUB.EQ.277) THEN
8041C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
8042 ISGN=1
8043 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8044 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8045 MINT(22)=-MINT(21)
8046 IF(MINT(43).EQ.4) KCC=4
8047
8048 ELSEIF(ISUB.EQ.278) THEN
8049C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
8050 ISGN=1
8051 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8052 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8053 MINT(22)=-MINT(21)
8054 IF(MINT(43).EQ.4) KCC=4
8055
8056 ELSEIF(ISUB.EQ.279) THEN
8057C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
8058C...pure LL + RR
8059 KCS=(-1)**INT(1.5D0+PYR(0))
8060 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8061 MINT(22)=-MINT(21)
8062 KCC=MINT(2)+10
8063
8064 ELSEIF(ISUB.EQ.280) THEN
8065C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
8066 KCS=(-1)**INT(1.5D0+PYR(0))
8067 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8068 MINT(22)=-MINT(21)
8069 KCC=MINT(2)+10
8070 ENDIF
8071
8072CMRENNA--
8073 ENDIF
8074
8075 IF(ISET(ISUB).EQ.11) THEN
8076C...Store documentation for user-defined processes
8077 BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
8078 KUPPO(1)=MINT(83)+5
8079 KUPPO(2)=MINT(83)+6
8080 I=MINT(83)+6
8081 DO 450 IUP=3,NUP
8082 KUPPO(IUP)=0
8083 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
8084 IDOC=IDOC-1
8085 MINT(4)=MINT(4)-1
8086 GOTO 450
8087 ENDIF
8088 I=I+1
8089 KUPPO(IUP)=I
8090 K(I,1)=21
8091 K(I,2)=KUP(IUP,2)
8092 K(I,3)=0
8093 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
8094 K(I,4)=0
8095 K(I,5)=0
8096 DO 440 J=1,5
8097 P(I,J)=PUP(IUP,J)
8098 440 CONTINUE
8099 450 CONTINUE
8100 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
8101 & -BEZUP)
8102
8103C...Store final state partons for user-defined processes
8104 N=IPU2
8105 DO 470 IUP=3,NUP
8106 N=N+1
8107 K(N,1)=1
8108 IF(KUP(IUP,1).NE.1) K(N,1)=11
8109 K(N,2)=KUP(IUP,2)
8110 IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
8111 K(N,3)=KUPPO(IUP)
8112 ELSE
8113 K(N,3)=MINT(84)+KUP(IUP,3)
8114 ENDIF
8115 K(N,4)=0
8116 K(N,5)=0
8117 DO 460 J=1,5
8118 P(N,J)=PUP(IUP,J)
8119 460 CONTINUE
8120 470 CONTINUE
8121 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
8122
8123C...Arrange colour flow for user-defined processes
8124 N=MINT(84)
8125 DO 480 IUP=1,NUP
8126 N=N+1
8127 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
8128 IF(K(N,1).EQ.1) K(N,1)=3
8129 IF(K(N,1).EQ.11) K(N,1)=14
8130 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
8131 & MINT(84))
8132 IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
8133 & MINT(84))
8134 IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
8135 IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
8136 480 CONTINUE
8137
8138 ELSEIF(IDOC.EQ.7) THEN
8139C...Resonance not decaying; store kinematics
8140 I=MINT(83)+7
8141 K(IPU3,1)=1
8142 K(IPU3,2)=KFRES
8143 K(IPU3,3)=I
8144 P(IPU3,4)=SHUSER
8145 P(IPU3,5)=SHUSER
8146 K(I,1)=21
8147 K(I,2)=KFRES
8148 P(I,4)=SHUSER
8149 P(I,5)=SHUSER
8150 N=IPU3
8151 MINT(21)=KFRES
8152 MINT(22)=0
8153
8154C...Special cases: colour flow in coloured resonances
8155 KCRES=PYCOMP(KFRES)
8156 IF(KCHG(KCRES,2).NE.0) THEN
8157 K(IPU3,1)=3
8158 DO 490 J=1,2
8159 JC=J
8160 IF(KCS.EQ.-1) JC=3-J
8161 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8162 & MINT(84)+ICOL(KCC,1,JC)
8163 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8164 & MINT(84)+ICOL(KCC,2,JC)
8165 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8166 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8167 490 CONTINUE
8168 ELSE
8169 K(IPU1,4)=IPU2
8170 K(IPU1,5)=IPU2
8171 K(IPU2,4)=IPU1
8172 K(IPU2,5)=IPU1
8173 ENDIF
8174
8175 ELSEIF(IDOC.EQ.8) THEN
8176C...2 -> 2 processes: store outgoing partons in their CM-frame
8177 DO 500 JT=1,2
8178 I=MINT(84)+2+JT
8179 KCA=PYCOMP(MINT(20+JT))
8180 K(I,1)=1
8181 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8182 K(I,2)=MINT(20+JT)
8183 K(I,3)=MINT(83)+IDOC+JT-2
8184 KFAA=IABS(K(I,2))
8185 IF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN
8186 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8187 ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN
8188 P(I,5)=SQRT(VINT(64))
8189 ELSE
8190 P(I,5)=PYMASS(K(I,2))
8191 ENDIF
8192 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
8193 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
8194 500 CONTINUE
8195 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8196 KFA1=IABS(MINT(21))
8197 KFA2=IABS(MINT(22))
8198 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8199 & THEN
8200 MINT(51)=1
8201 RETURN
8202 ENDIF
8203 P(IPU3,5)=0D0
8204 P(IPU4,5)=0D0
8205 ENDIF
8206 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8207 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
8208 P(IPU4,4)=SHR-P(IPU3,4)
8209 P(IPU4,3)=-P(IPU3,3)
8210 N=IPU4
8211 MINT(7)=MINT(83)+7
8212 MINT(8)=MINT(83)+8
8213
8214C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
8215 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8216
8217 ELSEIF(IDOC.EQ.9) THEN
8218C...2 -> 3 processes: store outgoing partons in their CM frame
8219 DO 510 JT=1,2
8220 I=MINT(84)+2+JT
8221 KCA=PYCOMP(MINT(20+JT))
8222 K(I,1)=1
8223 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8224 K(I,2)=MINT(20+JT)
8225 K(I,3)=MINT(83)+IDOC+JT-3
8226 IF(IABS(K(I,2)).LE.22) THEN
8227 P(I,5)=PYMASS(K(I,2))
8228 ELSE
8229 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8230 ENDIF
8231 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
8232 P(I,1)=PT*COS(VINT(198+5*JT))
8233 P(I,2)=PT*SIN(VINT(198+5*JT))
8234 510 CONTINUE
8235 K(IPU5,1)=1
8236 K(IPU5,2)=KFRES
8237 K(IPU5,3)=MINT(83)+IDOC
8238 P(IPU5,5)=SHR
8239 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8240 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8241 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
8242 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
8243 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
8244 PMT3=SQRT(PMS3)
8245 P(IPU5,3)=PMT3*SINH(VINT(211))
8246 P(IPU5,4)=PMT3*COSH(VINT(211))
8247 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
8248 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
8249 IF(SQL12.LE.0D0) THEN
8250 MINT(51)=1
8251 RETURN
8252 ENDIF
8253 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
8254 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
8255 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
8256 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
8257 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
8258 MINT(23)=KFRES
8259 N=IPU5
8260 MINT(7)=MINT(83)+7
8261 MINT(8)=MINT(83)+8
8262
8263 ELSEIF(IDOC.EQ.11) THEN
8264C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
8265 PHI(1)=PARU(2)*PYR(0)
8266 PHI(2)=PHI(1)-PHIR
8267 DO 520 JT=1,2
8268 I=MINT(84)+2+JT
8269 K(I,1)=1
8270 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8271 K(I,2)=MINT(20+JT)
8272 K(I,3)=MINT(83)+IDOC+JT-2
8273 P(I,5)=PYMASS(K(I,2))
8274 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
8275 MINT(51)=1
8276 RETURN
8277 ENDIF
8278 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8279 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8280 P(I,1)=PTABS*COS(PHI(JT))
8281 P(I,2)=PTABS*SIN(PHI(JT))
8282 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8283 P(I,4)=0.5D0*SHPR*Z(JT)
8284 IZW=MINT(83)+6+JT
8285 K(IZW,1)=21
8286 K(IZW,2)=23
8287 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
8288 K(IZW,3)=IZW-2
8289 P(IZW,1)=-P(I,1)
8290 P(IZW,2)=-P(I,2)
8291 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8292 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8293 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8294 520 CONTINUE
8295 I=MINT(83)+9
8296 K(IPU5,1)=1
8297 K(IPU5,2)=KFRES
8298 K(IPU5,3)=I
8299 P(IPU5,5)=SHR
8300 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8301 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8302 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8303 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8304 K(I,1)=21
8305 K(I,2)=KFRES
8306 DO 530 J=1,5
8307 P(I,J)=P(IPU5,J)
8308 530 CONTINUE
8309 N=IPU5
8310 MINT(23)=KFRES
8311
8312 ELSEIF(IDOC.EQ.12) THEN
8313C...Z0 and W+/- scattering: store bosons and outgoing partons
8314 PHI(1)=PARU(2)*PYR(0)
8315 PHI(2)=PHI(1)-PHIR
8316 JTRAN=INT(1.5D0+PYR(0))
8317 DO 540 JT=1,2
8318 I=MINT(84)+2+JT
8319 K(I,1)=1
8320 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8321 K(I,2)=MINT(20+JT)
8322 K(I,3)=MINT(83)+IDOC+JT-2
8323 P(I,5)=PYMASS(K(I,2))
8324 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
8325 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8326 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8327 P(I,1)=PTABS*COS(PHI(JT))
8328 P(I,2)=PTABS*SIN(PHI(JT))
8329 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8330 P(I,4)=0.5D0*SHPR*Z(JT)
8331 IZW=MINT(83)+6+JT
8332 K(IZW,1)=21
8333 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8334 K(IZW,2)=23
8335 ELSE
8336 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
8337 ENDIF
8338 K(IZW,3)=IZW-2
8339 P(IZW,1)=-P(I,1)
8340 P(IZW,2)=-P(I,2)
8341 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8342 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8343 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8344 IPU=MINT(84)+4+JT
8345 K(IPU,1)=3
8346 K(IPU,2)=KFPR(ISUB,JT)
8347 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
8348 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
8349 K(IPU,3)=MINT(83)+8+JT
8350 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8351 P(IPU,5)=PYMASS(K(IPU,2))
8352 ELSE
8353 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8354 ENDIF
8355 MINT(22+JT)=K(IPU,2)
8356 540 CONTINUE
8357C...Find rotation and boost for hard scattering subsystem
8358 I1=MINT(83)+7
8359 I2=MINT(83)+8
8360 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8361 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8362 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8363 GAMCM=(P(I1,4)+P(I2,4))/SHR
8364 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
8365 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
8366 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
8367 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
8368 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
8369 PHICM=PYANGL(PX,PY)
8370C...Store hard scattering subsystem. Rotate and boost it
8371 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
8372 & P(IPU6,5)**2
8373 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
8374 CTHWZ=VINT(23)
8375 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
8376 PHIWZ=VINT(24)-PHICM
8377 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
8378 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
8379 P(IPU5,3)=PABS*CTHWZ
8380 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
8381 P(IPU6,1)=-P(IPU5,1)
8382 P(IPU6,2)=-P(IPU5,2)
8383 P(IPU6,3)=-P(IPU5,3)
8384 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
8385 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
8386 DO 560 JT=1,2
8387 I1=MINT(83)+8+JT
8388 I2=MINT(84)+4+JT
8389 K(I1,1)=21
8390 K(I1,2)=K(I2,2)
8391 DO 550 J=1,5
8392 P(I1,J)=P(I2,J)
8393 550 CONTINUE
8394 560 CONTINUE
8395 N=IPU6
8396 MINT(7)=MINT(83)+9
8397 MINT(8)=MINT(83)+10
8398 ENDIF
8399
8400 IF(ISET(ISUB).EQ.11) THEN
8401 ELSEIF(IDOC.GE.8) THEN
8402C...Store colour connection indices
8403 DO 570 J=1,2
8404 JC=J
8405 IF(KCS.EQ.-1) JC=3-J
8406 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8407 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
8408 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8409 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
8410 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8411 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8412 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8413 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8414 570 CONTINUE
8415
8416C...Copy outgoing partons to documentation lines
8417 IMAX=2
8418 IF(IDOC.EQ.9) IMAX=3
8419 DO 590 I=1,IMAX
8420 I1=MINT(83)+IDOC-IMAX+I
8421 I2=MINT(84)+2+I
8422 K(I1,1)=21
8423 K(I1,2)=K(I2,2)
8424 IF(IDOC.LE.9) K(I1,3)=0
8425 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
8426 DO 580 J=1,5
8427 P(I1,J)=P(I2,J)
8428 580 CONTINUE
8429 590 CONTINUE
8430
8431 ELSEIF(IDOC.EQ.9) THEN
8432C...Store colour connection indices
8433 DO 600 J=1,2
8434 JC=J
8435 IF(KCS.EQ.-1) JC=3-J
8436 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8437 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
8438 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
8439 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8440 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
8441 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
8442 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8443 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8444 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
8445 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8446 600 CONTINUE
8447
8448C...Copy outgoing partons to documentation lines
8449 DO 620 I=1,3
8450 I1=MINT(83)+IDOC-3+I
8451 I2=MINT(84)+2+I
8452 K(I1,1)=21
8453 K(I1,2)=K(I2,2)
8454 K(I1,3)=0
8455 DO 610 J=1,5
8456 P(I1,J)=P(I2,J)
8457 610 CONTINUE
8458 620 CONTINUE
8459 ENDIF
8460
8461C...Low-pT events: remove gluons used for string drawing purposes
8462 IF(ISUB.EQ.95) THEN
8463 K(IPU3,1)=K(IPU3,1)+10
8464 K(IPU4,1)=K(IPU4,1)+10
8465 DO 630 J=41,66
8466 VINTSV(J)=VINT(J)
8467 VINT(J)=0D0
8468 630 CONTINUE
8469 DO 650 I=MINT(83)+5,MINT(83)+8
8470 DO 640 J=1,5
8471 P(I,J)=0D0
8472 640 CONTINUE
8473 650 CONTINUE
8474 ENDIF
8475
8476 RETURN
8477 END
8478
8479C*********************************************************************
8480
8481C...PYSSPA
8482C...Generates spacelike parton showers.
8483
8484 SUBROUTINE PYSSPA(IPU1,IPU2)
8485
8486C...Double precision and integer declarations.
8487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8488 INTEGER PYK,PYCHGE,PYCOMP
8489C...Commonblocks.
8490 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8492 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8493 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8494 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8495 COMMON/PYINT1/MINT(400),VINT(400)
8496 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8497 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8498 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8499 &/PYINT2/,/PYINT3/
8500C...Local arrays and data.
8501 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
8502 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
8503 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
8504 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
8505 &THEFIS(2,2),ISFI(2)
8506 DATA IS/2*0/
8507
8508C...Read out basic information; set global Q^2 scale.
8509 IPUS1=IPU1
8510 IPUS2=IPU2
8511 ISUB=MINT(1)
8512 Q2MX=VINT(56)
8513 IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56)
8514
8515C...Initialize QCD evolution and check phase space.
8516 Q2MNC=PARP(62)**2
8517 Q2MNCS(1)=Q2MNC
8518 IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3)
8519 &Q2MNCS(1)=MAX(Q2MNC,VINT(283))
8520 Q2MNCS(2)=Q2MNC
8521 IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3)
8522 &Q2MNCS(2)=MAX(Q2MNC,VINT(284))
8523 MCEV=0
8524 XEC0=2D0*PARP(65)/VINT(1)
8525 ALAMS=PARU(112)
8526 PARU(112)=PARP(61)
8527 FQ2C=1D0
8528 TCMX=0D0
8529 IF(MINT(47).GE.2.AND.(MINT(47).NE.5.OR.MSTP(12).GE.1)) THEN
8530 MCEV=1
8531 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
8532 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
8533 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
8534 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
8535 & MCEV=0
8536 ENDIF
8537
8538C...Initialize QED evolution and check phase space.
8539 Q2MNE=PARP(68)**2
8540 MEEV=0
8541 XEE=1D-6
8542 SPME=PMAS(11,1)**2
8543 TEMX=0D0
8544 FWTE=10D0
8545 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
8546 MEEV=1
8547 TEMX=LOG(Q2MX/SPME)
8548 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
8549 ENDIF
8550 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
8551
8552C...Initial values: flavours, momenta, virtualities.
8553 NS=N
8554 100 N=NS
8555 DO 120 JT=1,2
8556 MORE(JT)=1
8557 KFBEAM(JT)=MINT(10+JT)
8558 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
8559 KFLS(JT)=MINT(14+JT)
8560 KFLS(JT+2)=KFLS(JT)
8561 XS(JT)=VINT(40+JT)
8562 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
8563 ZS(JT)=1D0
8564 Q2S(JT)=Q2MX
8565 TEVCSV(JT)=TCMX
8566 ALAM(JT)=PARP(61)
8567 THE2(JT)=100D0
8568 TEVESV(JT)=TEMX
8569 DO 110 KFL=-25,25
8570 XFS(JT,KFL)=XSFX(JT,KFL)
8571 110 CONTINUE
8572 120 CONTINUE
8573 DSH=VINT(44)
8574 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
8575
8576C...Find if interference with final state partons.
8577 MFIS=0
8578 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
8579 IF(MFIS.NE.0) THEN
8580 DO 140 I=1,2
8581 KCFI(I)=0
8582 KCA=PYCOMP(IABS(KFLS(I)))
8583 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
8584 NFIS(I)=0
8585 IF(KCFI(I).NE.0) THEN
8586 IF(I.EQ.1) IPFS=IPUS1
8587 IF(I.EQ.2) IPFS=IPUS2
8588 DO 130 J=1,2
8589 ICSI=MOD(K(IPFS,3+J),MSTU(5))
8590 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
8591 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
8592 NFIS(I)=NFIS(I)+1
8593 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
8594 & P(ICSI,2)**2))
8595 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
8596 ENDIF
8597 130 CONTINUE
8598 ENDIF
8599 140 CONTINUE
8600 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
8601 ENDIF
8602
8603C...Pick up leg with highest virtuality.
8604 150 N=N+1
8605 JT=1
8606 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
8607 IF(MORE(JT).EQ.0) JT=3-JT
8608 KFLB=KFLS(JT)
8609 XB=XS(JT)
8610 DO 160 KFL=-25,25
8611 XFB(KFL)=XFS(JT,KFL)
8612 160 CONTINUE
8613 DSHR=2D0*SQRT(DSH)
8614 DSHZ=DSH/ZS(JT)
8615
8616C...Check if allowed to branch.
8617 MCEV=0
8618 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
8619 MCEV=1
8620 XEC=MAX(XEC0,XB*(1D0/(1D0-PARP(66))-1D0))
8621 IF(XB.GE.1D0-2D0*XEC) MCEV=0
8622 ENDIF
8623 MEEV=0
8624 IF(MINT(44+JT).EQ.3) THEN
8625 MEEV=1
8626 IF(XB.GE.1D0-2D0*XEE) MEEV=0
8627 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
8628 & MEEV=0
8629C***Currently kill QED shower for resolved photoproduction.
8630 IF(MINT(18+JT).EQ.1) MEEV=0
8631C***Currently kill shower for W inside electron.
8632 IF(IABS(KFLB).EQ.24) THEN
8633 MCEV=0
8634 MEEV=0
8635 ENDIF
8636 ENDIF
8637 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8638 Q2B=0D0
8639 GOTO 250
8640 ENDIF
8641
8642C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
8643 Q2B=Q2S(JT)
8644 TEVCB=TEVCSV(JT)
8645 TEVEB=TEVESV(JT)
8646 IF(MSTP(62).LE.1) THEN
8647 IF(ZS(JT).GT.0.99999D0) THEN
8648 Q2B=Q2S(JT)
8649 ELSE
8650 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
8651 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
8652 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
8653 ENDIF
8654 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8655 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8656 ENDIF
8657 IF(MCEV.EQ.1) THEN
8658 ALSDUM=PYALPS(FQ2C*Q2B)
8659 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
8660 ALAM(JT)=PARU(117)
8661 B0=(33D0-2D0*MSTU(118))/6D0
8662 ENDIF
8663 TEVCBS=TEVCB
8664 TEVEBS=TEVEB
8665
8666C...Select side for interference with final state partons.
8667 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
8668 IFI=N-NS
8669 ISFI(IFI)=0
8670 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
8671 ISFI(IFI)=1
8672 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
8673 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
8674 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
8675 ISFI(IFI)=1
8676 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
8677 ENDIF
8678 ENDIF
8679
8680C...Calculate Altarelli-Parisi weights.
8681 DO 170 KFL=-25,25
8682 WTAPC(KFL)=0D0
8683 WTAPE(KFL)=0D0
8684 WTSF(KFL)=0D0
8685 170 CONTINUE
8686C...q -> q, g -> q.
8687 IF(IABS(KFLB).LE.10) THEN
8688 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
8689 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
8690C...f -> f, gamma -> f.
8691 ELSEIF(IABS(KFLB).LE.20) THEN
8692 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
8693 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
8694 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
8695 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
8696C...f -> g, g -> g.
8697 ELSEIF(KFLB.EQ.21) THEN
8698 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
8699 DO 180 KFL=1,MSTP(58)
8700 WTAPC(KFL)=WTAPQ
8701 WTAPC(-KFL)=WTAPQ
8702 180 CONTINUE
8703 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
8704C...f -> gamma, W+, W-.
8705 ELSEIF(KFLB.EQ.22) THEN
8706 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
8707 WTAPE(11)=WTAPF
8708 WTAPE(-11)=WTAPF
8709 ELSEIF(KFLB.EQ.24) THEN
8710 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8711 & (XEE*(XB+XEE)))/XB
8712 ELSEIF(KFLB.EQ.-24) THEN
8713 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8714 & (XEE*(XB+XEE)))/XB
8715 ENDIF
8716
8717C...Calculate parton distribution weights and sum.
8718 NTRY=0
8719 190 NTRY=NTRY+1
8720 IF(NTRY.GT.500) THEN
8721 MINT(51)=1
8722 RETURN
8723 ENDIF
8724 WTSUMC=0D0
8725 WTSUME=0D0
8726 XFBO=MAX(1D-10,XFB(KFLB))
8727 DO 200 KFL=-25,25
8728 WTSF(KFL)=XFB(KFL)/XFBO
8729 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
8730 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
8731 200 CONTINUE
8732 WTSUMC=MAX(0.0001D0,WTSUMC)
8733 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
8734
8735C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
8736 NTRY2=0
8737 210 NTRY2=NTRY2+1
8738 IF(NTRY2.GT.500) THEN
8739 MINT(51)=1
8740 RETURN
8741 ENDIF
8742 IF(MCEV.EQ.1) THEN
8743 IF(MSTP(64).LE.0) THEN
8744 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
8745 ELSEIF(MSTP(64).EQ.1) THEN
8746 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
8747 ELSE
8748 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
8749 ENDIF
8750 ENDIF
8751 IF(MEEV.EQ.1) THEN
8752 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
8753 & (PARU(101)*FWTE*WTSUME*TEMX)))
8754 ENDIF
8755
8756C...Translate t into Q2 scale; choose between QCD and QED evolution.
8757 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
8758 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
8759 MCE=0
8760 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8761 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
8762 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
8763 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
8764 IF(Q2EB.GT.Q2MNE) MCE=2
8765 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
8766 MCE=1
8767 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
8768 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
8769 ELSE
8770 MCE=2
8771 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
8772 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
8773 ENDIF
8774
8775C...Evolution possibly ended. Update t values.
8776 IF(MCE.EQ.0) THEN
8777 Q2B=0D0
8778 GOTO 250
8779 ELSEIF(MCE.EQ.1) THEN
8780 Q2B=Q2CB
8781 Q2REF=FQ2C*Q2B
8782 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8783 ELSE
8784 Q2B=Q2EB
8785 Q2REF=Q2B
8786 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8787 ENDIF
8788
8789C...Select flavour for branching parton.
8790 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
8791 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
8792 KFLA=-25
8793 230 KFLA=KFLA+1
8794 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
8795 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
8796 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
8797 IF(KFLA.EQ.25) THEN
8798 Q2B=0D0
8799 GOTO 250
8800 ENDIF
8801
8802C...Choose z value and corrective weight.
8803 WTZ=0D0
8804C...q -> q + g.
8805 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
8806 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
8807 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
8808 WTZ=0.5D0*(1D0+Z**2)
8809C...q -> g + q.
8810 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
8811 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
8812 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
8813C...f -> f + gamma.
8814 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
8815 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
8816 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
8817 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
8818 ELSE
8819 Z=XB+XB*(XEE/(1D0-XEE))*
8820 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8821 ENDIF
8822 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
8823C...f -> gamma + f.
8824 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
8825 Z=XB+XB*(XEE/(1D0-XEE))*
8826 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8827 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
8828C...f -> W+- + f'.
8829 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
8830 Z=XB+XB*(XEE/(1D0-XEE))*
8831 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8832 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
8833 & (Q2B/(Q2B+PMAS(24,1)**2))
8834C...g -> q + qbar.
8835 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
8836 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
8837 WTZ=1D0-2D0*Z*(1D0-Z)
8838C...g -> g + g.
8839 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
8840 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
8841 WTZ=(1D0-Z*(1D0-Z))**2
8842C...gamma -> f + fbar.
8843 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
8844 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
8845 WTZ=1D0-2D0*Z*(1D0-Z)
8846 ENDIF
8847 IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
8848
8849C...Option with resummation of soft gluon emission as effective z shift.
8850 IF(MCE.EQ.1) THEN
8851 IF(MSTP(65).GE.1) THEN
8852 RSOFT=6D0
8853 IF(KFLB.NE.21) RSOFT=8D0/3D0
8854 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
8855 IF(Z.LE.XB) GOTO 210
8856 ENDIF
8857
8858C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
8859 IF(MSTP(64).GE.2) THEN
8860 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
8861 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
8862 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
8863 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
8864 ENDIF
8865
8866C...Impose angular constraint in first branching from interference
8867C...with final state partons.
8868 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
8869 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
8870 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
8871 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
8872 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
8873 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
8874 ENDIF
8875 ENDIF
8876
8877C...Option with angular ordering requirement.
8878 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
8879 THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2)
8880 IF(THE2T.GT.THE2(JT)) GOTO 210
8881 ENDIF
8882 ENDIF
8883
8884C...Weighting with new parton distributions.
8885 MINT(105)=MINT(102+JT)
8886 MINT(109)=MINT(106+JT)
8887 IF(MSTP(57).LE.1) THEN
8888 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
8889 ELSE
8890 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
8891 ENDIF
8892 XFBN=XFN(KFLB)
8893 IF(XFBN.LT.1D-20) THEN
8894 IF(KFLA.EQ.KFLB) THEN
8895 TEVCB=TEVCBS
8896 TEVEB=TEVEBS
8897 WTAPC(KFLB)=0D0
8898 WTAPE(KFLB)=0D0
8899 GOTO 190
8900 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
8901 TEVCB=0.5D0*(TEVCBS+TEVCB)
8902 GOTO 220
8903 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
8904 TEVEB=0.5D0*(TEVEBS+TEVEB)
8905 GOTO 220
8906 ELSE
8907 XFBN=1D-10
8908 XFN(KFLB)=XFBN
8909 ENDIF
8910 ENDIF
8911 DO 240 KFL=-25,25
8912 XFB(KFL)=XFN(KFL)
8913 240 CONTINUE
8914 XA=XB/Z
8915 IF(MSTP(57).LE.1) THEN
8916 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
8917 ELSE
8918 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
8919 ENDIF
8920 XFAN=XFA(KFLA)
8921 IF(XFAN.LT.1D-20) GOTO 190
8922 WTSFA=WTSF(KFLA)
8923 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
8924
8925C...Define two hard scatterers in their CM-frame.
8926 250 IF(N.EQ.NS+2) THEN
8927 DQ2(JT)=Q2B
8928 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
8929 DO 270 JR=1,2
8930 I=NS+JR
8931 IF(JR.EQ.1) IPO=IPUS1
8932 IF(JR.EQ.2) IPO=IPUS2
8933 DO 260 J=1,5
8934 K(I,J)=0
8935 P(I,J)=0D0
8936 V(I,J)=0D0
8937 260 CONTINUE
8938 K(I,1)=14
8939 K(I,2)=KFLS(JR+2)
8940 K(I,4)=IPO
8941 K(I,5)=IPO
8942 P(I,3)=DPLCM*(-1)**(JR+1)
8943 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
8944 P(I,5)=-SQRT(DQ2(JR))
8945 K(IPO,1)=14
8946 K(IPO,3)=I
8947 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
8948 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
8949 270 CONTINUE
8950
8951C...Find maximum allowed mass of timelike parton.
8952 ELSEIF(N.GT.NS+2) THEN
8953 JR=3-JT
8954 DQ2(3)=Q2B
8955 DPC(1)=P(IS(1),4)
8956 DPC(2)=P(IS(2),4)
8957 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
8958 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
8959 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
8960 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
8961 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
8962 IKIN=0
8963 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
8964 & 1D-10*DPD(1)) IKIN=1
8965 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
8966 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
8967 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
8968 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
8969
8970C...Generate timelike parton shower (if required).
8971 IT=N
8972 DO 280 J=1,5
8973 K(IT,J)=0
8974 P(IT,J)=0D0
8975 V(IT,J)=0D0
8976 280 CONTINUE
8977 K(IT,1)=3
8978C...f -> f + g (gamma).
8979 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
8980 K(IT,2)=21
8981 IF(IABS(KFLB).GE.11) K(IT,2)=22
8982C...f -> g (gamma, W+-) + f.
8983 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
8984 K(IT,2)=KFLB
8985 IF(KFLS(JT+2).EQ.24) THEN
8986 K(IT,2)=-12
8987 ELSEIF(KFLS(JT+2).EQ.-24) THEN
8988 K(IT,2)=12
8989 ENDIF
8990C...g (gamma) -> f + fbar, g + g.
8991 ELSE
8992 K(IT,2)=-KFLS(JT+2)
8993 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
8994 ENDIF
8995 P(IT,5)=PYMASS(K(IT,2))
8996 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
8997 IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
8998 MSTJ48=MSTJ(48)
8999 PARJ85=PARJ(85)
9000 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
9001 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9002 IF(MSTP(63).EQ.1) THEN
9003 Q2TIM=DMSMA
9004 ELSEIF(MSTP(63).EQ.2) THEN
9005 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
9006 ELSE
9007 Q2TIM=DMSMA
9008 MSTJ(48)=1
9009 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9010 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
9011 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
9012 PARJ(85)=SQRT(MAX(0D0,DPT2))*
9013 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
9014 ENDIF
9015 CALL PYSHOW(IT,0,SQRT(Q2TIM))
9016 MSTJ(48)=MSTJ48
9017 PARJ(85)=PARJ85
9018 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9019 ENDIF
9020
9021C...Reconstruct kinematics of branching: timelike parton shower.
9022 DMS=P(IT,5)**2
9023 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9024 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
9025 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
9026 & (4D0*DSH*DPC(3)**2)
9027 IF(DPT2.LT.0D0) GOTO 100
9028 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9029 & DSHR)/DPC(3)-DPC(3)
9030 P(IT,1)=SQRT(DPT2)
9031 P(IT,3)=DPB(1)*(-1)**(JT+1)
9032 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
9033 IF(N.GE.IT+1) THEN
9034 DPB(1)=SQRT(DPB(1)**2+DPT2)
9035 DPB(2)=SQRT(DPB(1)**2+DMS)
9036 DPB(3)=P(IT+1,3)
9037 DPB(4)=SQRT(DPB(3)**2+DMS)
9038 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9039 & DPB(1))
9040 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
9041 THE=PYANGL(P(IT,3),P(IT,1))
9042 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
9043 ENDIF
9044
9045C...Reconstruct kinematics of branching: spacelike parton.
9046 DO 290 J=1,5
9047 K(N+1,J)=0
9048 P(N+1,J)=0D0
9049 V(N+1,J)=0D0
9050 290 CONTINUE
9051 K(N+1,1)=14
9052 K(N+1,2)=KFLB
9053 P(N+1,1)=P(IT,1)
9054 P(N+1,3)=P(IT,3)+P(IS(JT),3)
9055 P(N+1,4)=P(IT,4)+P(IS(JT),4)
9056 P(N+1,5)=-SQRT(DQ2(3))
9057
9058C...Define colour flow of branching.
9059 K(IS(JT),3)=N+1
9060 K(IT,3)=N+1
9061 IM1=N+1
9062 IM2=N+1
9063C...f -> f + gamma (Z, W).
9064 IF(IABS(K(IT,2)).GE.22) THEN
9065 K(IT,1)=1
9066 ID1=IS(JT)
9067 ID2=IS(JT)
9068C...f -> gamma (Z, W) + f.
9069 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
9070 ID1=IT
9071 ID2=IT
9072C...gamma -> q + qbar, g + g.
9073 ELSEIF(K(N+1,2).EQ.22) THEN
9074 ID1=IS(JT)
9075 ID2=IT
9076 IM1=ID2
9077 IM2=ID1
9078C...q -> q + g.
9079 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
9080 ID1=IT
9081 ID2=IS(JT)
9082C...q -> g + q.
9083 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
9084 ID1=IS(JT)
9085 ID2=IT
9086C...qbar -> qbar + g.
9087 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
9088 ID1=IS(JT)
9089 ID2=IT
9090C...qbar -> g + qbar.
9091 ELSEIF(K(N+1,2).LT.0) THEN
9092 ID1=IT
9093 ID2=IS(JT)
9094C...g -> g + g; g -> q + qbar.
9095 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
9096 ID1=IS(JT)
9097 ID2=IT
9098 ELSE
9099 ID1=IT
9100 ID2=IS(JT)
9101 ENDIF
9102 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
9103 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
9104 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
9105 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
9106 IF(ID1.NE.ID2) THEN
9107 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9108 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9109 ENDIF
9110 N=N+1
9111
9112C...Boost to new CM-frame.
9113 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
9114 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
9115 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
9116 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
9117 IR=N+(JT-1)*(IS(1)-N)
9118 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
9119 & 0D0,0D0,0D0)
9120 ENDIF
9121
9122C...Update kinematics variables.
9123 IS(JT)=N
9124 DQ2(JT)=Q2B
9125 IF(MSTP(62).GE.3) THE2(JT)=THE2T
9126 DSH=DSHZ
9127
9128C...Save quantities; loop back.
9129 Q2S(JT)=Q2B
9130 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
9131 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
9132 KFLS(JT+2)=KFLS(JT)
9133 KFLS(JT)=KFLA
9134 XS(JT)=XA
9135 ZS(JT)=Z
9136 DO 300 KFL=-25,25
9137 XFS(JT,KFL)=XFA(KFL)
9138 300 CONTINUE
9139 TEVCSV(JT)=TEVCB
9140 TEVESV(JT)=TEVEB
9141 ELSE
9142 MORE(JT)=0
9143 IF(JT.EQ.1) IPU1=N
9144 IF(JT.EQ.2) IPU2=N
9145 ENDIF
9146 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9147 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
9148 IF(MSTU(21).GE.1) N=NS
9149 IF(MSTU(21).GE.1) RETURN
9150 ENDIF
9151 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
9152
9153C...Boost hard scattering partons to frame of shower initiators.
9154 DO 310 J=1,3
9155 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9156 310 CONTINUE
9157 K(N+2,1)=1
9158 DO 320 J=1,5
9159 P(N+2,J)=P(NS+1,J)
9160 320 CONTINUE
9161 ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9162 IF(ROBOT.GE.0.999999D0) THEN
9163 ROBOT=1.00001D0*SQRT(ROBOT)
9164 ROBO(3)=ROBO(3)/ROBOT
9165 ROBO(4)=ROBO(4)/ROBOT
9166 ROBO(5)=ROBO(5)/ROBOT
9167 ENDIF
9168 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
9169 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
9170 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9171 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
9172 &ROBO(5))
9173
9174C...Store user information. Reset Lambda value.
9175 K(IPU1,3)=MINT(83)+3
9176 K(IPU2,3)=MINT(83)+4
9177 DO 330 JT=1,2
9178 MINT(12+JT)=KFLS(JT)
9179 VINT(140+JT)=XS(JT)
9180 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
9181 330 CONTINUE
9182 PARU(112)=ALAMS
9183
9184 RETURN
9185 END
9186
9187C*********************************************************************
9188
9189C...PYRESD
9190C...Allows resonances to decay (including parton showers for hadronic
9191C...channels).
9192
9193 SUBROUTINE PYRESD(IRES)
9194
9195C...Double precision and integer declarations.
9196 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9197 INTEGER PYK,PYCHGE,PYCOMP
9198C...Parameter statement to help give large particle numbers.
9199 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
9200C...Commonblocks.
9201 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9202 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9203 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9204 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
9205 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9206 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9207 COMMON/PYINT1/MINT(400),VINT(400)
9208 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9209 COMMON/PYINT4/MWID(500),WIDS(500,5)
9210 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
9211 &/PYINT1/,/PYINT2/,/PYINT4/
9212C...Local arrays and complex and character variables.
9213 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
9214 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
9215 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
9216 &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5)
9217 COMPLEX FGK,HA(6,6),HC(6,6)
9218 REAL TIR,UIR
9219 CHARACTER CODE*9,MASS*9
9220
9221C...The F, Xi and Xj functions of Gunion and Kunszt
9222C...(Phys. Rev. D33, 665, plus errata from the authors).
9223 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
9224 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
9225 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
9226 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
9227 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
9228 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
9229 &2D0*(D34/D56+D56/D34))
9230
9231C...Some general constants.
9232 XW=PARU(102)
9233 XWV=XW
9234 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
9235 XW1=1D0-XW
9236 SQMZ=PMAS(23,1)**2
9237 GMMZ=PMAS(23,1)*PMAS(23,2)
9238 SQMW=PMAS(24,1)**2
9239 GMMW=PMAS(24,1)*PMAS(24,2)
9240 SH=VINT(44)
9241
9242C...Reset original resonance configuration.
9243 DO 100 JT=1,8
9244 IREF(1,JT)=0
9245 100 CONTINUE
9246
9247C...Define initial one, two or three objects for subprocess.
9248 IF(IRES.EQ.0) THEN
9249 ISUB=MINT(1)
9250 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
9251 IREF(1,1)=MINT(84)+2+ISET(ISUB)
9252 IREF(1,4)=MINT(83)+6+ISET(ISUB)
9253 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
9254 IREF(1,1)=MINT(84)+1+ISET(ISUB)
9255 IREF(1,2)=MINT(84)+2+ISET(ISUB)
9256 IREF(1,4)=MINT(83)+5+ISET(ISUB)
9257 IREF(1,5)=MINT(83)+6+ISET(ISUB)
9258 ELSEIF(ISET(ISUB).EQ.5) THEN
9259 IREF(1,1)=MINT(84)+3
9260 IREF(1,2)=MINT(84)+4
9261 IREF(1,3)=MINT(84)+5
9262 IREF(1,4)=MINT(83)+7
9263 IREF(1,5)=MINT(83)+8
9264 IREF(1,6)=MINT(83)+9
9265 ENDIF
9266
9267C...Define original resonance for odd cases.
9268 ELSE
9269 ISUB=0
9270 IREF(1,1)=IRES
9271 ENDIF
9272
9273C...Check if initial resonance has been moved (in resonance + jet).
9274 DO 120 JT=1,3
9275 IF(IREF(1,JT).GT.0) THEN
9276 IF(K(IREF(1,JT),1).GT.10) THEN
9277 KFA=IABS(K(IREF(1,JT),2))
9278 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
9279 DO 110 I=IREF(1,JT)+1,N
9280 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
9281 & IREF(1,JT)=I
9282 110 CONTINUE
9283 ELSE
9284 KDA=MOD(K(IREF(1,JT),4),MSTU(4))
9285 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
9286 ENDIF
9287 ENDIF
9288 ENDIF
9289 120 CONTINUE
9290
9291C...Loop over decay history.
9292 NP=1
9293 IP=0
9294 130 IP=IP+1
9295 NINH=0
9296 JTMAX=2
9297 IF(IREF(IP,2).EQ.0) JTMAX=1
9298 IF(IREF(IP,3).NE.0) JTMAX=3
9299 IT4=0
9300 NSAV=N
9301
9302C...Start treatment of one, two or three resonances in parallel.
9303 140 N=NSAV
9304 DO 220 JT=1,JTMAX
9305 ID=IREF(IP,JT)
9306 KDCY(JT)=0
9307 KFL1(JT)=0
9308 KFL2(JT)=0
9309 KFL3(JT)=0
9310 KEQL(JT)=0
9311 NSD(JT)=ID
9312
9313C...Check whether particle can/is allowed to decay.
9314 IF(ID.EQ.0) GOTO 210
9315 KFA=IABS(K(ID,2))
9316 KCA=PYCOMP(KFA)
9317 IF(MWID(KCA).EQ.0) GOTO 210
9318 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210
9319 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
9320 & KFA.EQ.18) IT4=IT4+1
9321 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
9322 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
9323
9324C...Info for selection of decay channel: sign, pairings.
9325 IF(KCHG(KCA,3).EQ.0) THEN
9326 IPM=2
9327 ELSE
9328 IPM=(5-ISIGN(1,K(ID,2)))/2
9329 ENDIF
9330 KFB=0
9331 IF(JTMAX.EQ.2) THEN
9332 KFB=IABS(K(IREF(IP,3-JT),2))
9333 ELSEIF(JTMAX.EQ.3) THEN
9334 JT2=JT+1-3*(JT/3)
9335 KFB=IABS(K(IREF(IP,JT2),2))
9336 IF(KFB.NE.KFA) THEN
9337 JT2=JT+2-3*((JT+1)/3)
9338 KFB=IABS(K(IREF(IP,JT2),2))
9339 ENDIF
9340 ENDIF
9341
9342C...Select decay channel.
9343 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
9344 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
9345 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
9346 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
9347 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
9348 IF(WDTE0S.LE.0D0) GOTO 210
9349 RKFL=WDTE0S*PYR(0)
9350 IDL=0
9351 150 IDL=IDL+1
9352 IDC=IDL+MDCY(KCA,2)-1
9353 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
9354 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
9355 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 150
9356
9357C...Read out flavours and colour charges of decay channel chosen.
9358 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
9359 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
9360 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
9361 KFC1A=PYCOMP(IABS(KFL1(JT)))
9362 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
9363 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
9364 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
9365 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
9366 KFC2A=PYCOMP(IABS(KFL2(JT)))
9367 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
9368 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
9369 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
9370 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
9371 IF(KFL3(JT).NE.0) THEN
9372 KFC3A=PYCOMP(IABS(KFL3(JT)))
9373 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
9374 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
9375 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
9376 ENDIF
9377
9378C...Set/save further info on channel.
9379 KDCY(JT)=1
9380 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
9381 NSD(JT)=N
9382 HGZ(JT,1)=VINT(111)
9383 HGZ(JT,2)=VINT(112)
9384 HGZ(JT,3)=VINT(114)
9385
9386C...Select masses; to begin with assume resonances narrow.
9387 DO 170 I=1,3
9388 P(N+I,5)=0D0
9389 PMMN(I)=0D0
9390 IF(I.EQ.1) THEN
9391 KFLW=IABS(KFL1(JT))
9392 KCW=KFC1A
9393 ELSEIF(I.EQ.2) THEN
9394 KFLW=IABS(KFL2(JT))
9395 KCW=KFC2A
9396 ELSEIF(I.EQ.3) THEN
9397 IF(KFL3(JT).EQ.0) GOTO 170
9398 KFLW=IABS(KFL3(JT))
9399 KCW=KFC3A
9400 ENDIF
9401 P(N+I,5)=PMAS(KCW,1)
9402CMRENNA++
9403C...This prevents SUSY/t particles from becoming too light.
9404 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9405 PMMN(I)=PMAS(KCW,1)
9406 DO 160 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9407 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9408 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9409 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9410 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9411 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9412 PMMN(I)=MIN(PMMN(I),PMSUM)
9413 ENDIF
9414 160 CONTINUE
9415CMRENNA--
9416 ELSEIF(KFLW.EQ.6) THEN
9417 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9418 ENDIF
9419 170 CONTINUE
9420
9421C...Check which two out of three are widest.
9422 IWID1=1
9423 IWID2=2
9424 PWID1=PMAS(KFC1A,2)
9425 PWID2=PMAS(KFC2A,2)
9426 KFLW1=IABS(KFL1(JT))
9427 KFLW2=IABS(KFL2(JT))
9428 IF(KFL3(JT).NE.0) THEN
9429 PWID3=PMAS(KFC3A,2)
9430 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
9431 IWID1=3
9432 PWID1=PWID3
9433 KFLW1=IABS(KFL3(JT))
9434 ELSEIF(PWID3.GT.PWID2) THEN
9435 IWID2=3
9436 PWID2=PWID3
9437 KFLW2=IABS(KFL3(JT))
9438 ENDIF
9439 ENDIF
9440
9441C...If all narrow then only check that masses consistent.
9442 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
9443 & PWID2.LT.PARP(41))) THEN
9444CMRENNA++
9445C....Handle near degeneracy cases.
9446 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
9447 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
9448 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
9449 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
9450 ENDIF
9451 ENDIF
9452CMRENNA--
9453 IF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
9454 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
9455 MINT(51)=1
9456 RETURN
9457 ENDIF
9458
9459C...For three wide resonances select narrower of three
9460C...according to BW decoupled from rest.
9461 ELSE
9462 PMTOT=P(ID,5)
9463 IF(KFL3(JT).NE.0) THEN
9464 IWID3=6-IWID1-IWID2
9465 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
9466 & KFLW1-KFLW2
9467 LOOP=0
9468 180 LOOP=LOOP+1
9469 P(N+IWID3,5)=PYMASS(KFLW3)
9470 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180
9471 PMTOT=PMTOT-P(N+IWID3,5)
9472 ENDIF
9473C...Select other two correlated within remaining phase space.
9474 IF(IP.EQ.1) THEN
9475 CKIN45=CKIN(45)
9476 CKIN47=CKIN(47)
9477 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
9478 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
9479 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9480 & P(N+IWID2,5))
9481 CKIN(45)=CKIN45
9482 CKIN(47)=CKIN47
9483 ELSE
9484 CKIN(49)=PMMN(IWID1)
9485 CKIN(50)=PMMN(IWID2)
9486 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9487 & P(N+IWID2,5))
9488 CKIN(49)=0D0
9489 CKIN(50)=0D0
9490 ENDIF
9491 IF(MINT(51).EQ.1) RETURN
9492 ENDIF
9493
9494C...Begin fill decay products, with colour flow for coloured objects.
9495 MSTU10=MSTU(10)
9496 MSTU(10)=1
9497 MSTU(19)=1
9498
9499CMRENNA++
9500C...1) Three-body decays of SUSY particles (plus special case top).
9501 IF(KFL3(JT).NE.0) THEN
9502 DO 200 I=N+1,N+3
9503 DO 190 J=1,5
9504 K(I,J)=0
9505 V(I,J)=0D0
9506 190 CONTINUE
9507 200 CONTINUE
9508 XM(1)=P(N+1,5)
9509 XM(2)=P(N+2,5)
9510 XM(3)=P(N+3,5)
9511 XM(5)=P(ID,5)
9512 CALL PYTBDY(XM)
9513 K(N+1,1)=1
9514 K(N+1,2)=KFL1(JT)
9515 K(N+2,1)=1
9516 K(N+2,2)=KFL2(JT)
9517 K(N+3,1)=1
9518 K(N+3,2)=KFL3(JT)
9519
9520C...Set colour flow for t -> W + b + Z.
9521 IF(KFA.EQ.6) THEN
9522 K(N+2,1)=3
9523 ISID=4
9524 IF(KCQM(JT).EQ.-1) ISID=5
9525 IDAU=N+2
9526 K(ID,ISID)=K(ID,ISID)+IDAU
9527 K(IDAU,ISID)=MSTU(5)*ID
9528
9529C...Set colour flow in three-body decays - programmed as special cases.
9530 ELSEIF(KFC2A.LE.6) THEN
9531 K(N+2,1)=3
9532 K(N+3,1)=3
9533 ISID=4
9534 IF(KFL2(JT).LT.0) ISID=5
9535 K(N+2,ISID)=MSTU(5)*(N+3)
9536 K(N+3,9-ISID)=MSTU(5)*(N+2)
9537 ENDIF
9538 IF(KFL1(JT).EQ.KSUSY1+21) THEN
9539 K(N+1,1)=3
9540 K(N+2,1)=3
9541 K(N+3,1)=3
9542 ISID=4
9543 IF(KFL2(JT).LT.0) ISID=5
9544 K(N+1,ISID)=MSTU(5)*(N+2)
9545 K(N+1,9-ISID)=MSTU(5)*(N+3)
9546 K(N+2,ISID)=MSTU(5)*(N+1)
9547 K(N+3,9-ISID)=MSTU(5)*(N+1)
9548 ENDIF
9549 IF(KFA.EQ.KSUSY1+21) THEN
9550 K(N+2,1)=3
9551 K(N+3,1)=3
9552 ISID=4
9553 IF(KFL2(JT).LT.0) ISID=5
9554 K(ID,ISID)=K(ID,ISID)+(N+2)
9555 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
9556 K(N+2,ISID)=MSTU(5)*ID
9557 K(N+3,9-ISID)=MSTU(5)*ID
9558 ENDIF
9559 N=N+3
9560CMRENNA--
9561
9562C...2) Everything else two-body decay.
9563 ELSE
9564 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
9565C...First set colour flow as if mother colour singlet.
9566 IF(KCQ1(JT).NE.0) THEN
9567 K(N-1,1)=3
9568 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
9569 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
9570 ENDIF
9571 IF(KCQ2(JT).NE.0) THEN
9572 K(N,1)=3
9573 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
9574 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
9575 ENDIF
9576C...Then redirect colour flow if mother (anti)triplet.
9577 IF(KCQM(JT).EQ.0) THEN
9578 ELSEIF(KCQM(JT).NE.2) THEN
9579 ISID=4
9580 IF(KCQM(JT).EQ.-1) ISID=5
9581 IDAU=N-1
9582 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
9583 K(ID,ISID)=K(ID,ISID)+IDAU
9584 K(IDAU,ISID)=MSTU(5)*ID
9585C...Then redirect colour flow if mother octet.
9586 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
9587 IDAU=N-1
9588 IF(KCQ1(JT).EQ.0) IDAU=N
9589 K(ID,4)=K(ID,4)+IDAU
9590 K(ID,5)=K(ID,5)+IDAU
9591 K(IDAU,4)=MSTU(5)*ID
9592 K(IDAU,5)=MSTU(5)*ID
9593 ELSE
9594 ISID=4
9595 IF(KCQ1(JT).EQ.-1) ISID=5
9596 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
9597 K(ID,ISID)=K(ID,ISID)+(N-1)
9598 K(ID,9-ISID)=K(ID,9-ISID)+N
9599 K(N-1,ISID)=MSTU(5)*ID
9600 K(N,9-ISID)=MSTU(5)*ID
9601 ENDIF
9602 ENDIF
9603
9604C...End loop over resonances for daughter flavour and mass selection.
9605 MSTU(10)=MSTU10
9606 210 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
9607 & NINH=NINH+1
9608 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
9609 WRITE(CODE,'(I9)') K(ID,2)
9610 WRITE(MASS,'(F9.3)') P(ID,5)
9611 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
9612 & CODE//' with mass'//MASS)
9613 MINT(51)=1
9614 RETURN
9615 ENDIF
9616 220 CONTINUE
9617
9618C...Check for allowed combinations. Skip if no decays.
9619 IF(JTMAX.EQ.1) THEN
9620 IF(KDCY(1).EQ.0) GOTO 560
9621 ELSEIF(JTMAX.EQ.2) THEN
9622 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560
9623 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9624 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9625 ELSEIF(JTMAX.EQ.3) THEN
9626 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560
9627 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9628 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9629 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9630 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9631 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9632 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9633 ENDIF
9634
9635C...Special case: matrix element option for Z0 decay to quarks.
9636 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
9637 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
9638
9639C...Check consistency of MSTJ options set.
9640 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9641 CALL PYERRM(6,
9642 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
9643 MSTJ(110)=1
9644 ENDIF
9645 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9646 CALL PYERRM(6,
9647 & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
9648 MSTJ(111)=0
9649 ENDIF
9650
9651C...Select alpha_strong behaviour.
9652 MST111=MSTU(111)
9653 PAR112=PARU(112)
9654 MSTU(111)=MSTJ(108)
9655 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9656 & MSTU(111)=1
9657 PARU(112)=PARJ(121)
9658 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9659
9660C...Find axial fraction in total cross section for scalar gluon model.
9661 PARJ(171)=0D0
9662 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
9663 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
9664 POLL=1D0-PARJ(131)*PARJ(132)
9665 SFF=1D0/(16D0*XW*XW1)
9666 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
9667 & (PARJ(123)*PARJ(124))**2)
9668 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
9669 VE=4D0*XW-1D0
9670 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9671 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
9672 & (PARJ(132)-PARJ(131)))
9673 KFLC=IABS(KFL1(1))
9674 PMQ=PYMASS(KFLC)
9675 QF=KCHG(KFLC,1)/3D0
9676 VQ=1D0
9677 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
9678 & 1D0-(2D0*PMQ/P(ID,5))**2))
9679 VF=SIGN(1D0,QF)-4D0*QF*XW
9680 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
9681 & VF**2*HF1W)+VQ**3*HF1W
9682 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
9683 ENDIF
9684
9685C...Choice of jet configuration.
9686 CALL PYXJET(P(ID,5),NJET,CUT)
9687 KFLC=IABS(KFL1(1))
9688 KFLN=21
9689 IF(NJET.EQ.4) THEN
9690 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
9691 ELSEIF(NJET.EQ.3) THEN
9692 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
9693 ELSE
9694 MSTJ(120)=1
9695 ENDIF
9696
9697C...Fill jet configuration; return if incorrect kinematics.
9698 NC=N-2
9699 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
9700 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
9701 ELSEIF(NJET.EQ.2) THEN
9702 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
9703 ELSEIF(NJET.EQ.3) THEN
9704 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
9705 ELSEIF(KFLN.EQ.21) THEN
9706 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9707 & X12,X14)
9708 ELSE
9709 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9710 & X12,X14)
9711 ENDIF
9712 IF(MSTU(24).NE.0) THEN
9713 MINT(51)=1
9714 MSTU(111)=MST111
9715 PARU(112)=PAR112
9716 RETURN
9717 ENDIF
9718
9719C...Angular orientation according to matrix element.
9720 IF(MSTJ(106).EQ.1) THEN
9721 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI)
9722 IF(MINT(11).LT.0) THE=PARU(1)-THE
9723 CTHE(1)=COS(THE)
9724 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
9725 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
9726 ENDIF
9727
9728C...Boost partons to Z0 rest frame.
9729 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
9730 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9731
9732C...Mark decayed resonance and add documentation lines,
9733 K(ID,1)=K(ID,1)+10
9734 IDOC=MINT(83)+MINT(4)
9735 DO 240 I=NC+1,N
9736 I1=MINT(83)+MINT(4)+1
9737 K(I,3)=I1
9738 IF(MSTP(128).GE.1) K(I,3)=ID
9739 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
9740 MINT(4)=MINT(4)+1
9741 K(I1,1)=21
9742 K(I1,2)=K(I,2)
9743 K(I1,3)=IREF(IP,4)
9744 DO 230 J=1,5
9745 P(I1,J)=P(I,J)
9746 230 CONTINUE
9747 ENDIF
9748 240 CONTINUE
9749
9750C...Generate parton shower.
9751 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
9752
9753C... End special case for Z0: skip ahead.
9754 MSTU(111)=MST111
9755 PARU(112)=PAR112
9756 GOTO 550
9757 ENDIF
9758
9759C...Order incoming partons and outgoing resonances.
9760 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9761 ILIN(1)=MINT(84)+1
9762 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
9763 IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
9764 ILIN(2)=2*MINT(84)+3-ILIN(1)
9765 IMIN=1
9766 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
9767 & .EQ.36) IMIN=3
9768 IMAX=2
9769 IORD=1
9770 IF(K(IREF(IP,1),2).EQ.23) IORD=2
9771 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
9772 IAKIPD=IABS(K(IREF(IP,IORD),2))
9773 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
9774 IF(KDCY(IORD).EQ.0) IORD=3-IORD
9775
9776C...Order decay products of resonances.
9777 DO 250 JT=IORD,3-IORD,3-2*IORD
9778 IF(KDCY(JT).EQ.0) THEN
9779 ILIN(IMAX+1)=NSD(JT)
9780 IMAX=IMAX+1
9781 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
9782 ILIN(IMAX+1)=N+2*JT-1
9783 ILIN(IMAX+2)=N+2*JT
9784 IMAX=IMAX+2
9785 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9786 K(N+2*JT,2)=K(NSD(JT)+2,2)
9787 ELSE
9788 ILIN(IMAX+1)=N+2*JT
9789 ILIN(IMAX+2)=N+2*JT-1
9790 IMAX=IMAX+2
9791 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9792 K(N+2*JT,2)=K(NSD(JT)+2,2)
9793 ENDIF
9794 250 CONTINUE
9795
9796C...Find charge, isospin, left- and righthanded couplings.
9797 DO 270 I=IMIN,IMAX
9798 DO 260 J=1,4
9799 COUP(I,J)=0D0
9800 260 CONTINUE
9801 KFA=IABS(K(ILIN(I),2))
9802 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270
9803 COUP(I,1)=KCHG(KFA,1)/3D0
9804 COUP(I,2)=(-1)**MOD(KFA,2)
9805 COUP(I,4)=-2D0*COUP(I,1)*XWV
9806 COUP(I,3)=COUP(I,2)+COUP(I,4)
9807 270 CONTINUE
9808
9809C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
9810 IF(ISUB.EQ.22) THEN
9811 DO 300 I=3,5,2
9812 I1=IORD
9813 IF(I.EQ.5) I1=3-IORD
9814 DO 290 J1=1,2
9815 DO 280 J2=1,2
9816 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
9817 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
9818 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
9819 & COUP(I,J2+2)**2
9820 280 CONTINUE
9821 290 CONTINUE
9822 300 CONTINUE
9823 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
9824 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
9825 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
9826 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
9827 IF(COWT12.LT.PYR(0)*COMX12) GOTO 140
9828 ENDIF
9829 ENDIF
9830
9831C...Select angular orientation type - Z'/W' only.
9832 MZPWP=0
9833 IF(ISUB.EQ.141) THEN
9834 IF(PYR(0).LT.PARU(130)) MZPWP=1
9835 IF(IP.EQ.2) THEN
9836 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
9837 IAKIR=IABS(K(IREF(2,2),2))
9838 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9839 ENDIF
9840 IF(IP.GE.3) MZPWP=2
9841 ELSEIF(ISUB.EQ.142) THEN
9842 IF(PYR(0).LT.PARU(136)) MZPWP=1
9843 IF(IP.EQ.2) THEN
9844 IAKIR=IABS(K(IREF(2,2),2))
9845 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9846 ENDIF
9847 IF(IP.GE.3) MZPWP=2
9848 ENDIF
9849
9850C...Select random angles (begin of weighting procedure).
9851 310 DO 320 JT=1,JTMAX
9852 IF(KDCY(JT).EQ.0) GOTO 320
9853 IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
9854 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
9855 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
9856 PHI(JT)=VINT(24)
9857 ELSE
9858 CTHE(JT)=2D0*PYR(0)-1D0
9859 PHI(JT)=PARU(2)*PYR(0)
9860 ENDIF
9861 320 CONTINUE
9862
9863 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9864C...Construct massless four-vectors.
9865 DO 340 I=N+1,N+4
9866 K(I,1)=1
9867 DO 330 J=1,5
9868 P(I,J)=0D0
9869 V(I,J)=0D0
9870 330 CONTINUE
9871 340 CONTINUE
9872 DO 350 JT=1,JTMAX
9873 IF(KDCY(JT).EQ.0) GOTO 350
9874 ID=IREF(IP,JT)
9875 P(N+2*JT-1,3)=0.5D0*P(ID,5)
9876 P(N+2*JT-1,4)=0.5D0*P(ID,5)
9877 P(N+2*JT,3)=-0.5D0*P(ID,5)
9878 P(N+2*JT,4)=0.5D0*P(ID,5)
9879 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
9880 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9881 350 CONTINUE
9882
9883C...Store incoming and outgoing momenta, with random rotation to
9884C...avoid accidental zeroes in HA expressions.
9885 DO 370 I=1,IMAX
9886 K(N+4+I,1)=1
9887 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
9888 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
9889 P(N+4+I,5)=P(ILIN(I),5)
9890 DO 360 J=1,3
9891 P(N+4+I,J)=P(ILIN(I),J)
9892 360 CONTINUE
9893 370 CONTINUE
9894 380 THERR=ACOS(2D0*PYR(0)-1D0)
9895 PHIRR=PARU(2)*PYR(0)
9896 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
9897 DO 400 I=1,IMAX
9898 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380
9899 DO 390 J=1,4
9900 PK(I,J)=P(N+4+I,J)
9901 390 CONTINUE
9902 400 CONTINUE
9903
9904C...Calculate internal products.
9905 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
9906 & ISUB.EQ.142) THEN
9907 DO 420 I1=IMIN,IMAX-1
9908 DO 410 I2=I1+1,IMAX
9909 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
9910 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
9911 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
9912 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
9913 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
9914 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
9915 HC(I1,I2)=CONJG(HA(I1,I2))
9916 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
9917 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
9918 HA(I2,I1)=-HA(I1,I2)
9919 HC(I2,I1)=-HC(I1,I2)
9920 410 CONTINUE
9921 420 CONTINUE
9922 ENDIF
9923 DO 440 I=1,2
9924 DO 430 J=1,4
9925 PK(I,J)=-PK(I,J)
9926 430 CONTINUE
9927 440 CONTINUE
9928 DO 460 I1=IMIN,IMAX-1
9929 DO 450 I2=I1+1,IMAX
9930 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
9931 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
9932 PKK(I2,I1)=PKK(I1,I2)
9933 450 CONTINUE
9934 460 CONTINUE
9935 ENDIF
9936
9937 KFAGM=IABS(IREF(IP,7))
9938 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
9939C...Isotropic decay selected by user.
9940 WT=1D0
9941 WTMAX=1D0
9942
9943 ELSEIF(JTMAX.EQ.3) THEN
9944C...Isotropic decay when three mother particles.
9945 WT=1D0
9946 WTMAX=1D0
9947
9948 ELSEIF(IT4.GE.1) THEN
9949C... Isotropic decay t -> b + W etc for 4th generation q and l.
9950 WT=1D0
9951 WTMAX=1D0
9952
9953 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
9954 & IREF(IP,7).EQ.36) THEN
9955C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
9956 IF(IP.EQ.1) WTMAX=SH**2
9957 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
9958 KFA=IABS(K(IREF(IP,1),2))
9959 IF(KFA.EQ.23) THEN
9960 KFLF1A=IABS(KFL1(1))
9961 EF1=KCHG(KFLF1A,1)/3D0
9962 AF1=SIGN(1D0,EF1+0.1D0)
9963 VF1=AF1-4D0*EF1*XWV
9964 KFLF2A=IABS(KFL1(2))
9965 EF2=KCHG(KFLF2A,1)/3D0
9966 AF2=SIGN(1D0,EF2+0.1D0)
9967 VF2=AF2-4D0*EF2*XWV
9968 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
9969 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
9970 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
9971 ELSEIF(KFA.EQ.24) THEN
9972 WT=16D0*PKK(3,5)*PKK(4,6)
9973 ELSE
9974 WT=WTMAX
9975 ENDIF
9976
9977 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
9978 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
9979 & THEN
9980C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
9981 I1=IREF(IP,8)
9982 IF(MOD(KFAGM,2).EQ.0) THEN
9983 I2=N+1
9984 I3=N+2
9985 ELSE
9986 I2=N+2
9987 I3=N+1
9988 ENDIF
9989 I4=IREF(IP,2)
9990 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
9991 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
9992 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
9993 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
9994
9995 ELSEIF(ISUB.EQ.1) THEN
9996C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
9997 EI=KCHG(IABS(MINT(15)),1)/3D0
9998 AI=SIGN(1D0,EI+0.1D0)
9999 VI=AI-4D0*EI*XWV
10000 EF=KCHG(IABS(KFL1(1)),1)/3D0
10001 AF=SIGN(1D0,EF+0.1D0)
10002 VF=AF-4D0*EF*XWV
10003 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
10004 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10005 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
10006 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10007 & (VI**2+AI**2)*VINT(114)*VF**2)
10008 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
10009 & 4D0*VI*AI*VINT(114)*VF*AF)
10010 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
10011 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
10012 WTMAX=2D0*(WT1+ABS(WT3))
10013
10014 ELSEIF(ISUB.EQ.2) THEN
10015C...Angular weight for W+/- -> 2 quarks/leptons.
10016 WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
10017 WTMAX=4D0
10018
10019 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10020C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
10021C...-> gluon/gamma + 2 quarks/leptons.
10022 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10023 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10024 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10025 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10026 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10027 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10028 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10029 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10030 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10031 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10032 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10033 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10034 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
10035 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
10036 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10037 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10038
10039 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10040C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
10041C...-> gluon/gamma + 2 quarks/leptons.
10042 WT=PKK(1,3)**2+PKK(2,4)**2
10043 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10044
10045 ELSEIF(ISUB.EQ.22) THEN
10046C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
10047 S34=P(IREF(IP,IORD),5)**2
10048 S56=P(IREF(IP,3-IORD),5)**2
10049 TI=PKK(1,3)+PKK(1,4)+S34
10050 UI=PKK(1,5)+PKK(1,6)+S56
10051 TIR=REAL(TI)
10052 UIR=REAL(UI)
10053 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
10054 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
10055 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
10056 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
10057 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
10058 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
10059 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
10060 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
10061 WT=
10062 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
10063 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
10064 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
10065 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
10066 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
10067 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
10068 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
10069 & 1D0/UI**2))
10070
10071 ELSEIF(ISUB.EQ.23) THEN
10072C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
10073 D34=P(IREF(IP,IORD),5)**2
10074 D56=P(IREF(IP,3-IORD),5)**2
10075 DT=PKK(1,3)+PKK(1,4)+D34
10076 DU=PKK(1,5)+PKK(1,6)+D56
10077 FACBW=1D0/((SH-SQMW)**2+SQMW*PMAS(24,2)**2)
10078 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10079 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10080 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
10081 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
10082 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
10083 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
10084 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10085 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10086 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
10087
10088 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
10089C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
10090C...(or H0, or A0).
10091 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10092 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10093 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10094 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10095 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10096
10097 ELSEIF(ISUB.EQ.25) THEN
10098C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
10099 D34=P(IREF(IP,IORD),5)**2
10100 D56=P(IREF(IP,3-IORD),5)**2
10101 DT=PKK(1,3)+PKK(1,4)+D34
10102 DU=PKK(1,5)+PKK(1,6)+D56
10103 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
10104 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
10105 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
10106 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
10107 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
10108 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
10109 & REAL(CBWW)*FGK(1,2,5,6,3,4))
10110 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10111 WT=FGK135**2+(CCWW*FGK253)**2
10112 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
10113 & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10114
10115 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
10116C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
10117C...(or H0, or A0).
10118 WT=PKK(1,3)*PKK(2,4)
10119 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10120
10121 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
10122C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
10123C...-> f + 2 quarks/leptons.
10124 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10125 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10126 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10127 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10128 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10129 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10130 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10131 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10132 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10133 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10134 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10135 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10136 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
10137 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
10138 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
10139 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
10140 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10141 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10142
10143 ELSEIF(ISUB.EQ.31) THEN
10144C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
10145 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10146 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10147 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10148
10149 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
10150 & ISUB.EQ.77) THEN
10151C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
10152 WT=16D0*PKK(3,5)*PKK(4,6)
10153 WTMAX=SH**2
10154
10155 ELSEIF(ISUB.EQ.110) THEN
10156C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
10157 WT=1D0
10158 WTMAX=1D0
10159
10160 ELSEIF(ISUB.EQ.141) THEN
10161 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10162C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
10163C...Couplings of incoming flavour.
10164 KFAI=IABS(MINT(15))
10165 EI=KCHG(KFAI,1)/3D0
10166 AI=SIGN(1D0,EI+0.1D0)
10167 VI=AI-4D0*EI*XWV
10168 KFAIC=1
10169 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
10170 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
10171 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
10172 VPI=PARU(119+2*KFAIC)
10173 API=PARU(120+2*KFAIC)
10174C...Couplings of final flavour.
10175 KFAF=IABS(KFL1(1))
10176 EF=KCHG(KFAF,1)/3D0
10177 AF=SIGN(1D0,EF+0.1D0)
10178 VF=AF-4D0*EF*XWV
10179 KFAFC=1
10180 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
10181 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
10182 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
10183 VPF=PARU(119+2*KFAFC)
10184 APF=PARU(120+2*KFAFC)
10185C...Asymmetry and weight.
10186 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
10187 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
10188 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
10189 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10190 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
10191 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
10192 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
10193 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10194 WTMAX=2D0+ABS(ASYM)
10195 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
10196C...Angular weight for f + fbar -> Z' -> W+ + W-.
10197 RM1=P(NSD(1)+1,5)**2/SH
10198 RM2=P(NSD(1)+2,5)**2/SH
10199 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10200 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10201 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10202 & (RM2-RM1)**2)
10203 WT=CFLAT+CCOS2*CTHE(1)**2
10204 WTMAX=CFLAT+MAX(0D0,CCOS2)
10205 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
10206 & IABS(KFL1(1)).EQ.37)) THEN
10207C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
10208 WT=1D0-CTHE(1)**2
10209 WTMAX=1D0
10210 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10211C...Angular weight for f + fbar -> Z' -> Z0 + h0.
10212 RM1=P(NSD(1)+1,5)**2/SH
10213 RM2=P(NSD(1)+2,5)**2/SH
10214 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10215 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10216 WTMAX=1D0+FLAM2/(8D0*RM1)
10217 ELSEIF(MZPWP.EQ.0) THEN
10218C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10219C...(W:s like if intermediate Z).
10220 D34=P(IREF(IP,IORD),5)**2
10221 D56=P(IREF(IP,3-IORD),5)**2
10222 DT=PKK(1,3)+PKK(1,4)+D34
10223 DU=PKK(1,5)+PKK(1,6)+D56
10224 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10225 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10226 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
10227 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
10228 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10229 ELSEIF(MZPWP.EQ.1) THEN
10230C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10231C...(W:s approximately longitudinal, like if intermediate H).
10232 WT=16D0*PKK(3,5)*PKK(4,6)
10233 WTMAX=SH**2
10234 ELSE
10235C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
10236C...H0 + A0 -> 4 quarks/leptons.
10237 WT=1D0
10238 WTMAX=1D0
10239 ENDIF
10240
10241 ELSEIF(ISUB.EQ.142) THEN
10242 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10243C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
10244 KFAI=IABS(MINT(15))
10245 KFAIC=1
10246 IF(KFAI.GT.10) KFAIC=2
10247 VI=PARU(129+2*KFAIC)
10248 AI=PARU(130+2*KFAIC)
10249 KFAF=IABS(KFL1(1))
10250 KFAFC=1
10251 IF(KFAF.GT.10) KFAFC=2
10252 VF=PARU(129+2*KFAFC)
10253 AF=PARU(130+2*KFAFC)
10254 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
10255 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10256 WTMAX=2D0+ABS(ASYM)
10257 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
10258C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
10259 RM1=P(NSD(1)+1,5)**2/SH
10260 RM2=P(NSD(1)+2,5)**2/SH
10261 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10262 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10263 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10264 & (RM2-RM1)**2)
10265 WT=CFLAT+CCOS2*CTHE(1)**2
10266 WTMAX=CFLAT+MAX(0D0,CCOS2)
10267 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10268C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
10269 RM1=P(NSD(1)+1,5)**2/SH
10270 RM2=P(NSD(1)+2,5)**2/SH
10271 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10272 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10273 WTMAX=1D0+FLAM2/(8D0*RM1)
10274 ELSEIF(MZPWP.EQ.0) THEN
10275C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10276C...(W/Z like if intermediate W).
10277 D34=P(IREF(IP,IORD),5)**2
10278 D56=P(IREF(IP,3-IORD),5)**2
10279 DT=PKK(1,3)+PKK(1,4)+D34
10280 DU=PKK(1,5)+PKK(1,6)+D56
10281 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10282 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
10283 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10284 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
10285 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10286 ELSEIF(MZPWP.EQ.1) THEN
10287C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10288C...(W/Z approximately longitudinal, like if intermediate H).
10289 WT=16D0*PKK(3,5)*PKK(4,6)
10290 WTMAX=SH**2
10291 ELSE
10292C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
10293 WT=1D0
10294 WTMAX=1D0
10295 ENDIF
10296
10297 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
10298 & THEN
10299C...Isotropic decay of leptoquarks (assumed spin 0).
10300 WT=1D0
10301 WTMAX=1D0
10302
10303 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10304C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
10305 SIDE=1D0
10306 IF(MINT(16).EQ.21) SIDE=-1D0
10307 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
10308 WT=1D0+SIDE*CTHE(1)
10309 WTMAX=2D0
10310 ELSEIF(IP.EQ.1) THEN
10311 RM1=P(NSD(1)+1,5)**2/SH
10312 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10313 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10314 ELSE
10315C...W/Z decay assumed isotropic, since not known.
10316 WT=1D0
10317 WTMAX=1D0
10318 ENDIF
10319
10320 ELSEIF(ISUB.EQ.149) THEN
10321C...Isotropic decay of techni-eta.
10322 WT=1D0
10323 WTMAX=1D0
10324
10325 ELSEIF(ISUB.EQ.191) THEN
10326 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10327C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
10328C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
10329 WT=1D0-CTHE(1)**2
10330 WTMAX=1D0
10331 ELSEIF(IP.EQ.1) THEN
10332C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
10333 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10334 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
10335 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10336 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10337 KFAI=IABS(MINT(15))
10338 EI=KCHG(KFAI,1)/3D0
10339 AI=SIGN(1D0,EI+0.1D0)
10340 VI=AI-4D0*EI*XWV
10341 VALI=0.5D0*(VI+AI)
10342 VARI=0.5D0*(VI-AI)
10343 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
10344 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
10345 KFAF=IABS(KFL1(1))
10346 EF=KCHG(KFAF,1)/3D0
10347 AF=SIGN(1D0,EF+0.1D0)
10348 VF=AF-4D0*EF*XWV
10349 VALF=0.5D0*(VF+AF)
10350 VARF=0.5D0*(VF-AF)
10351 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
10352 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
10353 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
10354 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
10355 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
10356 WTMAX=4D0*MAX(ASAME,AFLIP)
10357 ELSE
10358C...Isotropic decay of W/pi_tech produced in rho_tech decay.
10359 WT=1D0
10360 WTMAX=1D0
10361 ENDIF
10362
10363 ELSEIF(ISUB.EQ.192) THEN
10364 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10365C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
10366C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
10367 WT=1D0-CTHE(1)**2
10368 WTMAX=1D0
10369 ELSEIF(IP.EQ.1) THEN
10370C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
10371 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10372 WT=(1D0+CTHESG)**2
10373 WTMAX=4D0
10374 ELSE
10375C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
10376 WT=1D0
10377 WTMAX=1D0
10378 ENDIF
10379
10380 ELSEIF(ISUB.EQ.193) THEN
10381 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10382C...Angular weight for f + fbar -> omega_tech0 ->
10383C...gamma pi_tech0 or Z0 pi_tech0.
10384 WT=1D0+CTHE(1)**2
10385 WTMAX=2D0
10386 ELSEIF(IP.EQ.1) THEN
10387C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
10388 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10389 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10390 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10391 KFAI=IABS(MINT(15))
10392 EI=KCHG(KFAI,1)/3D0
10393 AI=SIGN(1D0,EI+0.1D0)
10394 VI=AI-4D0*EI*XWV
10395 VALI=0.5D0*(VI+AI)
10396 VARI=0.5D0*(VI-AI)
10397 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
10398 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
10399 KFAF=IABS(KFL1(1))
10400 EF=KCHG(KFAF,1)/3D0
10401 AF=SIGN(1D0,EF+0.1D0)
10402 VF=AF-4D0*EF*XWV
10403 VALF=0.5D0*(VF+AF)
10404 VARF=0.5D0*(VF-AF)
10405 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
10406 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
10407 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
10408 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
10409 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
10410 WTMAX=4D0*MAX(BSAME,BFLIP)
10411 ELSE
10412C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
10413 WT=1D0
10414 WTMAX=1D0
10415 ENDIF
10416
10417C...Obtain correct angular distribution by rejection techniques.
10418 ELSE
10419 WT=1D0
10420 WTMAX=1D0
10421 ENDIF
10422 IF(WT.LT.PYR(0)*WTMAX) GOTO 310
10423
10424C...Construct massive four-vectors using angles chosen.
10425 470 DO 540 JT=1,JTMAX
10426 IF(KDCY(JT).EQ.0) GOTO 540
10427 ID=IREF(IP,JT)
10428 DO 480 J=1,5
10429 DPMO(J)=P(ID,J)
10430 480 CONTINUE
10431 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
10432CMRENNA++
10433 IF(KFL3(JT).EQ.0) THEN
10434 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10435 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10436 ELSE
10437 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
10438 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10439 ENDIF
10440CMRENNA--
10441
10442C...Mark decayed resonances; trace history.
10443 K(ID,1)=K(ID,1)+10
10444 KFA=IABS(K(ID,2))
10445 KCA=PYCOMP(KFA)
10446 IF(KCQM(JT).NE.0) THEN
10447C...Do not kill colour flow through coloured resonance!
10448 ELSE
10449 K(ID,4)=NSD(JT)+1
10450 K(ID,5)=NSD(JT)+2
10451 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
10452 ENDIF
10453
10454C...Add documentation lines.
10455 IF(ISUB.NE.0) THEN
10456 IDOC=MINT(83)+MINT(4)
10457CMRENNA+++
10458 IHI=NSD(JT)+2
10459 IF(KFL3(JT).NE.0) IHI=IHI+1
10460 DO 500 I=NSD(JT)+1,IHI
10461CMRENNA---
10462 I1=MINT(83)+MINT(4)+1
10463 K(I,3)=I1
10464 IF(MSTP(128).GE.1) K(I,3)=ID
10465 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
10466 MINT(4)=MINT(4)+1
10467 K(I1,1)=21
10468 K(I1,2)=K(I,2)
10469 K(I1,3)=IREF(IP,JT+3)
10470 DO 490 J=1,5
10471 P(I1,J)=P(I,J)
10472 490 CONTINUE
10473 ENDIF
10474 500 CONTINUE
10475 ELSE
10476 K(NSD(JT)+1,3)=ID
10477 K(NSD(JT)+2,3)=ID
10478 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
10479 ENDIF
10480
10481C...Do showering if any of the two/three products can shower.
10482 NSHBEF=N
10483 IF(MSTP(71).GE.1) THEN
10484 ISHOW1=0
10485 KFL1A=IABS(KFL1(JT))
10486 IF(KFL1A.LE.22) ISHOW1=1
10487 ISHOW2=0
10488 KFL2A=IABS(KFL2(JT))
10489 IF(KFL2A.LE.22) ISHOW2=1
10490 ISHOW3=0
10491 IF(KFL3(JT).NE.0) THEN
10492 KFL3A=IABS(KFL3(JT))
10493 IF(KFL3A.LE.22) ISHOW3=1
10494 ENDIF
10495 IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
10496 ELSEIF(KFL3(JT).EQ.0) THEN
10497 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
10498 ELSE
10499 NSD1=NSD(JT)+1
10500 NSD2=NSD(JT)+2
10501 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
10502 NSD1=NSD(JT)+3
10503 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
10504 NSD2=NSD(JT)+3
10505 ENDIF
10506 PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
10507 & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
10508 & (P(NSD1,3)+P(NSD2,3))**2))
10509 CALL PYSHOW(NSD1,NSD2,PMSHOW)
10510 ENDIF
10511 ENDIF
10512 NSHAFT=N
10513 IF(JT.EQ.1) NAFT1=N
10514
10515C...Check if decay products moved by shower.
10516 NSD1=NSD(JT)+1
10517 NSD2=NSD(JT)+2
10518 NSD3=NSD(JT)+3
10519 IF(NSHAFT.GT.NSHBEF) THEN
10520 IF(K(NSD1,1).GT.10) THEN
10521 DO 510 I=NSHBEF+1,NSHAFT
10522 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
10523 510 CONTINUE
10524 ENDIF
10525 IF(K(NSD2,1).GT.10) THEN
10526 DO 520 I=NSHBEF+1,NSHAFT
10527 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
10528 & I.NE.NSD1) NSD2=I
10529 520 CONTINUE
10530 ENDIF
10531 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
10532 DO 530 I=NSHBEF+1,NSHAFT
10533 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
10534 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
10535 530 CONTINUE
10536 ENDIF
10537 ENDIF
10538
10539C...Store decay products for further treatment.
10540 NP=NP+1
10541 IREF(NP,1)=NSD1
10542 IREF(NP,2)=NSD2
10543 IREF(NP,3)=0
10544 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
10545 IREF(NP,4)=IDOC+1
10546 IREF(NP,5)=IDOC+2
10547 IREF(NP,6)=0
10548 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
10549 IREF(NP,7)=K(IREF(IP,JT),2)
10550 IREF(NP,8)=IREF(IP,JT)
10551 540 CONTINUE
10552
10553C...Fill information for 2 -> 1 -> 2.
10554 550 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
10555 MINT(7)=MINT(83)+6+2*ISET(ISUB)
10556 MINT(8)=MINT(83)+7+2*ISET(ISUB)
10557 MINT(25)=KFL1(1)
10558 MINT(26)=KFL2(1)
10559 VINT(23)=CTHE(1)
10560 RM3=P(N-1,5)**2/SH
10561 RM4=P(N,5)**2/SH
10562 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
10563 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
10564 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
10565 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
10566 VINT(47)=SQRT(VINT(48))
10567 ENDIF
10568
10569C...Possibility of colour rearrangement in W+W- events.
10570 IF(ISUB.EQ.25.AND.MSTP(115).GE.1) THEN
10571 IAKF1=IABS(KFL1(1))
10572 IAKF2=IABS(KFL1(2))
10573 IAKF3=IABS(KFL2(1))
10574 IAKF4=IABS(KFL2(2))
10575 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
10576 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
10577 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
10578 ENDIF
10579
10580C...Loop back if needed.
10581 560 IF(IP.LT.NP) GOTO 130
10582
10583 RETURN
10584 END
10585
10586C*********************************************************************
10587
10588C...PYMULT
10589C...Initializes treatment of multiple interactions, selects kinematics
10590C...of hardest interaction if low-pT physics included in run, and
10591C...generates all non-hardest interactions.
10592
10593 SUBROUTINE PYMULT(MMUL)
10594
10595C...Double precision and integer declarations.
10596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10597 INTEGER PYK,PYCHGE,PYCOMP
10598C...Commonblocks.
10599 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10600 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10601 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10602 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10603 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10604 COMMON/PYINT1/MINT(400),VINT(400)
10605 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10606 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10607 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10608 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
10609 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10610 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
10611C...Local arrays and saved variables.
10612 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
10613 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
10614
10615C...Initialization of multiple interaction treatment.
10616 IF(MMUL.EQ.1) THEN
10617 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
10618 ISUB=96
10619 MINT(1)=96
10620 VINT(63)=0D0
10621 VINT(64)=0D0
10622 VINT(143)=1D0
10623 VINT(144)=1D0
10624
10625C...Loop over phase space points: xT2 choice in 20 bins.
10626 100 SIGSUM=0D0
10627 DO 120 IXT2=1,20
10628 NMUL(IXT2)=MSTP(83)
10629 SIGM(IXT2)=0D0
10630 DO 110 ITRY=1,MSTP(83)
10631 RSCA=0.05D0*((21-IXT2)-PYR(0))
10632 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
10633 XT2=MAX(0.01D0*VINT(149),XT2)
10634 VINT(25)=XT2
10635
10636C...Choose tau and y*. Calculate cos(theta-hat).
10637 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10638 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10639 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10640 ELSE
10641 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10642 ENDIF
10643 VINT(21)=TAU
10644 CALL PYKLIM(2)
10645 RYST=PYR(0)
10646 MYST=1
10647 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10648 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10649 CALL PYKMAP(2,MYST,PYR(0))
10650 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10651
10652C...Calculate differential cross-section.
10653 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10654 CALL PYSIGH(NCHN,SIGS)
10655 SIGM(IXT2)=SIGM(IXT2)+SIGS
10656 110 CONTINUE
10657 SIGSUM=SIGSUM+SIGM(IXT2)
10658 120 CONTINUE
10659 SIGSUM=SIGSUM/(20D0*MSTP(83))
10660
10661C...Reject result if sigma(parton-parton) is smaller than hadronic one.
10662 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
10663 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) PARP(82),SIGSUM
10664 PARP(82)=0.9D0*PARP(82)
10665 VINT(149)=4D0*PARP(82)**2/VINT(2)
10666 GOTO 100
10667 ENDIF
10668 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM
10669
10670C...Start iteration to find k factor.
10671 YKE=SIGSUM/SIGT(0,0,5)
10672 SO=0.5D0
10673 XI=0D0
10674 YI=0D0
10675 XF=0D0
10676 YF=0D0
10677 XK=0.5D0
10678 IIT=0
10679 130 IF(IIT.EQ.0) THEN
10680 XK=2D0*XK
10681 ELSEIF(IIT.EQ.1) THEN
10682 XK=0.5D0*XK
10683 ELSE
10684 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
10685 ENDIF
10686
10687C...Evaluate overlap integrals.
10688 IF(MSTP(82).EQ.2) THEN
10689 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
10690 SOP=SP/PARU(1)
10691 ELSE
10692 IF(MSTP(82).EQ.3) DELTAB=0.02D0
10693 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
10694 SP=0D0
10695 SOP=0D0
10696 B=-0.5D0*DELTAB
10697 140 B=B+DELTAB
10698 IF(MSTP(82).EQ.3) THEN
10699 OV=EXP(-B**2)/PARU(2)
10700 ELSE
10701 CQ2=PARP(84)**2
10702 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
10703 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
10704 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
10705 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
10706 ENDIF
10707 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
10708 SP=SP+PARU(2)*B*DELTAB*PACC
10709 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
10710 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
10711 ENDIF
10712 YK=PARU(1)*XK*SO/SP
10713
10714C...Continue iteration until convergence.
10715 IF(YK.LT.YKE) THEN
10716 XI=XK
10717 YI=YK
10718 IF(IIT.EQ.1) IIT=2
10719 ELSE
10720 XF=XK
10721 YF=YK
10722 IF(IIT.EQ.0) IIT=1
10723 ENDIF
10724 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
10725
10726C...Store some results for subsequent use.
10727 VINT(145)=SIGSUM
10728 VINT(146)=SOP/SO
10729 VINT(147)=SOP/SP
10730
10731C...Initialize iteration in xT2 for hardest interaction.
10732 ELSEIF(MMUL.EQ.2) THEN
10733 IF(MSTP(82).LE.0) THEN
10734 ELSEIF(MSTP(82).EQ.1) THEN
10735 XT2=1D0
10736 XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149))
10737 ELSEIF(MSTP(82).EQ.2) THEN
10738 XT2=1D0
10739 XT2FAC=VINT(146)*XSEC(96,1)/SIGT(0,0,5)*VINT(149)*
10740 & (1D0+VINT(149))
10741 ELSE
10742 XC2=4D0*CKIN(3)**2/VINT(2)
10743 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
10744 ENDIF
10745
10746 ELSEIF(MMUL.EQ.3) THEN
10747C...Low-pT or multiple interactions (first semihard interaction):
10748C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
10749C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
10750 ISUB=MINT(1)
10751 IF(MSTP(82).LE.0) THEN
10752 XT2=0D0
10753 ELSEIF(MSTP(82).EQ.1) THEN
10754 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10755 ELSEIF(MSTP(82).EQ.2) THEN
10756 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
10757 & VINT(149)))).GT.PYR(0)) XT2=1D0
10758 IF(XT2.GE.1D0) THEN
10759 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
10760 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
10761 & VINT(149)
10762 ELSE
10763 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
10764 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
10765 & VINT(149)
10766 ENDIF
10767 XT2=MAX(0.01D0*VINT(149),XT2)
10768 ELSE
10769 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
10770 & PYR(0)*(1D0-XC2))-VINT(149)
10771 XT2=MAX(0.01D0*VINT(149),XT2)
10772 ENDIF
10773 VINT(25)=XT2
10774
10775C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
10776 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
10777 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
10778 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
10779 ISUB=95
10780 MINT(1)=ISUB
10781 VINT(21)=0.01D0*VINT(149)
10782 VINT(22)=0D0
10783 VINT(23)=0D0
10784 VINT(25)=0.01D0*VINT(149)
10785
10786 ELSE
10787C...Multiple interactions (first semihard interaction).
10788C...Choose tau and y*. Calculate cos(theta-hat).
10789 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10790 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10791 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10792 ELSE
10793 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10794 ENDIF
10795 VINT(21)=TAU
10796 CALL PYKLIM(2)
10797 RYST=PYR(0)
10798 MYST=1
10799 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10800 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10801 CALL PYKMAP(2,MYST,PYR(0))
10802 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10803 ENDIF
10804 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
10805
10806C...Store results of cross-section calculation.
10807 ELSEIF(MMUL.EQ.4) THEN
10808 ISUB=MINT(1)
10809 XTS=VINT(25)
10810 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
10811 IF(ISET(ISUB).EQ.2)
10812 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10813 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
10814 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
10815 & (XTS+VINT(149))))
10816 IRBIN=INT(1D0+20D0*RBIN)
10817 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
10818 NMUL(IRBIN)=NMUL(IRBIN)+1
10819 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
10820 ENDIF
10821
10822C...Choose impact parameter.
10823 ELSEIF(MMUL.EQ.5) THEN
10824 IF(MSTP(82).EQ.3) THEN
10825 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
10826 ELSE
10827 RTYPE=PYR(0)
10828 CQ2=PARP(84)**2
10829 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
10830 B2=-LOG(PYR(0))
10831 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
10832 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
10833 ELSE
10834 B2=-CQ2*LOG(PYR(0))
10835 ENDIF
10836 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
10837 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
10838 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
10839 ENDIF
10840
10841C...Multiple interactions (variable impact parameter) : reject with
10842C...probability exp(-overlap*cross-section above pT/normalization).
10843 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
10844 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
10845 DO 150 IBIN=IRBIN+1,20
10846 RNCOR=RNCOR+NMUL(IBIN)
10847 SIGCOR=SIGCOR+SIGM(IBIN)
10848 150 CONTINUE
10849 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
10850 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
10851 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
10852 & SIGABV/SIGT(0,0,5)))
10853
10854C...Generate additional multiple semihard interactions.
10855 ELSEIF(MMUL.EQ.6) THEN
10856 ISUBSV=MINT(1)
10857 DO 160 J=11,80
10858 VINTSV(J)=VINT(J)
10859 160 CONTINUE
10860 ISUB=96
10861 MINT(1)=96
10862
10863C...Reconstruct strings in hard scattering.
10864 NMAX=MINT(84)+4
10865 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
10866 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
10867 NSTR=0
10868 DO 180 I=MINT(84)+1,NMAX
10869 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
10870 IF(KCS.EQ.0) GOTO 180
10871
10872 DO 170 J=1,4
10873 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
10874 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
10875 IF(J.LE.2) THEN
10876 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
10877 ELSE
10878 IST=MOD(K(I,J+1),MSTU(5))
10879 ENDIF
10880 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
10881 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
10882 NSTR=NSTR+1
10883 IF(J.EQ.1.OR.J.EQ.4) THEN
10884 KSTR(NSTR,1)=I
10885 KSTR(NSTR,2)=IST
10886 ELSE
10887 KSTR(NSTR,1)=IST
10888 KSTR(NSTR,2)=I
10889 ENDIF
10890 170 CONTINUE
10891 180 CONTINUE
10892
10893C...Set up starting values for iteration in xT2.
10894 XT2=VINT(25)
10895 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
10896 IF(ISET(ISUBSV).EQ.2)
10897 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10898 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
10899 IF(MSTP(82).LE.1) THEN
10900 XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5))
10901 ELSE
10902 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/SIGT(0,0,5)*
10903 & VINT(149)*(1D0+VINT(149))
10904 ENDIF
10905 VINT(63)=0D0
10906 VINT(64)=0D0
10907 VINT(143)=1D0-VINT(141)
10908 VINT(144)=1D0-VINT(142)
10909
10910C...Iterate downwards in xT2.
10911 190 IF(MSTP(82).LE.1) THEN
10912 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10913 IF(XT2.LT.VINT(149)) GOTO 240
10914 ELSE
10915 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
10916 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
10917 & LOG(PYR(0)))-VINT(149)
10918 IF(XT2.LE.0D0) GOTO 240
10919 XT2=MAX(0.01D0*VINT(149),XT2)
10920 ENDIF
10921 VINT(25)=XT2
10922
10923C...Choose tau and y*. Calculate cos(theta-hat).
10924 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10925 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10926 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10927 ELSE
10928 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10929 ENDIF
10930 VINT(21)=TAU
10931 CALL PYKLIM(2)
10932 RYST=PYR(0)
10933 MYST=1
10934 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10935 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10936 CALL PYKMAP(2,MYST,PYR(0))
10937 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10938
10939C...Check that x not used up. Accept or reject kinematical variables.
10940 X1M=SQRT(TAU)*EXP(VINT(22))
10941 X2M=SQRT(TAU)*EXP(-VINT(22))
10942 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
10943 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10944 CALL PYSIGH(NCHN,SIGS)
10945 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
10946
10947C...Reset K, P and V vectors. Select some variables.
10948 DO 210 I=N+1,N+2
10949 DO 200 J=1,5
10950 K(I,J)=0
10951 P(I,J)=0D0
10952 V(I,J)=0D0
10953 200 CONTINUE
10954 210 CONTINUE
10955 RFLAV=PYR(0)
10956 PT=0.5D0*VINT(1)*SQRT(XT2)
10957 PHI=PARU(2)*PYR(0)
10958 CTH=VINT(23)
10959
10960C...Add first parton to event record.
10961 K(N+1,1)=3
10962 K(N+1,2)=21
10963 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
10964 & 1+INT((2D0+PARJ(2))*PYR(0))
10965 P(N+1,1)=PT*COS(PHI)
10966 P(N+1,2)=PT*SIN(PHI)
10967 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
10968 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
10969 P(N+1,5)=0D0
10970
10971C...Add second parton to event record.
10972 K(N+2,1)=3
10973 K(N+2,2)=21
10974 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
10975 P(N+2,1)=-P(N+1,1)
10976 P(N+2,2)=-P(N+1,2)
10977 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
10978 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
10979 P(N+2,5)=0D0
10980
10981 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
10982C....Choose relevant string pieces to place gluons on.
10983 DO 230 I=N+1,N+2
10984 DMIN=1D8
10985 DO 220 ISTR=1,NSTR
10986 I1=KSTR(ISTR,1)
10987 I2=KSTR(ISTR,2)
10988 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
10989 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
10990 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
10991 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
10992 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
10993 DMIN=DIST
10994 IST1=I1
10995 IST2=I2
10996 ISTM=ISTR
10997 ENDIF
10998 220 CONTINUE
10999
11000C....Colour flow adjustments, new string pieces.
11001 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
11002 & MOD(K(IST1,4),MSTU(5))
11003 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
11004 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
11005 K(I,5)=MSTU(5)*IST1
11006 K(I,4)=MSTU(5)*IST2
11007 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
11008 & MOD(K(IST2,5),MSTU(5))
11009 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
11010 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
11011 KSTR(ISTM,2)=I
11012 KSTR(NSTR+1,1)=I
11013 KSTR(NSTR+1,2)=IST2
11014 NSTR=NSTR+1
11015 230 CONTINUE
11016
11017C...String drawing and colour flow for gluon loop.
11018 ELSEIF(K(N+1,2).EQ.21) THEN
11019 K(N+1,4)=MSTU(5)*(N+2)
11020 K(N+1,5)=MSTU(5)*(N+2)
11021 K(N+2,4)=MSTU(5)*(N+1)
11022 K(N+2,5)=MSTU(5)*(N+1)
11023 KSTR(NSTR+1,1)=N+1
11024 KSTR(NSTR+1,2)=N+2
11025 KSTR(NSTR+2,1)=N+2
11026 KSTR(NSTR+2,2)=N+1
11027 NSTR=NSTR+2
11028
11029C...String drawing and colour flow for qqbar pair.
11030 ELSE
11031 K(N+1,4)=MSTU(5)*(N+2)
11032 K(N+2,5)=MSTU(5)*(N+1)
11033 KSTR(NSTR+1,1)=N+1
11034 KSTR(NSTR+1,2)=N+2
11035 NSTR=NSTR+1
11036 ENDIF
11037
11038C...Update remaining energy; iterate.
11039 N=N+2
11040 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11041 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
11042 IF(MSTU(21).GE.1) RETURN
11043 ENDIF
11044 MINT(31)=MINT(31)+1
11045 VINT(151)=VINT(151)+VINT(41)
11046 VINT(152)=VINT(152)+VINT(42)
11047 VINT(143)=VINT(143)-VINT(41)
11048 VINT(144)=VINT(144)-VINT(42)
11049 IF(MINT(31).LT.240) GOTO 190
11050 240 CONTINUE
11051 MINT(1)=ISUBSV
11052 DO 250 J=11,80
11053 VINT(J)=VINTSV(J)
11054 250 CONTINUE
11055 ENDIF
11056
11057C...Format statements for printout.
11058 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
11059 &'actions for MSTP(82) =',I2,' ******')
11060 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11061 &D9.2,' mb: rejected')
11062 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11063 &D9.2,' mb: accepted')
11064
11065 RETURN
11066 END
11067
11068C*********************************************************************
11069
11070C...PYREMN
11071C...Adds on target remnants (one or two from each side) and
11072C...includes primordial kT for hadron beams.
11073
11074 SUBROUTINE PYREMN(IPU1,IPU2)
11075
11076C...Double precision and integer declarations.
11077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11078 INTEGER PYK,PYCHGE,PYCOMP
11079C...Commonblocks.
11080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11082 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11083 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11084 COMMON/PYINT1/MINT(400),VINT(400)
11085 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
11086C...Local arrays.
11087 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
11088 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
11089
11090C...Find event type and remaining energy.
11091 ISUB=MINT(1)
11092 NS=N
11093 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
11094 VINT(143)=1D0-VINT(141)
11095 VINT(144)=1D0-VINT(142)
11096 ENDIF
11097
11098C...Define initial partons.
11099 NTRY=0
11100 100 NTRY=NTRY+1
11101 DO 130 JT=1,2
11102 I=MINT(83)+JT+2
11103 IF(JT.EQ.1) IPU=IPU1
11104 IF(JT.EQ.2) IPU=IPU2
11105 K(I,1)=21
11106 K(I,2)=K(IPU,2)
11107 K(I,3)=I-2
11108 PMS(JT)=0D0
11109 VINT(156+JT)=0D0
11110 VINT(158+JT)=0D0
11111 IF(MINT(47).EQ.1) THEN
11112 DO 110 J=1,5
11113 P(I,J)=P(I-2,J)
11114 110 CONTINUE
11115 ELSEIF(ISUB.EQ.95) THEN
11116 K(I,2)=21
11117 ELSE
11118 P(I,5)=P(IPU,5)
11119
11120C...No primordial kT, or chosen according to truncated Gaussian or
11121C...exponential, or (for photon) predetermined or power law.
11122 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
11123 IF(MSTP(91).LE.0) THEN
11124 PT=0D0
11125 ELSEIF(MSTP(91).EQ.1) THEN
11126 PT=PARP(91)*SQRT(-LOG(PYR(0)))
11127 ELSE
11128 RPT1=PYR(0)
11129 RPT2=PYR(0)
11130 PT=-PARP(92)*LOG(RPT1*RPT2)
11131 ENDIF
11132 IF(PT.GT.PARP(93)) GOTO 120
11133 ELSEIF(MINT(106+JT).EQ.3) THEN
11134 PT=SQRT(VINT(282+JT))
11135 PT=PT*0.8D0**MINT(57)
11136 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
11137 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
11138 IF(MSTP(93).LE.0) THEN
11139 PT=0D0
11140 ELSEIF(MSTP(93).EQ.1) THEN
11141 PT=PARP(99)*SQRT(-LOG(PYR(0)))
11142 ELSEIF(MSTP(93).EQ.2) THEN
11143 RPT1=PYR(0)
11144 RPT2=PYR(0)
11145 PT=-PARP(99)*LOG(RPT1*RPT2)
11146 ELSEIF(MSTP(93).EQ.3) THEN
11147 HA=PARP(99)**2
11148 HB=PARP(100)**2
11149 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
11150 ELSE
11151 HA=PARP(99)**2
11152 HB=PARP(100)**2
11153 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
11154 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
11155 ENDIF
11156 IF(PT.GT.PARP(100)) GOTO 120
11157 ELSE
11158 PT=0D0
11159 ENDIF
11160 VINT(156+JT)=PT
11161 PHI=PARU(2)*PYR(0)
11162 P(I,1)=PT*COS(PHI)
11163 P(I,2)=PT*SIN(PHI)
11164 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11165 ENDIF
11166 130 CONTINUE
11167 IF(MINT(47).EQ.1) RETURN
11168
11169C...Kinematics construction for initial partons.
11170 I1=MINT(83)+3
11171 I2=MINT(83)+4
11172 IF(ISUB.EQ.95) THEN
11173 SHS=0D0
11174 SHR=0D0
11175 ELSE
11176 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
11177 & (P(I1,2)+P(I2,2))**2
11178 SHR=SQRT(MAX(0D0,SHS))
11179 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
11180 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
11181 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
11182 P(I2,4)=SHR-P(I1,4)
11183 P(I2,3)=-P(I1,3)
11184
11185C...Transform partons to overall CM-frame.
11186 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
11187 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
11188 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
11189 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
11190 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
11191 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
11192 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
11193 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
11194 ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(VINT(141)-VINT(142))/
11195 & (VINT(141)+VINT(142))))
11196 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
11197 ENDIF
11198
11199C...Optionally fix up x and Q2 definitions for leptoproduction.
11200 IDISXQ=0
11201 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
11202 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
11203 IF(IDISXQ.EQ.1) THEN
11204
11205C...Find where incoming and outgoing leptons/partons are sitting.
11206 LESD=1
11207 IF(MINT(42).EQ.1) LESD=2
11208 LPIN=MINT(83)+3-LESD
11209 LEIN=MINT(84)+LESD
11210 LQIN=MINT(84)+3-LESD
11211 LEOUT=MINT(84)+2+LESD
11212 LQOUT=MINT(84)+5-LESD
11213 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
11214 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
11215 LSCMS=0
11216 DO 140 I=MINT(84)+5,N
11217 IF(K(I,2).EQ.94) THEN
11218 LSCMS=I
11219 LEOUT=I+LESD
11220 LQOUT=I+3-LESD
11221 ENDIF
11222 140 CONTINUE
11223 LQBG=IPU1
11224 IF(LESD.EQ.1) LQBG=IPU2
11225
11226C...Calculate actual and wanted momentum transfer.
11227 XNOM=VINT(43-LESD)
11228 Q2NOM=-VINT(45)
11229 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
11230 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
11231 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
11232 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
11233 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
11234 P(N+1,1)=FAC*P(LEOUT,1)
11235 P(N+1,2)=FAC*P(LEOUT,2)
11236 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
11237 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
11238 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
11239 & P(N+1,3)**2)
11240 DO 150 J=1,4
11241 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
11242 QNEW(J)=P(LEIN,J)-P(N+1,J)
11243 150 CONTINUE
11244
11245C...Boost outgoing electron and daughters.
11246 IF(LSCMS.EQ.0) THEN
11247 DO 160 J=1,4
11248 P(LEOUT,J)=P(N+1,J)
11249 160 CONTINUE
11250 ELSE
11251 DO 170 J=1,3
11252 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
11253 170 CONTINUE
11254 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
11255 DO 180 J=1,3
11256 DBE(J)=PINV*P(N+2,J)
11257 180 CONTINUE
11258 DO 200 I=LSCMS+1,N
11259 IORIG=I
11260 190 IORIG=K(IORIG,3)
11261 IF(IORIG.GT.LEOUT) GOTO 190
11262 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
11263 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
11264 200 CONTINUE
11265 ENDIF
11266
11267C...Copy shower initiator and all outgoing partons.
11268 NCOP=N+1
11269 K(NCOP,3)=LQBG
11270 DO 210 J=1,5
11271 P(NCOP,J)=P(LQBG,J)
11272 210 CONTINUE
11273 DO 240 I=MINT(84)+1,N
11274 ICOP=0
11275 IF(K(I,1).GT.10) GOTO 240
11276 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
11277 ICOP=I
11278 ELSE
11279 IORIG=I
11280 220 IORIG=K(IORIG,3)
11281 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
11282 ICOP=IORIG
11283 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
11284 GOTO 220
11285 ENDIF
11286 ENDIF
11287 IF(ICOP.NE.0) THEN
11288 NCOP=NCOP+1
11289 K(NCOP,3)=I
11290 DO 230 J=1,5
11291 P(NCOP,J)=P(I,J)
11292 230 CONTINUE
11293 ENDIF
11294 240 CONTINUE
11295
11296C...Calculate relative rescaling factors.
11297 SLC=3-2*LESD
11298 PLCSUM=0D0
11299 DO 250 I=N+2,NCOP
11300 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
11301 250 CONTINUE
11302 DO 260 I=N+2,NCOP
11303 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
11304 260 CONTINUE
11305
11306C...Transfer extra three-momentum of current.
11307 DO 280 I=N+2,NCOP
11308 DO 270 J=1,3
11309 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
11310 270 CONTINUE
11311 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11312 280 CONTINUE
11313
11314C...Iterate change of initiator momentum to get energy right.
11315 ITER=0
11316 290 ITER=ITER+1
11317 PEEX=-P(N+1,4)-QNEW(4)
11318 PEMV=-P(N+1,3)/P(N+1,4)
11319 DO 300 I=N+2,NCOP
11320 PEEX=PEEX+P(I,4)
11321 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
11322 300 CONTINUE
11323 IF(ABS(PEMV).LT.1D-10) THEN
11324 MINT(51)=1
11325 MINT(57)=MINT(57)+1
11326 RETURN
11327 ENDIF
11328 PZCH=-PEEX/PEMV
11329 P(N+1,3)=P(N+1,3)+PZCH
11330 P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
11331 DO 310 I=N+2,NCOP
11332 P(I,3)=P(I,3)+V(I,1)*PZCH
11333 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11334 310 CONTINUE
11335 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
11336
11337C...Modify momenta in event record.
11338 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
11339 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
11340 IF(ABS(HBE).GT.0.999999D0) THEN
11341 MINT(51)=1
11342 MINT(57)=MINT(57)+1
11343 RETURN
11344 ENDIF
11345 I=MINT(83)+5-LESD
11346 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
11347 DO 330 I=N+1,NCOP
11348 ICOP=K(I,3)
11349 DO 320 J=1,4
11350 P(ICOP,J)=P(I,J)
11351 320 CONTINUE
11352 330 CONTINUE
11353 ENDIF
11354
11355C...Check minimum invariant mass of remnant system(s).
11356 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
11357 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
11358 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11359 PMIN(0)=SQRT(PMS(0))
11360 DO 340 JT=1,2
11361 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
11362 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
11363 PMIN(JT)=0D0
11364 IF(MINT(44+JT).EQ.1) GOTO 340
11365 MINT(105)=MINT(102+JT)
11366 MINT(109)=MINT(106+JT)
11367 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
11368 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
11369 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
11370 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
11371 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
11372 & P(MINT(83)+JT+2,2)**2)
11373 340 CONTINUE
11374 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
11375 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
11376 &PSYS(2,4))) THEN
11377 MINT(51)=1
11378 MINT(57)=MINT(57)+1
11379 RETURN
11380 ENDIF
11381
11382C...Loop over two remnants; skip if none there.
11383 I=NS
11384 DO 410 JT=1,2
11385 ISN(JT)=0
11386 IF(MINT(44+JT).EQ.1) GOTO 410
11387 IF(JT.EQ.1) IPU=IPU1
11388 IF(JT.EQ.2) IPU=IPU2
11389
11390C...Store first remnant parton.
11391 I=I+1
11392 IS(JT)=I
11393 ISN(JT)=1
11394 DO 350 J=1,5
11395 K(I,J)=0
11396 P(I,J)=0D0
11397 V(I,J)=0D0
11398 350 CONTINUE
11399 K(I,1)=1
11400 K(I,2)=KFLSP(JT)
11401 K(I,3)=MINT(83)+JT
11402 P(I,5)=PYMASS(K(I,2))
11403
11404C...First parton colour connections and kinematics.
11405 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
11406 IF(KCOL.EQ.2) THEN
11407 K(I,1)=3
11408 K(I,4)=MSTU(5)*IPU+IPU
11409 K(I,5)=MSTU(5)*IPU+IPU
11410 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11411 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11412 ELSEIF(KCOL.NE.0) THEN
11413 K(I,1)=3
11414 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
11415 K(I,KFLS+3)=IPU
11416 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11417 ENDIF
11418 IF(KFLCH(JT).EQ.0) THEN
11419 P(I,1)=-P(MINT(83)+JT+2,1)
11420 P(I,2)=-P(MINT(83)+JT+2,2)
11421 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11422 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11423 P(I,3)=PSYS(JT,3)
11424 P(I,4)=PSYS(JT,4)
11425
11426C...When extra remnant parton or hadron: store extra remnant.
11427 ELSE
11428 I=I+1
11429 ISN(JT)=2
11430 DO 360 J=1,5
11431 K(I,J)=0
11432 P(I,J)=0D0
11433 V(I,J)=0D0
11434 360 CONTINUE
11435 K(I,1)=1
11436 K(I,2)=KFLCH(JT)
11437 K(I,3)=MINT(83)+JT
11438 P(I,5)=PYMASS(K(I,2))
11439
11440C...Find parton colour connections of extra remnant.
11441 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
11442 IF(KCOL.EQ.2) THEN
11443 K(I,1)=3
11444 K(I,4)=MSTU(5)*IPU+IPU
11445 K(I,5)=MSTU(5)*IPU+IPU
11446 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11447 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11448 ELSEIF(KCOL.NE.0) THEN
11449 K(I,1)=3
11450 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
11451 K(I,KFLS+3)=IPU
11452 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11453 ENDIF
11454
11455C...Relative transverse momentum when two remnants.
11456 LOOP=0
11457 370 LOOP=LOOP+1
11458 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
11459 IF(IABS(MINT(10+JT)).LT.20) THEN
11460 P(I-1,1)=0D0
11461 P(I-1,2)=0D0
11462 ENDIF
11463 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
11464 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
11465 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
11466 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11467
11468C...Meson or baryon; photon as meson. For splitup below.
11469 IMB=1
11470 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
11471
11472C***Relative distribution for electron into two electrons. Temporary!
11473 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
11474 & THEN
11475 CHI(JT)=PYR(0)
11476
11477C...Relative distribution of electron energy into electron plus parton.
11478 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
11479 XHRD=VINT(140+JT)
11480 XE=VINT(154+JT)
11481 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
11482
11483C...Relative distribution of energy for particle into two jets.
11484 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
11485 CHIK=PARP(92+2*IMB)
11486 IF(MSTP(92).LE.1) THEN
11487 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11488 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11489 ELSEIF(MSTP(92).EQ.2) THEN
11490 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
11491 ELSEIF(MSTP(92).EQ.3) THEN
11492 CUT=2D0*0.3D0/VINT(1)
11493 380 CHI(JT)=PYR(0)**2
11494 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
11495 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
11496 ELSEIF(MSTP(92).EQ.4) THEN
11497 CUT=2D0*0.3D0/VINT(1)
11498 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11499 390 CHIR=CUT*CUTR**PYR(0)
11500 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
11501 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
11502 ELSE
11503 CUT=2D0*0.3D0/VINT(1)
11504 CUTA=CUT**(1D0-PARP(98))
11505 CUTB=(1D0+CUT)**(1D0-PARP(98))
11506 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11507 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
11508 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
11509 ENDIF
11510
11511C...Relative distribution of energy for particle into jet plus particle.
11512 ELSE
11513 IF(MSTP(94).LE.1) THEN
11514 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11515 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11516 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11517 ELSEIF(MSTP(94).EQ.2) THEN
11518 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
11519 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11520 ELSEIF(MSTP(94).EQ.3) THEN
11521 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
11522 CHI(JT)=ZZ
11523 ELSE
11524 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
11525 CHI(JT)=ZZ
11526 ENDIF
11527 ENDIF
11528
11529C...Construct total transverse mass; reject if too large.
11530 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
11531 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
11532 IF(LOOP.LT.10) THEN
11533 GOTO 370
11534 ELSE
11535 MINT(51)=1
11536 MINT(57)=MINT(57)+1
11537 RETURN
11538 ENDIF
11539 ENDIF
11540 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11541 VINT(158+JT)=CHI(JT)
11542
11543C...Subdivide longitudinal momentum according to value selected above.
11544 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
11545 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
11546 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
11547 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
11548 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
11549 ENDIF
11550 410 CONTINUE
11551 N=I
11552
11553C...Check if longitudinal boosts needed - if so pick two systems.
11554 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
11555 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
11556 IF(PDEV.LE.1D-6*VINT(1)) RETURN
11557 IF(ISN(1).EQ.0) THEN
11558 IR=0
11559 IL=2
11560 ELSEIF(ISN(2).EQ.0) THEN
11561 IR=1
11562 IL=0
11563 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
11564 IR=1
11565 IL=2
11566 ELSEIF(VINT(143).GT.0.2D0) THEN
11567 IR=1
11568 IL=0
11569 ELSEIF(VINT(144).GT.0.2D0) THEN
11570 IR=0
11571 IL=2
11572 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
11573 IR=1
11574 IL=0
11575 ELSE
11576 IR=0
11577 IL=2
11578 ENDIF
11579 IG=3-IR-IL
11580
11581C...E+-pL wanted for system to be modified.
11582 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
11583 PPB=VINT(1)
11584 PNB=VINT(1)
11585 ELSE
11586 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
11587 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
11588 ENDIF
11589
11590C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
11591 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
11592 PMTB=PPB*PNB
11593 PMTR=PMS(IR)
11594 PMTL=PMS(IL)
11595 SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
11596 SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11597 RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
11598 & *PNB)
11599 RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
11600 & *PPB)
11601 BER=(RKR**2-1D0)/(RKR**2+1D0)
11602 BEL=-(RKL**2-1D0)/(RKL**2+1D0)
11603 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
11604 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
11605 DO 420 J=1,4
11606 PSYS(0,J)=0D0
11607 420 CONTINUE
11608 DO 450 I=MINT(84)+1,NS
11609 IF(K(I,1).GT.10) GOTO 450
11610 INCL=0
11611 IORIG=I
11612 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11613 IORIG=K(IORIG,3)
11614 IF(IORIG.GT.LPIN) GOTO 430
11615 IF(INCL.EQ.0) GOTO 450
11616 DO 440 J=1,4
11617 PSYS(0,J)=PSYS(0,J)+P(I,J)
11618 440 CONTINUE
11619 450 CONTINUE
11620 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11621 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
11622 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
11623 ENDIF
11624
11625C...Construct longitudinal boosts.
11626 DPMTB=PPB*PNB
11627 DPMTR=PMS(IR)
11628 DPMTL=PMS(IL)
11629 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
11630 IF(DSQLAM.LE.1D-6*DPMTB) THEN
11631 MINT(51)=1
11632 MINT(57)=MINT(57)+1
11633 RETURN
11634 ENDIF
11635 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11636 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
11637 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
11638 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
11639 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
11640 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
11641 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
11642
11643C...Perform longitudinal boosts.
11644 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
11645 P(IS(1),3)=0D0
11646 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
11647 ELSEIF(IR.EQ.1) THEN
11648 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
11649 ELSEIF(IDISXQ.EQ.1) THEN
11650 DO 470 I=I1,NS
11651 INCL=0
11652 IORIG=I
11653 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11654 IORIG=K(IORIG,3)
11655 IF(IORIG.GT.LPIN) GOTO 460
11656 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
11657 470 CONTINUE
11658 ELSE
11659 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
11660 ENDIF
11661 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
11662 P(IS(2),3)=0D0
11663 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
11664 ELSEIF(IL.EQ.2) THEN
11665 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
11666 ELSEIF(IDISXQ.EQ.1) THEN
11667 DO 490 I=I1,NS
11668 INCL=0
11669 IORIG=I
11670 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11671 IORIG=K(IORIG,3)
11672 IF(IORIG.GT.LPIN) GOTO 480
11673 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
11674 490 CONTINUE
11675 ELSE
11676 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
11677 ENDIF
11678
11679C...Final check that energy-momentum conservation worked.
11680 PESUM=0D0
11681 PZSUM=0D0
11682 DO 500 I=MINT(84)+1,N
11683 IF(K(I,1).GT.10) GOTO 500
11684 PESUM=PESUM+P(I,4)
11685 PZSUM=PZSUM+P(I,3)
11686 500 CONTINUE
11687 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
11688 IF(PDEV.GT.1D-4*VINT(1)) THEN
11689 MINT(51)=1
11690 MINT(57)=MINT(57)+1
11691 RETURN
11692 ENDIF
11693
11694C...Calculate rotation and boost from overall CM frame to
11695C...hadronic CM frame in leptoproduction.
11696 MINT(91)=0
11697 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
11698 MINT(91)=1
11699 LESD=1
11700 IF(MINT(42).EQ.1) LESD=2
11701 LPIN=MINT(83)+3-LESD
11702
11703C...Sum upp momenta of everything not lepton or photon to define boost.
11704 DO 510 J=1,4
11705 PSUM(J)=0D0
11706 510 CONTINUE
11707 DO 530 I=1,N
11708 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
11709 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
11710 IF(K(I,2).EQ.22) GOTO 530
11711 DO 520 J=1,4
11712 PSUM(J)=PSUM(J)+P(I,J)
11713 520 CONTINUE
11714 530 CONTINUE
11715 VINT(223)=-PSUM(1)/PSUM(4)
11716 VINT(224)=-PSUM(2)/PSUM(4)
11717 VINT(225)=-PSUM(3)/PSUM(4)
11718
11719C...Boost incoming hadron to hadronic CM frame to determine rotations.
11720 K(N+1,1)=1
11721 DO 540 J=1,5
11722 P(N+1,J)=P(LPIN,J)
11723 V(N+1,J)=V(LPIN,J)
11724 540 CONTINUE
11725 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
11726 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
11727 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
11728 IF(LESD.EQ.2) THEN
11729 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
11730 ELSE
11731 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
11732 ENDIF
11733 ENDIF
11734
11735 RETURN
11736 END
11737
11738C*********************************************************************
11739
11740C...PYDIFF
11741C...Handles diffractive and elastic scattering.
11742
11743 SUBROUTINE PYDIFF
11744
11745C...Double precision and integer declarations.
11746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11747 INTEGER PYK,PYCHGE,PYCOMP
11748C...Commonblocks.
11749 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11751 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11752 COMMON/PYINT1/MINT(400),VINT(400)
11753 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11754
11755C...Reset K, P and V vectors. Store incoming particles.
11756 DO 110 JT=1,MSTP(126)+10
11757 I=MINT(83)+JT
11758 DO 100 J=1,5
11759 K(I,J)=0
11760 P(I,J)=0D0
11761 V(I,J)=0D0
11762 100 CONTINUE
11763 110 CONTINUE
11764 N=MINT(84)
11765 MINT(3)=0
11766 MINT(21)=0
11767 MINT(22)=0
11768 MINT(23)=0
11769 MINT(24)=0
11770 MINT(4)=4
11771 DO 130 JT=1,2
11772 I=MINT(83)+JT
11773 K(I,1)=21
11774 K(I,2)=MINT(10+JT)
11775 DO 120 J=1,5
11776 P(I,J)=VINT(285+5*JT+J)
11777 120 CONTINUE
11778 130 CONTINUE
11779 MINT(6)=2
11780
11781C...Subprocess; kinematics.
11782 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
11783 PZ=SQRT(SQLAM)/(2D0*VINT(1))
11784 DO 200 JT=1,2
11785 I=MINT(83)+JT
11786 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
11787 KFH=MINT(102+JT)
11788
11789C...Elastically scattered particle.
11790 IF(MINT(16+JT).LE.0) THEN
11791 N=N+1
11792 K(N,1)=1
11793 K(N,2)=KFH
11794 K(N,3)=I+2
11795 P(N,3)=PZ*(-1)**(JT+1)
11796 P(N,4)=PE
11797 P(N,5)=SQRT(VINT(62+JT))
11798
11799C...Decay rho from elastic scattering of gamma with sin**2(theta)
11800C...distribution of decay products (in rho rest frame).
11801 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
11802 NSAV=N
11803 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
11804 P(N,3)=0D0
11805 P(N,4)=P(N,5)
11806 CALL PYDECY(NSAV)
11807 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
11808 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
11809 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
11810 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
11811 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
11812 140 CTHE=2D0*PYR(0)-1D0
11813 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
11814 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
11815 ENDIF
11816 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
11817 ENDIF
11818
11819C...Diffracted particle: low-mass system to two particles.
11820 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
11821 N=N+2
11822 K(N-1,1)=1
11823 K(N,1)=1
11824 K(N-1,3)=I+2
11825 K(N,3)=I+2
11826 PMMAS=SQRT(VINT(62+JT))
11827 NTRY=0
11828 150 NTRY=NTRY+1
11829 IF(NTRY.LT.20) THEN
11830 MINT(105)=MINT(102+JT)
11831 MINT(109)=MINT(106+JT)
11832 CALL PYSPLI(KFH,21,KFL1,KFL2)
11833 CALL PYKFDI(KFL1,0,KFL3,KF1)
11834 IF(KF1.EQ.0) GOTO 150
11835 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
11836 IF(KF2.EQ.0) GOTO 150
11837 ELSE
11838 KF1=KFH
11839 KF2=111
11840 ENDIF
11841 PM1=PYMASS(KF1)
11842 PM2=PYMASS(KF2)
11843 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
11844 K(N-1,2)=KF1
11845 K(N,2)=KF2
11846 P(N-1,5)=PM1
11847 P(N,5)=PM2
11848 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
11849 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
11850 P(N-1,3)=PZP
11851 P(N,3)=-PZP
11852 P(N-1,4)=SQRT(PM1**2+PZP**2)
11853 P(N,4)=SQRT(PM2**2+PZP**2)
11854 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
11855 & 0D0,0D0,0D0)
11856 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
11857 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
11858
11859C...Diffracted particle: valence quark kicked out.
11860 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
11861 & PARP(101))) THEN
11862 N=N+2
11863 K(N-1,1)=2
11864 K(N,1)=1
11865 K(N-1,3)=I+2
11866 K(N,3)=I+2
11867 MINT(105)=MINT(102+JT)
11868 MINT(109)=MINT(106+JT)
11869 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
11870 P(N-1,5)=PYMASS(K(N-1,2))
11871 P(N,5)=PYMASS(K(N,2))
11872 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
11873 & 4D0*P(N-1,5)**2*P(N,5)**2
11874 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
11875 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
11876 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
11877 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
11878 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11879
11880C...Diffracted particle: gluon kicked out.
11881 ELSE
11882 N=N+3
11883 K(N-2,1)=2
11884 K(N-1,1)=2
11885 K(N,1)=1
11886 K(N-2,3)=I+2
11887 K(N-1,3)=I+2
11888 K(N,3)=I+2
11889 MINT(105)=MINT(102+JT)
11890 MINT(109)=MINT(106+JT)
11891 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
11892 K(N-1,2)=21
11893 P(N-2,5)=PYMASS(K(N-2,2))
11894 P(N-1,5)=0D0
11895 P(N,5)=PYMASS(K(N,2))
11896C...Energy distribution for particle into two jets.
11897 160 IMB=1
11898 IF(MOD(KFH/1000,10).NE.0) IMB=2
11899 CHIK=PARP(92+2*IMB)
11900 IF(MSTP(92).LE.1) THEN
11901 IF(IMB.EQ.1) CHI=PYR(0)
11902 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
11903 ELSEIF(MSTP(92).EQ.2) THEN
11904 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
11905 ELSEIF(MSTP(92).EQ.3) THEN
11906 CUT=2D0*0.3D0/VINT(1)
11907 170 CHI=PYR(0)**2
11908 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
11909 & PYR(0)) GOTO 170
11910 ELSEIF(MSTP(92).EQ.4) THEN
11911 CUT=2D0*0.3D0/VINT(1)
11912 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11913 180 CHIR=CUT*CUTR**PYR(0)
11914 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
11915 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
11916 ELSE
11917 CUT=2D0*0.3D0/VINT(1)
11918 CUTA=CUT**(1D0-PARP(98))
11919 CUTB=(1D0+CUT)**(1D0-PARP(98))
11920 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11921 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
11922 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
11923 ENDIF
11924 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
11925 & VINT(62+JT)) GOTO 160
11926 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
11927 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160
11928 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
11929 & (2D0*VINT(62+JT))
11930 PEI=SQRT(PZI**2+SQM)
11931 PQQP=(1D0-CHI)*(PEI+PZI)
11932 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
11933 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
11934 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
11935 P(N-1,3)=P(N-1,4)*(-1)**JT
11936 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
11937 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11938 ENDIF
11939
11940C...Documentation lines.
11941 K(I+2,1)=21
11942 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
11943 IF(MINT(16+JT).NE.0) K(I+2,2)=10*(KFH/10)
11944 K(I+2,3)=I
11945 P(I+2,3)=PZ*(-1)**(JT+1)
11946 P(I+2,4)=PE
11947 P(I+2,5)=SQRT(VINT(62+JT))
11948 200 CONTINUE
11949
11950C...Rotate outgoing partons/particles using cos(theta).
11951 IF(VINT(23).LT.0.9D0) THEN
11952 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
11953 ELSE
11954 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
11955 ENDIF
11956
11957 RETURN
11958 END
11959
11960C*********************************************************************
11961
11962C...PYDOCU
11963C...Handles the documentation of the process in MSTI and PARI,
11964C...and also computes cross-sections based on accumulated statistics.
11965
11966 SUBROUTINE PYDOCU
11967
11968C...Double precision and integer declarations.
11969 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11970 INTEGER PYK,PYCHGE,PYCOMP
11971C...Commonblocks.
11972 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11975 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11976 COMMON/PYINT1/MINT(400),VINT(400)
11977 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11978 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
11979 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
11980 &/PYINT5/
11981
11982C...Calculate Monte Carlo estimates of cross-sections.
11983 ISUB=MINT(1)
11984 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
11985 NGEN(0,3)=NGEN(0,3)+1
11986 XSEC(0,3)=0D0
11987 DO 100 I=1,500
11988 IF(I.EQ.96.OR.I.EQ.97) THEN
11989 XSEC(I,3)=0D0
11990 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
11991 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
11992 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
11993 & DBLE(NGEN(96,2)))
11994 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
11995 XSEC(I,3)=0D0
11996 ELSEIF(NGEN(I,2).EQ.0) THEN
11997 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
11998 & DBLE(NGEN(0,2)))
11999 ELSE
12000 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
12001 & DBLE(NGEN(I,2)))
12002 ENDIF
12003 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
12004 100 CONTINUE
12005
12006C...Rescale to known low-pT cross-section for standard QCD processes.
12007 IF(MSUB(95).EQ.1) THEN
12008 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
12009 & XSEC(68,3)+XSEC(95,3)
12010 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
12011 IF(XSECH.GT.1D-10.AND.XSECW.GT.1D-10) THEN
12012 FAC=XSECW/XSECH
12013 XSEC(11,3)=FAC*XSEC(11,3)
12014 XSEC(12,3)=FAC*XSEC(12,3)
12015 XSEC(13,3)=FAC*XSEC(13,3)
12016 XSEC(28,3)=FAC*XSEC(28,3)
12017 XSEC(53,3)=FAC*XSEC(53,3)
12018 XSEC(68,3)=FAC*XSEC(68,3)
12019 XSEC(95,3)=FAC*XSEC(95,3)
12020 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
12021 ENDIF
12022 ENDIF
12023
12024C...Save information for gamma-p and gamma-gamma.
12025 IF(MINT(121).GT.1) THEN
12026 IGA=MINT(122)
12027 CALL PYSAVE(2,IGA)
12028 CALL PYSAVE(5,0)
12029 ENDIF
12030
12031C...Reset information on hard interaction.
12032 DO 110 J=1,200
12033 MSTI(J)=0
12034 PARI(J)=0D0
12035 110 CONTINUE
12036
12037C...Copy integer valued information from MINT into MSTI.
12038 DO 120 J=1,32
12039 MSTI(J)=MINT(J)
12040 120 CONTINUE
12041 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
12042
12043C...Store cross-section variables in PARI.
12044 PARI(1)=XSEC(0,3)
12045 PARI(2)=XSEC(0,3)/MINT(5)
12046 PARI(9)=VINT(99)
12047 PARI(10)=VINT(100)
12048 VINT(98)=VINT(98)+VINT(100)
12049 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
12050
12051C...Store kinematics variables in PARI.
12052 PARI(11)=VINT(1)
12053 PARI(12)=VINT(2)
12054 IF(ISUB.NE.95) THEN
12055 DO 130 J=13,26
12056 PARI(J)=VINT(30+J)
12057 130 CONTINUE
12058 PARI(31)=VINT(141)
12059 PARI(32)=VINT(142)
12060 PARI(33)=VINT(41)
12061 PARI(34)=VINT(42)
12062 PARI(35)=PARI(33)-PARI(34)
12063 PARI(36)=VINT(21)
12064 PARI(37)=VINT(22)
12065 PARI(38)=VINT(26)
12066 PARI(39)=VINT(157)
12067 PARI(40)=VINT(158)
12068 PARI(41)=VINT(23)
12069 PARI(42)=2D0*VINT(47)/VINT(1)
12070 ENDIF
12071
12072C...Store information on scattered partons in PARI.
12073 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
12074 DO 140 IS=7,8
12075 I=MINT(IS)
12076 PARI(36+IS)=P(I,3)/VINT(1)
12077 PARI(38+IS)=P(I,4)/VINT(1)
12078 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
12079 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12080 & SQRT(PR),1D20)),P(I,3))
12081 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
12082 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12083 & SQRT(PR),1D20)),P(I,3))
12084 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
12085 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
12086 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
12087 140 CONTINUE
12088 ENDIF
12089
12090C...Store sum up transverse and longitudinal momenta.
12091 PARI(65)=2D0*PARI(17)
12092 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
12093 DO 150 I=MSTP(126)+1,N
12094 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
12095 PT=SQRT(P(I,1)**2+P(I,2)**2)
12096 PARI(69)=PARI(69)+PT
12097 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
12098 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
12099 150 CONTINUE
12100 PARI(67)=PARI(68)
12101 PARI(71)=VINT(151)
12102 PARI(72)=VINT(152)
12103 PARI(73)=VINT(151)
12104 PARI(74)=VINT(152)
12105 ELSE
12106 PARI(66)=PARI(65)
12107 PARI(69)=PARI(65)
12108 ENDIF
12109
12110C...Store various other pieces of information into PARI.
12111 PARI(61)=VINT(148)
12112 PARI(75)=VINT(155)
12113 PARI(76)=VINT(156)
12114 PARI(77)=VINT(159)
12115 PARI(78)=VINT(160)
12116 PARI(81)=VINT(138)
12117
12118C...Set information for PYTABU.
12119 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12120 MSTU(161)=MINT(21)
12121 MSTU(162)=0
12122 ELSEIF(ISET(ISUB).EQ.5) THEN
12123 MSTU(161)=MINT(23)
12124 MSTU(162)=0
12125 ELSE
12126 MSTU(161)=MINT(21)
12127 MSTU(162)=MINT(22)
12128 ENDIF
12129
12130 RETURN
12131 END
12132
12133C*********************************************************************
12134
12135C...PYFRAM
12136C...Performs transformations between different coordinate frames.
12137
12138 SUBROUTINE PYFRAM(IFRAME)
12139
12140C...Double precision and integer declarations.
12141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12142 INTEGER PYK,PYCHGE,PYCOMP
12143C...Commonblocks.
12144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12145 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12146 COMMON/PYINT1/MINT(400),VINT(400)
12147 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
12148
12149C...Check that transformation can and should be done.
12150 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
12151 &MINT(91).EQ.1)) THEN
12152 IF(IFRAME.EQ.MINT(6)) RETURN
12153 ELSE
12154 WRITE(MSTU(11),5000) IFRAME,MINT(6)
12155 RETURN
12156 ENDIF
12157
12158 IF(MINT(6).EQ.1) THEN
12159C...Transform from fixed target or user specified frame to
12160C...overall CM frame.
12161 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
12162 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
12163 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
12164 ELSEIF(MINT(6).EQ.3) THEN
12165C...Transform from hadronic CM frame in DIS to overall CM frame.
12166 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
12167 & -VINT(225))
12168 ENDIF
12169
12170 IF(IFRAME.EQ.1) THEN
12171C...Transform from overall CM frame to fixed target or user specified
12172C...frame.
12173 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
12174 ELSEIF(IFRAME.EQ.3) THEN
12175C...Transform from overall CM frame to hadronic CM frame in DIS.
12176 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
12177 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
12178 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
12179 ENDIF
12180
12181C...Set information about new frame.
12182 MINT(6)=IFRAME
12183 MSTI(6)=IFRAME
12184
12185 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
12186 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
12187 &1X,I5)
12188
12189 RETURN
12190 END
12191
12192C*********************************************************************
12193
12194C...PYWIDT
12195C...Calculates full and partial widths of resonances.
12196
12197 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
12198
12199C...Double precision and integer declarations.
12200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12201 INTEGER PYK,PYCHGE,PYCOMP
12202C...Parameter statement to help give large particle numbers.
12203 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
12204C...Commonblocks.
12205 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12206 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12207 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
12208 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12209 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12210 COMMON/PYINT1/MINT(400),VINT(400)
12211 COMMON/PYINT4/MWID(500),WIDS(500,5)
12212 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
12213 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
12214 &SFMIX(16,4)
12215 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
12216 &/PYINT4/,/PYMSSM/,/PYSSMT/
12217C...Local arrays and saved variables.
12218 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
12219 &WID2SV(3,2)
12220 SAVE MOFSV,WIDWSV,WID2SV
12221 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
12222
12223C...Compressed code and sign; mass.
12224 KFLA=IABS(KFLR)
12225 KFLS=ISIGN(1,KFLR)
12226 KC=PYCOMP(KFLA)
12227 SHR=SQRT(SH)
12228 PMR=PMAS(KC,1)
12229
12230C...Reset width information.
12231 DO 110 I=0,200
12232 WDTP(I)=0D0
12233 DO 100 J=0,5
12234 WDTE(I,J)=0D0
12235 100 CONTINUE
12236 110 CONTINUE
12237
12238C...Not to be treated as a resonance: return.
12239 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
12240 &KFLA.NE.22) THEN
12241 WDTP(0)=1D0
12242 WDTE(0,0)=1D0
12243 MINT(61)=0
12244 MINT(62)=0
12245 MINT(63)=0
12246 RETURN
12247
12248C...Treatment as a resonance based on tabulated branching ratios.
12249 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
12250C...Loop over possible decay channels; skip irrelevant ones.
12251 DO 120 I=1,MDCY(KC,3)
12252 IDC=I+MDCY(KC,2)-1
12253 IF(MDME(IDC,1).LT.0) GOTO 120
12254
12255C...Read out decay products and nominal masses.
12256 KFD1=KFDP(IDC,1)
12257 KFC1=PYCOMP(KFD1)
12258 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
12259 PM1=PMAS(KFC1,1)
12260 KFD2=KFDP(IDC,2)
12261 KFC2=PYCOMP(KFD2)
12262 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
12263 PM2=PMAS(KFC2,1)
12264 KFD3=KFDP(IDC,3)
12265 PM3=0D0
12266 IF(KFD3.NE.0) THEN
12267 KFC3=PYCOMP(KFD3)
12268 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
12269 PM3=PMAS(KFC3,1)
12270 ENDIF
12271
12272C...Naive partial width and alternative threshold factors.
12273 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
12274 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
12275 & PM1+PM2+PM3.GE.SHR) THEN
12276 WDTP(I)=0D0
12277 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
12278 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
12279 & 4D0*PM1**2*PM2**2))/SH
12280 ELSEIF(MDME(IDC,2).EQ.52) THEN
12281 PMA=MAX(PM1,PM2,PM3)
12282 PMC=MIN(PM1,PM2,PM3)
12283 PMB=PM1+PM2+PM3-PMA-PMC
12284 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
12285 PMAN=PMA**2/SH
12286 PMBN=PMB**2/SH
12287 PMCN=PMC**2/SH
12288 PMBCN=PMBC**2/SH
12289 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
12290 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12291 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12292 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12293 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12294 & ((1D0-PMBCN)*PMBCN*SH)
12295 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
12296 WDTP(I)=WDTP(I)*SQRT(
12297 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
12298 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
12299 ELSEIF(MDME(IDC,2).EQ.53) THEN
12300 PMA=MAX(PM1,PM2,PM3)
12301 PMC=MIN(PM1,PM2,PM3)
12302 PMB=PM1+PM2+PM3-PMA-PMC
12303 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
12304 PMAN=PMA**2/SH
12305 PMBN=PMB**2/SH
12306 PMCN=PMC**2/SH
12307 PMBCN=PMBC**2/SH
12308 FACACT=SQRT(MAX(0D0,
12309 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12310 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12311 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12312 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12313 & ((1D0-PMBCN)*PMBCN*SH)
12314 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
12315 PMAN=PMA**2/PMR**2
12316 PMBN=PMB**2/PMR**2
12317 PMCN=PMC**2/PMR**2
12318 PMBCN=PMBC**2/PMR**2
12319 FACNOM=SQRT(MAX(0D0,
12320 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12321 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12322 & ((PMR-PMA)**2-(PMB+PMC)**2)*
12323 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
12324 & ((1D0-PMBCN)*PMBCN*PMR**2)
12325 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
12326 ENDIF
12327 WDTP(0)=WDTP(0)+WDTP(I)
12328
12329C...Calculate secondary width (at most two identical/opposite).
12330 IF(MDME(IDC,1).GT.0) THEN
12331 IF(KFD2.EQ.KFD1) THEN
12332 IF(KCHG(KFC1,3).EQ.0) THEN
12333 WID2=WIDS(KFC1,1)
12334 ELSEIF(KFD1.GT.0) THEN
12335 WID2=WIDS(KFC1,4)
12336 ELSE
12337 WID2=WIDS(KFC1,5)
12338 ENDIF
12339 IF(KFD3.GT.0) THEN
12340 WID2=WID2*WIDS(KFC3,2)
12341 ELSEIF(KFD3.LT.0) THEN
12342 WID2=WID2*WIDS(KFC3,3)
12343 ENDIF
12344 ELSEIF(KFD2.EQ.-KFD1) THEN
12345 WID2=WIDS(KFC1,1)
12346 IF(KFD3.GT.0) THEN
12347 WID2=WID2*WIDS(KFC3,2)
12348 ELSEIF(KFD3.LT.0) THEN
12349 WID2=WID2*WIDS(KFC3,3)
12350 ENDIF
12351 ELSEIF(KFD3.EQ.KFD1) THEN
12352 IF(KCHG(KFC1,3).EQ.0) THEN
12353 WID2=WIDS(KFC1,1)
12354 ELSEIF(KFD1.GT.0) THEN
12355 WID2=WIDS(KFC1,4)
12356 ELSE
12357 WID2=WIDS(KFC1,5)
12358 ENDIF
12359 IF(KFD2.GT.0) THEN
12360 WID2=WID2*WIDS(KFC2,2)
12361 ELSEIF(KFD2.LT.0) THEN
12362 WID2=WID2*WIDS(KFC2,3)
12363 ENDIF
12364 ELSEIF(KFD3.EQ.-KFD1) THEN
12365 WID2=WIDS(KFC1,1)
12366 IF(KFD2.GT.0) THEN
12367 WID2=WID2*WIDS(KFC2,2)
12368 ELSEIF(KFD2.LT.0) THEN
12369 WID2=WID2*WIDS(KFC2,3)
12370 ENDIF
12371 ELSEIF(KFD3.EQ.KFD2) THEN
12372 IF(KCHG(KFC2,3).EQ.0) THEN
12373 WID2=WIDS(KFC2,1)
12374 ELSEIF(KFD2.GT.0) THEN
12375 WID2=WIDS(KFC2,4)
12376 ELSE
12377 WID2=WIDS(KFC2,5)
12378 ENDIF
12379 IF(KFD1.GT.0) THEN
12380 WID2=WID2*WIDS(KFC1,2)
12381 ELSEIF(KFD1.LT.0) THEN
12382 WID2=WID2*WIDS(KFC1,3)
12383 ENDIF
12384 ELSEIF(KFD3.EQ.-KFD2) THEN
12385 WID2=WIDS(KFC2,1)
12386 IF(KFD1.GT.0) THEN
12387 WID2=WID2*WIDS(KFC1,2)
12388 ELSEIF(KFD1.LT.0) THEN
12389 WID2=WID2*WIDS(KFC1,3)
12390 ENDIF
12391 ELSE
12392 IF(KFD1.GT.0) THEN
12393 WID2=WIDS(KFC1,2)
12394 ELSE
12395 WID2=WIDS(KFC1,3)
12396 ENDIF
12397 IF(KFD2.GT.0) THEN
12398 WID2=WID2*WIDS(KFC2,2)
12399 ELSE
12400 WID2=WID2*WIDS(KFC2,3)
12401 ENDIF
12402 IF(KFD3.GT.0) THEN
12403 WID2=WID2*WIDS(KFC3,2)
12404 ELSEIF(KFD3.LT.0) THEN
12405 WID2=WID2*WIDS(KFC3,3)
12406 ENDIF
12407 ENDIF
12408
12409C...Store effective widths according to case.
12410 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12411 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12412 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12413 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12414 ENDIF
12415 120 CONTINUE
12416C...Return.
12417 MINT(61)=0
12418 MINT(62)=0
12419 MINT(63)=0
12420 RETURN
12421 ENDIF
12422
12423C...Here begins detailed dynamical calculation of resonance widths.
12424C...Shared treatment of Higgs states.
12425 KFHIGG=25
12426 IHIGG=1
12427 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12428 KFHIGG=KFLA
12429 IHIGG=KFLA-33
12430 ENDIF
12431
12432C...Common electroweak and strong constants.
12433 XW=PARU(102)
12434 XWV=XW
12435 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12436 XW1=1D0-XW
12437 AEM=PYALEM(SH)
12438 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
12439 AS=PYALPS(SH)
12440 RADC=1D0+AS/PARU(1)
12441
12442 IF(KFLA.EQ.6) THEN
12443C...t quark.
12444 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12445 RADCT=1D0-2.5D0*AS/PARU(1)
12446 DO 130 I=1,MDCY(KC,3)
12447 IDC=I+MDCY(KC,2)-1
12448 IF(MDME(IDC,1).LT.0) GOTO 130
12449 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12450 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12451 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
12452 IF(I.GE.4.AND.I.LE.7) THEN
12453C...t -> W + q; including approximate QCD correction factor.
12454 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
12455 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12456 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12457 IF(KFLR.GT.0) THEN
12458 WID2=WIDS(24,2)
12459 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12460 ELSE
12461 WID2=WIDS(24,3)
12462 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12463 ENDIF
12464 ELSEIF(I.EQ.9) THEN
12465C...t -> H + b.
12466 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12467 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12468 WID2=WIDS(37,2)
12469 IF(KFLR.LT.0) WID2=WIDS(37,3)
12470CMRENNA++
12471 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
12472C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
12473 BETA=ATAN(RMSS(5))
12474 SINB=SIN(BETA)
12475 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
12476 ET=KCHG(6,1)/3D0
12477 T3L=SIGN(0.5D0,ET)
12478 KFC1=PYCOMP(KFDP(IDC,1))
12479 KFC2=PYCOMP(KFDP(IDC,2))
12480 PMNCHI=PMAS(KFC1,1)
12481 PMSTOP=PMAS(KFC2,1)
12482 IF(SHR.GT.PMNCHI+PMSTOP) THEN
12483 IZ=I-9
12484 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
12485 AR=-ET*ZMIX(IZ,1)*TANW
12486 BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
12487 BR=AL
12488 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
12489 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
12490 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
12491 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
12492 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
12493 & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
12494 IF(KFLR.GT.0) THEN
12495 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
12496 ELSE
12497 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
12498 ENDIF
12499 ENDIF
12500CMRENNA--
12501 ENDIF
12502 WDTP(0)=WDTP(0)+WDTP(I)
12503 IF(MDME(IDC,1).GT.0) THEN
12504 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12505 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12506 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12507 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12508 ENDIF
12509 130 CONTINUE
12510
12511 ELSEIF(KFLA.EQ.7) THEN
12512C...b' quark.
12513 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12514 DO 140 I=1,MDCY(KC,3)
12515 IDC=I+MDCY(KC,2)-1
12516 IF(MDME(IDC,1).LT.0) GOTO 140
12517 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12518 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12519 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
12520 IF(I.GE.4.AND.I.LE.7) THEN
12521C...b' -> W + q.
12522 WDTP(I)=FAC*VCKM(I-3,4)*
12523 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12524 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12525 IF(KFLR.GT.0) THEN
12526 WID2=WIDS(24,3)
12527 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
12528 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
12529 ELSE
12530 WID2=WIDS(24,2)
12531 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
12532 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
12533 ENDIF
12534 WID2=WIDS(24,3)
12535 IF(KFLR.LT.0) WID2=WIDS(24,2)
12536 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12537C...b' -> H + q.
12538 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12539 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12540 IF(KFLR.GT.0) THEN
12541 WID2=WIDS(37,3)
12542 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
12543 ELSE
12544 WID2=WIDS(37,2)
12545 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
12546 ENDIF
12547 ENDIF
12548 WDTP(0)=WDTP(0)+WDTP(I)
12549 IF(MDME(IDC,1).GT.0) THEN
12550 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12551 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12552 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12553 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12554 ENDIF
12555 140 CONTINUE
12556
12557 ELSEIF(KFLA.EQ.8) THEN
12558C...t' quark.
12559 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12560 DO 150 I=1,MDCY(KC,3)
12561 IDC=I+MDCY(KC,2)-1
12562 IF(MDME(IDC,1).LT.0) GOTO 150
12563 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12564 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12565 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
12566 IF(I.GE.4.AND.I.LE.7) THEN
12567C...t' -> W + q.
12568 WDTP(I)=FAC*VCKM(4,I-3)*
12569 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12570 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12571 IF(KFLR.GT.0) THEN
12572 WID2=WIDS(24,2)
12573 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12574 ELSE
12575 WID2=WIDS(24,3)
12576 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12577 ENDIF
12578 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12579C...t' -> H + q.
12580 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12581 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12582 IF(KFLR.GT.0) THEN
12583 WID2=WIDS(37,2)
12584 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
12585 ELSE
12586 WID2=WIDS(37,3)
12587 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
12588 ENDIF
12589 ENDIF
12590 WDTP(0)=WDTP(0)+WDTP(I)
12591 IF(MDME(IDC,1).GT.0) THEN
12592 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12593 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12594 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12595 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12596 ENDIF
12597 150 CONTINUE
12598
12599 ELSEIF(KFLA.EQ.17) THEN
12600C...tau' lepton.
12601 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12602 DO 160 I=1,MDCY(KC,3)
12603 IDC=I+MDCY(KC,2)-1
12604 IF(MDME(IDC,1).LT.0) GOTO 160
12605 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12606 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12607 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
12608 IF(I.EQ.3) THEN
12609C...tau' -> W + nu'_tau.
12610 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12611 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12612 IF(KFLR.GT.0) THEN
12613 WID2=WIDS(24,3)
12614 WID2=WID2*WIDS(18,2)
12615 ELSE
12616 WID2=WIDS(24,2)
12617 WID2=WID2*WIDS(18,3)
12618 ENDIF
12619 ELSEIF(I.EQ.5) THEN
12620C...tau' -> H + nu'_tau.
12621 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12622 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12623 IF(KFLR.GT.0) THEN
12624 WID2=WIDS(37,3)
12625 WID2=WID2*WIDS(18,2)
12626 ELSE
12627 WID2=WIDS(37,2)
12628 WID2=WID2*WIDS(18,3)
12629 ENDIF
12630 ENDIF
12631 WDTP(0)=WDTP(0)+WDTP(I)
12632 IF(MDME(IDC,1).GT.0) THEN
12633 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12634 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12635 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12636 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12637 ENDIF
12638 160 CONTINUE
12639
12640 ELSEIF(KFLA.EQ.18) THEN
12641C...nu'_tau neutrino.
12642 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12643 DO 170 I=1,MDCY(KC,3)
12644 IDC=I+MDCY(KC,2)-1
12645 IF(MDME(IDC,1).LT.0) GOTO 170
12646 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12647 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12648 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
12649 IF(I.EQ.2) THEN
12650C...nu'_tau -> W + tau'.
12651 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12652 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12653 IF(KFLR.GT.0) THEN
12654 WID2=WIDS(24,2)
12655 WID2=WID2*WIDS(17,2)
12656 ELSE
12657 WID2=WIDS(24,3)
12658 WID2=WID2*WIDS(17,3)
12659 ENDIF
12660 ELSEIF(I.EQ.3) THEN
12661C...nu'_tau -> H + tau'.
12662 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12663 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12664 IF(KFLR.GT.0) THEN
12665 WID2=WIDS(37,2)
12666 WID2=WID2*WIDS(17,2)
12667 ELSE
12668 WID2=WIDS(37,3)
12669 WID2=WID2*WIDS(17,3)
12670 ENDIF
12671 ENDIF
12672 WDTP(0)=WDTP(0)+WDTP(I)
12673 IF(MDME(IDC,1).GT.0) THEN
12674 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12675 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12676 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12677 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12678 ENDIF
12679 170 CONTINUE
12680
12681 ELSEIF(KFLA.EQ.21) THEN
12682C...QCD:
12683C***Note that widths are not given in dimensional quantities here.
12684 DO 180 I=1,MDCY(KC,3)
12685 IDC=I+MDCY(KC,2)-1
12686 IF(MDME(IDC,1).LT.0) GOTO 180
12687 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12688 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12689 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
12690 WID2=1D0
12691 IF(I.LE.8) THEN
12692C...QCD -> q + qbar
12693 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12694 IF(I.EQ.6) WID2=WIDS(6,1)
12695 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12696 ENDIF
12697 WDTP(0)=WDTP(0)+WDTP(I)
12698 IF(MDME(IDC,1).GT.0) THEN
12699 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12700 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12701 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12702 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12703 ENDIF
12704 180 CONTINUE
12705
12706 ELSEIF(KFLA.EQ.22) THEN
12707C...QED photon.
12708C***Note that widths are not given in dimensional quantities here.
12709 DO 190 I=1,MDCY(KC,3)
12710 IDC=I+MDCY(KC,2)-1
12711 IF(MDME(IDC,1).LT.0) GOTO 190
12712 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12713 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12714 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
12715 WID2=1D0
12716 IF(I.LE.8) THEN
12717C...QED -> q + qbar.
12718 EF=KCHG(I,1)/3D0
12719 FCOF=3D0*RADC
12720 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12721 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12722 IF(I.EQ.6) WID2=WIDS(6,1)
12723 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12724 ELSEIF(I.LE.12) THEN
12725C...QED -> l+ + l-.
12726 EF=KCHG(9+2*(I-8),1)/3D0
12727 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12728 IF(I.EQ.12) WID2=WIDS(17,1)
12729 ENDIF
12730 WDTP(0)=WDTP(0)+WDTP(I)
12731 IF(MDME(IDC,1).GT.0) THEN
12732 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12733 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12734 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12735 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12736 ENDIF
12737 190 CONTINUE
12738
12739 ELSEIF(KFLA.EQ.23) THEN
12740C...Z0:
12741 ICASE=1
12742 XWC=1D0/(16D0*XW*XW1)
12743 FAC=(AEM*XWC/3D0)*SHR
12744 200 CONTINUE
12745 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
12746 VINT(111)=0D0
12747 VINT(112)=0D0
12748 VINT(114)=0D0
12749 ENDIF
12750 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12751 KFI=IABS(MINT(15))
12752 IF(KFI.GT.20) KFI=IABS(MINT(16))
12753 EI=KCHG(KFI,1)/3D0
12754 AI=SIGN(1D0,EI)
12755 VI=AI-4D0*EI*XWV
12756 SQMZ=PMAS(23,1)**2
12757 HZ=SHR*WDTP(0)
12758 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
12759 IF(MSTP(43).EQ.3) VINT(112)=
12760 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
12761 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12762 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
12763 ENDIF
12764 DO 210 I=1,MDCY(KC,3)
12765 IDC=I+MDCY(KC,2)-1
12766 IF(MDME(IDC,1).LT.0) GOTO 210
12767 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12768 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12769 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
12770 WID2=1D0
12771 IF(I.LE.8) THEN
12772C...Z0 -> q + qbar
12773 EF=KCHG(I,1)/3D0
12774 AF=SIGN(1D0,EF+0.1D0)
12775 VF=AF-4D0*EF*XWV
12776 FCOF=3D0*RADC
12777 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12778 IF(I.EQ.6) WID2=WIDS(6,1)
12779 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12780 ELSEIF(I.LE.16) THEN
12781C...Z0 -> l+ + l-, nu + nubar
12782 EF=KCHG(I+2,1)/3D0
12783 AF=SIGN(1D0,EF+0.1D0)
12784 VF=AF-4D0*EF*XWV
12785 FCOF=1D0
12786 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
12787 ENDIF
12788 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
12789 IF(ICASE.EQ.1) THEN
12790 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
12791 & BE34
12792 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12793 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
12794 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
12795 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
12796 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12797 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
12798 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
12799 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
12800 ENDIF
12801 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
12802 IF(MDME(IDC,1).GT.0) THEN
12803 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
12804 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
12805 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12806 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
12807 & WDTE(I,MDME(IDC,1))
12808 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12809 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12810 ENDIF
12811 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12812 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
12813 & VINT(111)+FGGF*WID2
12814 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
12815 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12816 & VINT(114)+FZZF*WID2
12817 ENDIF
12818 ENDIF
12819 210 CONTINUE
12820 IF(MINT(61).GE.1) ICASE=3-ICASE
12821 IF(ICASE.EQ.2) GOTO 200
12822
12823 ELSEIF(KFLA.EQ.24) THEN
12824C...W+/-:
12825 FAC=(AEM/(24D0*XW))*SHR
12826 DO 220 I=1,MDCY(KC,3)
12827 IDC=I+MDCY(KC,2)-1
12828 IF(MDME(IDC,1).LT.0) GOTO 220
12829 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12830 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12831 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
12832 WID2=1D0
12833 IF(I.LE.16) THEN
12834C...W+/- -> q + qbar'
12835 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
12836 IF(KFLR.GT.0) THEN
12837 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
12838 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
12839 IF(I.GE.13) WID2=WID2*WIDS(7,3)
12840 ELSE
12841 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
12842 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
12843 IF(I.GE.13) WID2=WID2*WIDS(7,2)
12844 ENDIF
12845 ELSEIF(I.LE.20) THEN
12846C...W+/- -> l+/- + nu
12847 FCOF=1D0
12848 IF(KFLR.GT.0) THEN
12849 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
12850 ELSE
12851 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
12852 ENDIF
12853 ENDIF
12854 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
12855 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
12856 WDTP(0)=WDTP(0)+WDTP(I)
12857 IF(MDME(IDC,1).GT.0) THEN
12858 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12859 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12860 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12861 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12862 ENDIF
12863 220 CONTINUE
12864
12865 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12866C...h0 (or H0, or A0):
12867 IF(MSTP(49).EQ.0) THEN
12868 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
12869 ELSE
12870 FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
12871 ENDIF
12872 DO 260 I=1,MDCY(KFHIGG,3)
12873 IDC=I+MDCY(KFHIGG,2)-1
12874 IF(MDME(IDC,1).LT.0) GOTO 260
12875 KFC1=PYCOMP(KFDP(IDC,1))
12876 KFC2=PYCOMP(KFDP(IDC,2))
12877 RM1=PMAS(KFC1,1)**2/SH
12878 RM2=PMAS(KFC2,1)**2/SH
12879 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
12880 & GOTO 260
12881 WID2=1D0
12882
12883 IF(I.LE.8) THEN
12884C...h0 -> q + qbar
12885 WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,
12886 & 1D0-4D0*RM1))*RADC
12887 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)*
12888 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
12889 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
12890 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12891 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
12892 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
12893 ENDIF
12894 IF(I.EQ.6) WID2=WIDS(6,1)
12895 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12896
12897 ELSEIF(I.LE.12) THEN
12898C...h0 -> l+ + l-
12899 WDTP(I)=FAC*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12900 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
12901 & PARU(153+10*IHIGG)**2
12902 IF(I.EQ.12) WID2=WIDS(17,1)
12903
12904 ELSEIF(I.EQ.13) THEN
12905C...h0 -> g + g; quark loop contribution only
12906 ETARE=0D0
12907 ETAIM=0D0
12908 DO 230 J=1,2*MSTP(1)
12909 EPS=(2D0*PMAS(J,1))**2/SH
12910C...Loop integral; function of eps=4m^2/shat; different for A0.
12911 IF(EPS.LE.1D0) THEN
12912 IF(EPS.GT.1.D-4) THEN
12913 ROOT=SQRT(1D0-EPS)
12914 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12915 ELSE
12916 RLN=LOG(4D0/EPS-2D0)
12917 ENDIF
12918 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12919 PHIIM=0.5D0*PARU(1)*RLN
12920 ELSE
12921 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12922 PHIIM=0D0
12923 ENDIF
12924 IF(IHIGG.LE.2) THEN
12925 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12926 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
12927 ELSE
12928 ETAREJ=-0.5D0*EPS*PHIRE
12929 ETAIMJ=-0.5D0*EPS*PHIIM
12930 ENDIF
12931C...Couplings (=1 for standard model Higgs).
12932 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12933 IF(MOD(J,2).EQ.1) THEN
12934 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
12935 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
12936 ELSE
12937 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
12938 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
12939 ENDIF
12940 ENDIF
12941 ETARE=ETARE+ETAREJ
12942 ETAIM=ETAIM+ETAIMJ
12943 230 CONTINUE
12944 ETA2=ETARE**2+ETAIM**2
12945 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
12946
12947 ELSEIF(I.EQ.14) THEN
12948C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
12949 ETARE=0D0
12950 ETAIM=0D0
12951 JMAX=3*MSTP(1)+1
12952 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
12953 DO 240 J=1,JMAX
12954 IF(J.LE.2*MSTP(1)) THEN
12955 EJ=KCHG(J,1)/3D0
12956 EPS=(2D0*PMAS(J,1))**2/SH
12957 ELSEIF(J.LE.3*MSTP(1)) THEN
12958 JL=2*(J-2*MSTP(1))-1
12959 EJ=KCHG(10+JL,1)/3D0
12960 EPS=(2D0*PMAS(10+JL,1))**2/SH
12961 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
12962 EPS=(2D0*PMAS(24,1))**2/SH
12963 ELSE
12964 EPS=(2D0*PMAS(37,1))**2/SH
12965 ENDIF
12966C...Loop integral; function of eps=4m^2/shat.
12967 IF(EPS.LE.1D0) THEN
12968 IF(EPS.GT.1.D-4) THEN
12969 ROOT=SQRT(1D0-EPS)
12970 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12971 ELSE
12972 RLN=LOG(4D0/EPS-2D0)
12973 ENDIF
12974 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12975 PHIIM=0.5D0*PARU(1)*RLN
12976 ELSE
12977 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12978 PHIIM=0D0
12979 ENDIF
12980 IF(J.LE.3*MSTP(1)) THEN
12981C...Fermion loops: loop integral different for A0; charges.
12982 IF(IHIGG.LE.2) THEN
12983 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12984 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
12985 ELSE
12986 PHIPRE=-0.5D0*EPS*PHIRE
12987 PHIPIM=-0.5D0*EPS*PHIIM
12988 ENDIF
12989 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
12990 EJC=3D0*EJ**2
12991 EJH=PARU(151+10*IHIGG)
12992 ELSEIF(J.LE.2*MSTP(1)) THEN
12993 EJC=3D0*EJ**2
12994 EJH=PARU(152+10*IHIGG)
12995 ELSE
12996 EJC=EJ**2
12997 EJH=PARU(153+10*IHIGG)
12998 ENDIF
12999 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13000 ETAREJ=EJC*EJH*PHIPRE
13001 ETAIMJ=EJC*EJH*PHIPIM
13002 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13003C...W loops: loop integral and charges.
13004 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
13005 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
13006 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13007 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13008 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13009 ENDIF
13010 ELSE
13011C...Charged H loops: loop integral and charges.
13012 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
13013 & PARU(158+10*IHIGG+2*(IHIGG/3))
13014 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
13015 ETAIMJ=-EPS**2*PHIIM*FACHHH
13016 ENDIF
13017 ETARE=ETARE+ETAREJ
13018 ETAIM=ETAIM+ETAIMJ
13019 240 CONTINUE
13020 ETA2=ETARE**2+ETAIM**2
13021 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
13022
13023 ELSEIF(I.EQ.15) THEN
13024C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
13025 ETARE=0D0
13026 ETAIM=0D0
13027 JMAX=3*MSTP(1)+1
13028 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13029 DO 250 J=1,JMAX
13030 IF(J.LE.2*MSTP(1)) THEN
13031 EJ=KCHG(J,1)/3D0
13032 AJ=SIGN(1D0,EJ+0.1D0)
13033 VJ=AJ-4D0*EJ*XWV
13034 EPS=(2D0*PMAS(J,1))**2/SH
13035 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
13036 ELSEIF(J.LE.3*MSTP(1)) THEN
13037 JL=2*(J-2*MSTP(1))-1
13038 EJ=KCHG(10+JL,1)/3D0
13039 AJ=SIGN(1D0,EJ+0.1D0)
13040 VJ=AJ-4D0*EJ*XWV
13041 EPS=(2D0*PMAS(10+JL,1))**2/SH
13042 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
13043 ELSE
13044 EPS=(2D0*PMAS(24,1))**2/SH
13045 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
13046 ENDIF
13047C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
13048 IF(EPS.LE.1D0) THEN
13049 ROOT=SQRT(1D0-EPS)
13050 IF(EPS.GT.1.D-4) THEN
13051 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13052 ELSE
13053 RLN=LOG(4D0/EPS-2D0)
13054 ENDIF
13055 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13056 PHIIM=0.5D0*PARU(1)*RLN
13057 PSIRE=0.5D0*ROOT*RLN
13058 PSIIM=-0.5D0*ROOT*PARU(1)
13059 ELSE
13060 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13061 PHIIM=0D0
13062 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
13063 PSIIM=0D0
13064 ENDIF
13065 IF(EPSP.LE.1D0) THEN
13066 ROOT=SQRT(1D0-EPSP)
13067 IF(EPSP.GT.1.D-4) THEN
13068 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13069 ELSE
13070 RLN=LOG(4D0/EPSP-2D0)
13071 ENDIF
13072 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
13073 PHIIMP=0.5D0*PARU(1)*RLN
13074 PSIREP=0.5D0*ROOT*RLN
13075 PSIIMP=-0.5D0*ROOT*PARU(1)
13076 ELSE
13077 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
13078 PHIIMP=0D0
13079 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
13080 PSIIMP=0D0
13081 ENDIF
13082 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
13083 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
13084 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
13085 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
13086 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
13087 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
13088 IF(J.LE.3*MSTP(1)) THEN
13089C...Fermion loops: loop integral different for A0; charges.
13090 IF(IHIGG.EQ.3) FXYRE=0D0
13091 IF(IHIGG.EQ.3) FXYIM=0D0
13092 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13093 EJC=-3D0*EJ*VJ
13094 EJH=PARU(151+10*IHIGG)
13095 ELSEIF(J.LE.2*MSTP(1)) THEN
13096 EJC=-3D0*EJ*VJ
13097 EJH=PARU(152+10*IHIGG)
13098 ELSE
13099 EJC=-EJ*VJ
13100 EJH=PARU(153+10*IHIGG)
13101 ENDIF
13102 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13103 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
13104 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
13105 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13106C...W loops: loop integral and charges.
13107 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
13108 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
13109 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
13110 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13111 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13112 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13113 ENDIF
13114 ELSE
13115C...Charged H loops: loop integral and charges.
13116 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
13117 & PARU(158+10*IHIGG+2*(IHIGG/3))
13118 ETAREJ=FACHHH*FXYRE
13119 ETAIMJ=FACHHH*FXYIM
13120 ENDIF
13121 ETARE=ETARE+ETAREJ
13122 ETAIM=ETAIM+ETAIMJ
13123 250 CONTINUE
13124 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
13125 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
13126 WID2=WIDS(23,2)
13127
13128 ELSEIF(I.LE.17) THEN
13129C...h0 -> Z0 + Z0, W+ + W-
13130 PM1=PMAS(IABS(KFDP(IDC,1)),1)
13131 PG1=PMAS(IABS(KFDP(IDC,1)),2)
13132 IF(MINT(62).GE.1) THEN
13133 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
13134 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
13135 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
13136 MOFSV(IHIGG,I-15)=0
13137 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13138 & 1D0-4D0*RM1))
13139 WID2=1D0
13140 ELSE
13141 MOFSV(IHIGG,I-15)=1
13142 RMAS=SQRT(MAX(0D0,SH))
13143 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
13144 & WID2)
13145 WIDWSV(IHIGG,I-15)=WIDW
13146 WID2SV(IHIGG,I-15)=WID2
13147 ENDIF
13148 ELSE
13149 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
13150 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13151 & 1D0-4D0*RM1))
13152 WID2=1D0
13153 ELSE
13154 WIDW=WIDWSV(IHIGG,I-15)
13155 WID2=WID2SV(IHIGG,I-15)
13156 ENDIF
13157 ENDIF
13158 WDTP(I)=FAC*WIDW/(2D0*(18-I))
13159 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
13160 & PARU(138+I+10*IHIGG)**2
13161 WID2=WID2*WIDS(7+I,1)
13162
13163 ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
13164C***H0 -> Z0 + h0 (not yet implemented).
13165
13166 ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
13167C...H0 -> h0 + h0.
13168 WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
13169 & SQRT(MAX(0D0,1D0-4D0*RM1))
13170 WID2=WIDS(25,2)**2
13171
13172 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
13173C...H0 -> A0 + A0.
13174 WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
13175 & SQRT(MAX(0D0,1D0-4D0*RM1))
13176 WID2=WIDS(36,2)**2
13177
13178 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
13179C...A0 -> Z0 + h0.
13180 WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
13181 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13182 WID2=WIDS(23,2)*WIDS(25,2)
13183
13184CMRENNA++
13185 ELSE
13186C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13187 RM10=RM1*SH/PMR**2
13188 RM20=RM2*SH/PMR**2
13189 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13190 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13191 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13192 WFAC=0D0
13193 ELSE
13194 WFAC=WFAC/WFAC0
13195 ENDIF
13196 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13197CMRENNA--
13198 IF(KFC2.EQ.KFC1) THEN
13199 WID2=WIDS(KFC1,1)
13200 ELSE
13201 KSGN1=2
13202 IF(KFDP(IDC,1).LT.0) KSGN1=3
13203 KSGN2=2
13204 IF(KFDP(IDC,2).LT.0) KSGN2=3
13205 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13206 ENDIF
13207 ENDIF
13208 WDTP(0)=WDTP(0)+WDTP(I)
13209 IF(MDME(IDC,1).GT.0) THEN
13210 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13211 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13212 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13213 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13214 ENDIF
13215 260 CONTINUE
13216
13217 ELSEIF(KFLA.EQ.32) THEN
13218C...Z'0:
13219 ICASE=1
13220 XWC=1D0/(16D0*XW*XW1)
13221 FAC=(AEM*XWC/3D0)*SHR
13222 VINT(117)=0D0
13223 270 CONTINUE
13224 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
13225 VINT(111)=0D0
13226 VINT(112)=0D0
13227 VINT(113)=0D0
13228 VINT(114)=0D0
13229 VINT(115)=0D0
13230 VINT(116)=0D0
13231 ENDIF
13232 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13233 KFAI=IABS(MINT(15))
13234 EI=KCHG(KFAI,1)/3D0
13235 AI=SIGN(1D0,EI+0.1D0)
13236 VI=AI-4D0*EI*XWV
13237 KFAIC=1
13238 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13239 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13240 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13241 VPI=PARU(119+2*KFAIC)
13242 API=PARU(120+2*KFAIC)
13243 SQMZ=PMAS(23,1)**2
13244 HZ=SHR*FAC*VINT(117)
13245 SQMZP=PMAS(32,1)**2
13246 HZP=SHR*FAC*WDTP(0)
13247 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13248 & MSTP(44).EQ.7) VINT(111)=1D0
13249 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
13250 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
13251 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
13252 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
13253 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13254 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
13255 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
13256 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
13257 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
13258 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13259 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
13260 ENDIF
13261 DO 280 I=1,MDCY(KC,3)
13262 IDC=I+MDCY(KC,2)-1
13263 IF(MDME(IDC,1).LT.0) GOTO 280
13264 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13265 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13266 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
13267 WID2=1D0
13268 IF(I.LE.16) THEN
13269 IF(I.LE.8) THEN
13270C...Z'0 -> q + qbar
13271 EF=KCHG(I,1)/3D0
13272 AF=SIGN(1D0,EF+0.1D0)
13273 VF=AF-4D0*EF*XWV
13274 VPF=PARU(123-2*MOD(I,2))
13275 APF=PARU(124-2*MOD(I,2))
13276 FCOF=3D0*RADC
13277 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
13278 & PYHFTH(SH,SH*RM1,1D0)
13279 IF(I.EQ.6) WID2=WIDS(6,1)
13280 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
13281 ELSEIF(I.LE.16) THEN
13282C...Z'0 -> l+ + l-, nu + nubar
13283 EF=KCHG(I+2,1)/3D0
13284 AF=SIGN(1D0,EF+0.1D0)
13285 VF=AF-4D0*EF*XWV
13286 VPF=PARU(127-2*MOD(I,2))
13287 APF=PARU(128-2*MOD(I,2))
13288 FCOF=1D0
13289 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
13290 ENDIF
13291 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
13292 IF(ICASE.EQ.1) THEN
13293 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13294 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
13295 & APF**2*(1D0-4D0*RM1))*BE34
13296 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13297 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
13298 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13299 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
13300 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
13301 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
13302 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
13303 ELSEIF(MINT(61).EQ.2) THEN
13304 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
13305 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
13306 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
13307 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13308 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
13309 & BE34
13310 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
13311 & BE34
13312 ENDIF
13313 ELSEIF(I.EQ.17) THEN
13314C...Z'0 -> W+ + W-
13315 WDTPZP=PARU(129)**2*XW1**2*
13316 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13317 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13318 IF(ICASE.EQ.1) THEN
13319 WDTPZ=0D0
13320 WDTP(I)=FAC*WDTPZP
13321 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13322 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13323 ELSEIF(MINT(61).EQ.2) THEN
13324 FGGF=0D0
13325 FGZF=0D0
13326 FGZPF=0D0
13327 FZZF=0D0
13328 FZZPF=0D0
13329 FZPZPF=WDTPZP
13330 ENDIF
13331 WID2=WIDS(24,1)
13332 ELSEIF(I.EQ.18) THEN
13333C...Z'0 -> H+ + H-
13334 CZC=2D0*(1D0-2D0*XW)
13335 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
13336 IF(ICASE.EQ.1) THEN
13337 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
13338 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
13339 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13340 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
13341 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
13342 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
13343 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
13344 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
13345 ELSEIF(MINT(61).EQ.2) THEN
13346 FGGF=0.25D0*BE34C
13347 FGZF=0.25D0*PARU(142)*CZC*BE34C
13348 FGZPF=0.25D0*PARU(143)*CZC*BE34C
13349 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
13350 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
13351 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
13352 ENDIF
13353 WID2=WIDS(37,1)
13354 ELSEIF(I.EQ.19) THEN
13355C...Z'0 -> Z0 + gamma.
13356 ELSEIF(I.EQ.20) THEN
13357C...Z'0 -> Z0 + h0
13358 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13359 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
13360 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
13361 IF(ICASE.EQ.1) THEN
13362 WDTPZ=0D0
13363 WDTP(I)=FAC*WDTPZP
13364 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13365 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13366 ELSEIF(MINT(61).EQ.2) THEN
13367 FGGF=0D0
13368 FGZF=0D0
13369 FGZPF=0D0
13370 FZZF=0D0
13371 FZZPF=0D0
13372 FZPZPF=WDTPZP
13373 ENDIF
13374 WID2=WIDS(23,2)*WIDS(25,2)
13375 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
13376C...Z' -> h0 + A0 or H0 + A0.
13377 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13378 IF(I.EQ.21) THEN
13379 CZAH=PARU(186)
13380 CZPAH=PARU(188)
13381 ELSE
13382 CZAH=PARU(187)
13383 CZPAH=PARU(189)
13384 ENDIF
13385 IF(ICASE.EQ.1) THEN
13386 WDTPZ=CZAH**2*BE34C
13387 WDTP(I)=FAC*CZPAH**2*BE34C
13388 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13389 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
13390 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
13391 & VINT(116))*BE34C
13392 ELSEIF(MINT(61).EQ.2) THEN
13393 FGGF=0D0
13394 FGZF=0D0
13395 FGZPF=0D0
13396 FZZF=CZAH**2*BE34C
13397 FZZPF=CZAH*CZPAH*BE34C
13398 FZPZPF=CZPAH**2*BE34C
13399 ENDIF
13400 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
13401 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
13402 ENDIF
13403 IF(ICASE.EQ.1) THEN
13404 VINT(117)=VINT(117)+WDTPZ
13405 WDTP(0)=WDTP(0)+WDTP(I)
13406 ENDIF
13407 IF(MDME(IDC,1).GT.0) THEN
13408 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
13409 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
13410 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13411 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
13412 & WDTE(I,MDME(IDC,1))
13413 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13414 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13415 ENDIF
13416 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
13417 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13418 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
13419 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
13420 & FGZF*WID2
13421 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
13422 & FGZPF*WID2
13423 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13424 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
13425 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
13426 & FZZPF*WID2
13427 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13428 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
13429 ENDIF
13430 ENDIF
13431 280 CONTINUE
13432 IF(MINT(61).GE.1) ICASE=3-ICASE
13433 IF(ICASE.EQ.2) GOTO 270
13434
13435 ELSEIF(KFLA.EQ.34) THEN
13436C...W'+/-:
13437 FAC=(AEM/(24D0*XW))*SHR
13438 DO 290 I=1,MDCY(KC,3)
13439 IDC=I+MDCY(KC,2)-1
13440 IF(MDME(IDC,1).LT.0) GOTO 290
13441 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13442 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13443 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
13444 WID2=1D0
13445 IF(I.LE.20) THEN
13446 IF(I.LE.16) THEN
13447C...W'+/- -> q + qbar'
13448 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
13449 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
13450 IF(KFLR.GT.0) THEN
13451 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
13452 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
13453 IF(I.GE.13) WID2=WID2*WIDS(7,3)
13454 ELSE
13455 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
13456 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
13457 IF(I.GE.13) WID2=WID2*WIDS(7,2)
13458 ENDIF
13459 ELSEIF(I.LE.20) THEN
13460C...W'+/- -> l+/- + nu
13461 FCOF=PARU(133)**2+PARU(134)**2
13462 IF(KFLR.GT.0) THEN
13463 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13464 ELSE
13465 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13466 ENDIF
13467 ENDIF
13468 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13469 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13470 ELSEIF(I.EQ.21) THEN
13471C...W'+/- -> W+/- + Z0
13472 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
13473 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13474 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13475 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
13476 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
13477 ELSEIF(I.EQ.23) THEN
13478C...W'+/- -> W+/- + h0
13479 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13480 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
13481 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13482 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13483 ENDIF
13484 WDTP(0)=WDTP(0)+WDTP(I)
13485 IF(MDME(IDC,1).GT.0) THEN
13486 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13487 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13488 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13489 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13490 ENDIF
13491 290 CONTINUE
13492
13493 ELSEIF(KFLA.EQ.37) THEN
13494C...H+/-:
13495 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
13496 DO 300 I=1,MDCY(KC,3)
13497 IDC=I+MDCY(KC,2)-1
13498 IF(MDME(IDC,1).LT.0) GOTO 300
13499 KFC1=PYCOMP(KFDP(IDC,1))
13500 KFC2=PYCOMP(KFDP(IDC,2))
13501 RM1=PMAS(KFC1,1)**2/SH
13502 RM2=PMAS(KFC2,1)**2/SH
13503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
13504 WID2=1D0
13505 IF(I.LE.4) THEN
13506C...H+/- -> q + qbar'
13507 RM1R=RM1
13508 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1*
13509 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
13510 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
13511 WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)*
13512 & (1D0-RM1R-RM2)-4D0*RM1R*RM2)*
13513 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13514 IF(KFLR.GT.0) THEN
13515 IF(I.EQ.3) WID2=WIDS(6,2)
13516 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
13517 ELSE
13518 IF(I.EQ.3) WID2=WIDS(6,3)
13519 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
13520 ENDIF
13521 ELSEIF(I.LE.8) THEN
13522C...H+/- -> l+/- + nu
13523 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
13524 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-
13525 & 4D0*RM1*RM2))
13526 IF(KFLR.GT.0) THEN
13527 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
13528 ELSE
13529 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
13530 ENDIF
13531 ELSEIF(I.EQ.9) THEN
13532C...H+/- -> W+/- + h0.
13533 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
13534 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13535 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13536 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13537
13538CMRENNA++
13539 ELSE
13540C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13541 RM10=RM1*SH/PMR**2
13542 RM20=RM2*SH/PMR**2
13543 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13544 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13545 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13546 WFAC=0D0
13547 ELSE
13548 WFAC=WFAC/WFAC0
13549 ENDIF
13550 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13551CMRENNA--
13552 KSGN1=2
13553 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
13554 KSGN2=2
13555 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
13556 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13557 ENDIF
13558 WDTP(0)=WDTP(0)+WDTP(I)
13559 IF(MDME(IDC,1).GT.0) THEN
13560 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13561 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13562 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13563 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13564 ENDIF
13565 300 CONTINUE
13566
13567 ELSEIF(KFLA.EQ.38) THEN
13568C...Techni-eta.
13569 FAC=(SH/PARP(46)**2)*SHR
13570 DO 310 I=1,MDCY(KC,3)
13571 IDC=I+MDCY(KC,2)-1
13572 IF(MDME(IDC,1).LT.0) GOTO 310
13573 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13574 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13575 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
13576 WID2=1D0
13577 IF(I.LE.2) THEN
13578 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
13579 IF(I.EQ.2) WID2=WIDS(6,1)
13580 ELSE
13581 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
13582 ENDIF
13583 WDTP(0)=WDTP(0)+WDTP(I)
13584 IF(MDME(IDC,1).GT.0) THEN
13585 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13586 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13587 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13588 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13589 ENDIF
13590 310 CONTINUE
13591
13592 ELSEIF(KFLA.EQ.39) THEN
13593C...LQ (leptoquark).
13594 FAC=(AEM/4D0)*PARU(151)*SHR
13595 DO 320 I=1,MDCY(KC,3)
13596 IDC=I+MDCY(KC,2)-1
13597 IF(MDME(IDC,1).LT.0) GOTO 320
13598 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13599 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13600 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
13601 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13602 WID2=1D0
13603 WDTP(0)=WDTP(0)+WDTP(I)
13604 IF(MDME(IDC,1).GT.0) THEN
13605 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13606 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13607 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13608 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13609 ENDIF
13610 320 CONTINUE
13611
13612 ELSEIF(KFLA.EQ.40) THEN
13613C...R:
13614 FAC=(AEM/(12D0*XW))*SHR
13615 DO 330 I=1,MDCY(KC,3)
13616 IDC=I+MDCY(KC,2)-1
13617 IF(MDME(IDC,1).LT.0) GOTO 330
13618 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13619 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13620 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
13621 WID2=1D0
13622 IF(I.LE.6) THEN
13623C...R -> q + qbar'
13624 FCOF=3D0*RADC
13625 ELSEIF(I.LE.9) THEN
13626C...R -> l+ + l'-
13627 FCOF=1D0
13628 ENDIF
13629 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
13630 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13631 IF(KFLR.GT.0) THEN
13632 IF(I.EQ.4) WID2=WIDS(6,3)
13633 IF(I.EQ.5) WID2=WIDS(7,3)
13634 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
13635 IF(I.EQ.9) WID2=WIDS(17,3)
13636 ELSE
13637 IF(I.EQ.4) WID2=WIDS(6,2)
13638 IF(I.EQ.5) WID2=WIDS(7,2)
13639 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
13640 IF(I.EQ.9) WID2=WIDS(17,2)
13641 ENDIF
13642 WDTP(0)=WDTP(0)+WDTP(I)
13643 IF(MDME(IDC,1).GT.0) THEN
13644 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13645 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13646 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13647 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13648 ENDIF
13649 330 CONTINUE
13650
13651 ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.52) THEN
13652C...Techni-pi0 and techni-pi+-:
13653 FAC=(3D0/(32D0*PARU(1)*PARP(142)**2))*SHR
13654 DO 340 I=1,MDCY(KC,3)
13655 IDC=I+MDCY(KC,2)-1
13656 IF(MDME(IDC,1).LT.0) GOTO 340
13657 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
13658 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
13659 RM1=PM1**2/SH
13660 RM2=PM2**2/SH
13661 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
13662 WID2=1D0
13663C...pi_tech -> f + f'.
13664 FCOF=1D0
13665 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
13666 WDTP(I)=FAC*FCOF*(PM1+PM2)**2*
13667 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13668 WDTP(0)=WDTP(0)+WDTP(I)
13669 IF(MDME(IDC,1).GT.0) THEN
13670 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13671 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13672 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13673 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13674 ENDIF
13675 340 CONTINUE
13676
13677 ELSEIF(KFLA.EQ.53) THEN
13678C...Techni-pi'0 not yet implemented.
13679
13680 ELSEIF(KFLA.EQ.54) THEN
13681C...Techni-rho0:
13682 ALPRHT=2.91D0*(3D0/PARP(144))
13683 FAC=(ALPRHT/12D0)*SHR
13684 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)
13685 SQMZ=PMAS(23,1)**2
13686 GMMZ=PMAS(23,1)*PMAS(23,2)
13687 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13688 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13689 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13690 DO 350 I=1,MDCY(KC,3)
13691 IDC=I+MDCY(KC,2)-1
13692 IF(MDME(IDC,1).LT.0) GOTO 350
13693 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13694 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13695 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 350
13696 IF(I.EQ.1) THEN
13697C...rho_tech0 -> W+ + W-.
13698 WDTP(I)=FAC*PARP(141)**4*
13699 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13700 WID2=WIDS(24,1)
13701 ELSEIF(I.EQ.2) THEN
13702C...rho_tech0 -> W+ + pi_tech-.
13703 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13704 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13705 WID2=WIDS(24,2)*WIDS(52,3)
13706 ELSEIF(I.EQ.3) THEN
13707C...rho_tech0 -> pi_tech+ + W-.
13708 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13709 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13710 WID2=WIDS(52,2)*WIDS(24,3)
13711 ELSEIF(I.EQ.4) THEN
13712C...rho_tech0 -> pi_tech+ + pi_tech-.
13713 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13714 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13715 WID2=WIDS(52,1)
13716 ELSE
13717C...rho_tech0 -> f + fbar.
13718 WID2=1D0
13719 IF(I.LE.12) THEN
13720 IA=I-4
13721 FCOF=3D0*RADC
13722 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13723 ELSE
13724 IA=I-2
13725 FCOF=1D0
13726 IF(IA.GE.17) WID2=WIDS(IA,1)
13727 ENDIF
13728 EI=KCHG(IA,1)/3D0
13729 AI=SIGN(1D0,EI+0.1D0)
13730 VI=AI-4D0*EI*XWV
13731 VALI=0.5D0*(VI+AI)
13732 VARI=0.5D0*(VI-AI)
13733 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13734 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
13735 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
13736 ENDIF
13737 WDTP(0)=WDTP(0)+WDTP(I)
13738 IF(MDME(IDC,1).GT.0) THEN
13739 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13740 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13741 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13742 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13743 ENDIF
13744 350 CONTINUE
13745
13746 ELSEIF(KFLA.EQ.55) THEN
13747C...Techni-rho+/-:
13748 ALPRHT=2.91D0*(3D0/PARP(144))
13749 FAC=(ALPRHT/12D0)*SHR
13750 SQMW=PMAS(24,1)**2
13751 GMMW=PMAS(24,1)*PMAS(24,2)
13752 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13753 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
13754 DO 360 I=1,MDCY(KC,3)
13755 IDC=I+MDCY(KC,2)-1
13756 IF(MDME(IDC,1).LT.0) GOTO 360
13757 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13758 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13759 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
13760 IF(I.EQ.1) THEN
13761C...rho_tech+ -> W+ + Z0.
13762 WDTP(I)=FAC*PARP(141)**4*
13763 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13764 IF(KFLR.GT.0) THEN
13765 WID2=WIDS(24,2)*WIDS(23,2)
13766 ELSE
13767 WID2=WIDS(24,3)*WIDS(23,2)
13768 ENDIF
13769 ELSEIF(I.EQ.2) THEN
13770C...rho_tech+ -> W+ + pi_tech0.
13771 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13772 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13773 IF(KFLR.GT.0) THEN
13774 WID2=WIDS(24,2)*WIDS(51,2)
13775 ELSE
13776 WID2=WIDS(24,3)*WIDS(51,2)
13777 ENDIF
13778 ELSEIF(I.EQ.3) THEN
13779C...rho_tech+ -> pi_tech+ + Z0.
13780 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13781 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13782 IF(KFLR.GT.0) THEN
13783 WID2=WIDS(52,2)*WIDS(23,2)
13784 ELSE
13785 WID2=WIDS(52,3)*WIDS(23,2)
13786 ENDIF
13787 ELSEIF(I.EQ.4) THEN
13788C...rho_tech+ -> pi_tech+ + pi_tech0.
13789 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13790 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13791 IF(KFLR.GT.0) THEN
13792 WID2=WIDS(52,2)*WIDS(51,2)
13793 ELSE
13794 WID2=WIDS(52,3)*WIDS(51,2)
13795 ENDIF
13796 ELSE
13797C...rho_tech+ -> f + fbar'.
13798 IA=I-4
13799 WID2=1D0
13800 IF(IA.LE.16) THEN
13801 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
13802 IF(KFLR.GT.0) THEN
13803 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
13804 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
13805 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
13806 ELSE
13807 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
13808 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
13809 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
13810 ENDIF
13811 ELSE
13812 FCOF=1D0
13813 IF(KFLR.GT.0) THEN
13814 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13815 ELSE
13816 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13817 ENDIF
13818 ENDIF
13819 WDTP(I)=FACF*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13820 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13821 ENDIF
13822 WDTP(0)=WDTP(0)+WDTP(I)
13823 IF(MDME(IDC,1).GT.0) THEN
13824 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13825 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13826 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13827 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13828 ENDIF
13829 360 CONTINUE
13830
13831 ELSEIF(KFLA.EQ.56) THEN
13832C...Techni-omega:
13833 ALPRHT=2.91D0*(3D0/PARP(144))
13834 FAC=(AEM/24D0)*(SHR**3/PARP(145)**2)
13835 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13836 & (2D0*PARP(143)-1D0)**2
13837 SQMZ=PMAS(23,1)**2
13838 GMMZ=PMAS(23,1)*PMAS(23,2)
13839 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13840 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13841 DO 370 I=1,MDCY(KC,3)
13842 IDC=I+MDCY(KC,2)-1
13843 IF(MDME(IDC,1).LT.0) GOTO 370
13844 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13845 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13846 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
13847 IF(I.EQ.1) THEN
13848C...omega_tech0 -> gamma + pi_tech0.
13849 WDTP(I)=FAC*
13850 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13851 WID2=WIDS(51,2)
13852 ELSEIF(I.EQ.2) THEN
13853C...omega_tech0 -> Z0 + pi_tech0 not known.
13854 WDTP(I)=0D0
13855 WID2=WIDS(23,2)*WIDS(51,2)
13856 ELSE
13857C...omega_tech0 -> f + fbar.
13858 WID2=1D0
13859 IF(I.LE.10) THEN
13860 IA=I-2
13861 FCOF=3D0*RADC
13862 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13863 ELSE
13864 IA=I
13865 FCOF=1D0
13866 IF(IA.GE.17) WID2=WIDS(IA,1)
13867 ENDIF
13868 EI=KCHG(IA,1)/3D0
13869 AI=SIGN(1D0,EI+0.1D0)
13870 VI=AI-4D0*EI*XWV
13871 VALI=0.5D0*(VI+AI)
13872 VARI=0.5D0*(VI-AI)
13873 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13874 & ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
13875 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
13876 ENDIF
13877 WDTP(0)=WDTP(0)+WDTP(I)
13878 IF(MDME(IDC,1).GT.0) THEN
13879 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13880 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13881 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13882 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13883 ENDIF
13884 370 CONTINUE
13885
13886 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
13887C...d* excited quark.
13888 FAC=(SH/PARU(155)**2)*SHR
13889 DO 380 I=1,MDCY(KC,3)
13890 IDC=I+MDCY(KC,2)-1
13891 IF(MDME(IDC,1).LT.0) GOTO 380
13892 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13893 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13894 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
13895 IF(I.EQ.1) THEN
13896C...d* -> g + d.
13897 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13898 WID2=1D0
13899 ELSEIF(I.EQ.2) THEN
13900C...d* -> gamma + d.
13901 QF=-PARU(157)/2D0+PARU(158)/6D0
13902 WDTP(I)=FAC*AEM*QF**2/4D0
13903 WID2=1D0
13904 ELSEIF(I.EQ.3) THEN
13905C...d* -> Z0 + d.
13906 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13907 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13908 & (1D0-RM1)**2*(2D0+RM1)
13909 WID2=WIDS(23,2)
13910 ELSEIF(I.EQ.4) THEN
13911C...d* -> W- + u.
13912 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13913 & (1D0-RM1)**2*(2D0+RM1)
13914 IF(KFLR.GT.0) WID2=WIDS(24,3)
13915 IF(KFLR.LT.0) WID2=WIDS(24,2)
13916 ENDIF
13917 WDTP(0)=WDTP(0)+WDTP(I)
13918 IF(MDME(IDC,1).GT.0) THEN
13919 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13920 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13921 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13922 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13923 ENDIF
13924 380 CONTINUE
13925
13926 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
13927C...u* excited quark.
13928 FAC=(SH/PARU(155)**2)*SHR
13929 DO 390 I=1,MDCY(KC,3)
13930 IDC=I+MDCY(KC,2)-1
13931 IF(MDME(IDC,1).LT.0) GOTO 390
13932 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13933 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13934 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
13935 IF(I.EQ.1) THEN
13936C...u* -> g + u.
13937 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13938 WID2=1D0
13939 ELSEIF(I.EQ.2) THEN
13940C...u* -> gamma + u.
13941 QF=PARU(157)/2D0+PARU(158)/6D0
13942 WDTP(I)=FAC*AEM*QF**2/4D0
13943 WID2=1D0
13944 ELSEIF(I.EQ.3) THEN
13945C...u* -> Z0 + u.
13946 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13947 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13948 & (1D0-RM1)**2*(2D0+RM1)
13949 WID2=WIDS(23,2)
13950 ELSEIF(I.EQ.4) THEN
13951C...u* -> W+ + d.
13952 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13953 & (1D0-RM1)**2*(2D0+RM1)
13954 IF(KFLR.GT.0) WID2=WIDS(24,2)
13955 IF(KFLR.LT.0) WID2=WIDS(24,3)
13956 ENDIF
13957 WDTP(0)=WDTP(0)+WDTP(I)
13958 IF(MDME(IDC,1).GT.0) THEN
13959 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13960 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13961 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13962 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13963 ENDIF
13964 390 CONTINUE
13965
13966 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
13967C...e* excited lepton.
13968 FAC=(SH/PARU(155)**2)*SHR
13969 DO 400 I=1,MDCY(KC,3)
13970 IDC=I+MDCY(KC,2)-1
13971 IF(MDME(IDC,1).LT.0) GOTO 400
13972 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13973 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13974 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
13975 IF(I.EQ.1) THEN
13976C...e* -> gamma + e.
13977 QF=-PARU(157)/2D0-PARU(158)/2D0
13978 WDTP(I)=FAC*AEM*QF**2/4D0
13979 WID2=1D0
13980 ELSEIF(I.EQ.2) THEN
13981C...e* -> Z0 + e.
13982 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
13983 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13984 & (1D0-RM1)**2*(2D0+RM1)
13985 WID2=WIDS(23,2)
13986 ELSEIF(I.EQ.3) THEN
13987C...e* -> W- + nu.
13988 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13989 & (1D0-RM1)**2*(2D0+RM1)
13990 IF(KFLR.GT.0) WID2=WIDS(24,3)
13991 IF(KFLR.LT.0) WID2=WIDS(24,2)
13992 ENDIF
13993 WDTP(0)=WDTP(0)+WDTP(I)
13994 IF(MDME(IDC,1).GT.0) THEN
13995 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13996 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13997 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13998 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13999 ENDIF
14000 400 CONTINUE
14001
14002 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
14003C...nu*_e excited neutrino.
14004 FAC=(SH/PARU(155)**2)*SHR
14005 DO 410 I=1,MDCY(KC,3)
14006 IDC=I+MDCY(KC,2)-1
14007 IF(MDME(IDC,1).LT.0) GOTO 410
14008 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14009 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14010 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
14011 IF(I.EQ.1) THEN
14012C...nu*_e -> Z0 + nu*_e.
14013 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14014 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14015 & (1D0-RM1)**2*(2D0+RM1)
14016 WID2=WIDS(23,2)
14017 ELSEIF(I.EQ.2) THEN
14018C...nu*_e -> W+ + e.
14019 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14020 & (1D0-RM1)**2*(2D0+RM1)
14021 IF(KFLR.GT.0) WID2=WIDS(24,2)
14022 IF(KFLR.LT.0) WID2=WIDS(24,3)
14023 ENDIF
14024 WDTP(0)=WDTP(0)+WDTP(I)
14025 IF(MDME(IDC,1).GT.0) THEN
14026 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14027 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14028 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14029 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14030 ENDIF
14031 410 CONTINUE
14032
14033 ENDIF
14034 MINT(61)=0
14035 MINT(62)=0
14036 MINT(63)=0
14037
14038 RETURN
14039 END
14040
14041C***********************************************************************
14042
14043C...PYOFSH
14044C...Calculates partial width and differential cross-section maxima
14045C...of channels/processes not allowed on mass-shell, and selects
14046C...masses in such channels/processes.
14047
14048 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
14049
14050C...Double precision and integer declarations.
14051 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14052 INTEGER PYK,PYCHGE,PYCOMP
14053C...Commonblocks.
14054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14055 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14056 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14057 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14058 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14059 COMMON/PYINT1/MINT(400),VINT(400)
14060 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14061 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14062 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14063 &/PYINT2/,/PYINT5/
14064C...Local arrays.
14065 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
14066 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
14067 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
14068 &WDTE(0:200,0:5)
14069
14070C...Find if particles equal, maximum mass, matrix elements, etc.
14071 MINT(51)=0
14072 ISUB=MINT(1)
14073 KFD(1)=IABS(KFD1)
14074 KFD(2)=IABS(KFD2)
14075 MEQL=0
14076 IF(KFD(1).EQ.KFD(2)) MEQL=1
14077 MLM=0
14078 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
14079 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
14080 NOFF=44
14081 PMMX=PMMO
14082 ELSE
14083 NOFF=40
14084 PMMX=VINT(1)
14085 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
14086 ENDIF
14087 MMED=0
14088 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
14089 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
14090 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
14091 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
14092 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
14093 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
14094 LOOP=1
14095
14096C...Find where Breit-Wigners are required, else select discrete masses.
14097 100 DO 110 I=1,2
14098 KFCA=PYCOMP(KFD(I))
14099 IF(KFCA.GT.0) THEN
14100 PMD(I)=PMAS(KFCA,1)
14101 PGD(I)=PMAS(KFCA,2)
14102 ELSE
14103 PMD(I)=0D0
14104 PGD(I)=0D0
14105 ENDIF
14106 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
14107 MBW(I)=0
14108 PMG(I)=PMD(I)
14109 RMG(I)=(PMG(I)/PMMX)**2
14110 ELSE
14111 MBW(I)=1
14112 ENDIF
14113 110 CONTINUE
14114
14115C...Find allowed mass range and Breit-Wigner parameters.
14116 DO 120 I=1,2
14117 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
14118 PML(I)=PARP(42)
14119 PMU(I)=PMMX-PARP(42)
14120 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14121 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14122 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
14123 ILM=I
14124 IF(MLM.EQ.2) ILM=3-I
14125 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
14126 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
14127 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I),
14128 & CKIN(NOFF+2*ILM))
14129 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14130 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14131 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14132 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14133 IF(MBW(I).EQ.1) THEN
14134 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14135 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14136 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14137 & PGD(I)))
14138 ENDIF
14139 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
14140 ILM=I
14141 IF(MLM.EQ.2) ILM=3-I
14142 PML(I)=MAX(CKIN(48+I),PARP(42))
14143 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
14144 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14145 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14146 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14147 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14148 IF(MBW(I).EQ.1) THEN
14149 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14150 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14151 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14152 & PGD(I)))
14153 ENDIF
14154 ENDIF
14155 120 CONTINUE
14156 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
14157 &THEN
14158 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
14159 MINT(51)=1
14160 RETURN
14161 ENDIF
14162
14163C...Calculation of partial width of resonance.
14164 IF(MOFSH.EQ.1) THEN
14165
14166C..If only one integration, pick that to be the inner.
14167 IF(MBW(1).EQ.0) THEN
14168 PM2=PMD(1)
14169 PMD(1)=PMD(2)
14170 PGD(1)=PGD(2)
14171 PML(1)=PML(2)
14172 PMU(1)=PMU(2)
14173 ELSEIF(MBW(2).EQ.0) THEN
14174 PM2=PMD(2)
14175 ENDIF
14176
14177C...Start outer loop of integration.
14178 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14179 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14180 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14181 NPT2=1
14182 XPT2(1)=1D0
14183 INX2(1)=0
14184 FMAX2=0D0
14185 ENDIF
14186 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14187 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
14188 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
14189 ENDIF
14190 RM2=(PM2/PMMX)**2
14191
14192C...Start inner loop of integration.
14193 PML1=PML(1)
14194 PMU1=MIN(PMU(1),PMMX-PM2)
14195 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
14196 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14197 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14198 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
14199 FUNC2=0D0
14200 GOTO 180
14201 ENDIF
14202 NPT1=1
14203 XPT1(1)=1D0
14204 INX1(1)=0
14205 FMAX1=0D0
14206 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
14207 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
14208 RM1=(PM1/PMMX)**2
14209
14210C...Evaluate function value - inner loop.
14211 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14212 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
14213 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
14214 & RM2**2+10D0*RM1*RM2)
14215 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
14216 FPT1(NPT1)=FUNC1
14217
14218C...Go to next position in inner loop.
14219 IF(NPT1.EQ.1) THEN
14220 NPT1=NPT1+1
14221 XPT1(NPT1)=0D0
14222 INX1(NPT1)=1
14223 GOTO 140
14224 ELSEIF(NPT1.LE.8) THEN
14225 NPT1=NPT1+1
14226 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
14227 ISH1=ISH1+1
14228 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14229 INX1(NPT1)=INX1(ISH1)
14230 INX1(ISH1)=NPT1
14231 GOTO 140
14232 ELSEIF(NPT1.LT.100) THEN
14233 ISN1=ISH1
14234 150 ISH1=ISH1+1
14235 IF(ISH1.GT.NPT1) ISH1=2
14236 IF(ISH1.EQ.ISN1) GOTO 160
14237 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
14238 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
14239 NPT1=NPT1+1
14240 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14241 INX1(NPT1)=INX1(ISH1)
14242 INX1(ISH1)=NPT1
14243 GOTO 140
14244 ENDIF
14245
14246C...Calculate integral over inner loop.
14247 160 FSUM1=0D0
14248 DO 170 IPT1=2,NPT1
14249 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
14250 & (XPT1(INX1(IPT1))-XPT1(IPT1))
14251 170 CONTINUE
14252 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
14253 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14254 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
14255 FPT2(NPT2)=FUNC2
14256
14257C...Go to next position in outer loop.
14258 IF(NPT2.EQ.1) THEN
14259 NPT2=NPT2+1
14260 XPT2(NPT2)=0D0
14261 INX2(NPT2)=1
14262 GOTO 130
14263 ELSEIF(NPT2.LE.8) THEN
14264 NPT2=NPT2+1
14265 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
14266 ISH2=ISH2+1
14267 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14268 INX2(NPT2)=INX2(ISH2)
14269 INX2(ISH2)=NPT2
14270 GOTO 130
14271 ELSEIF(NPT2.LT.100) THEN
14272 ISN2=ISH2
14273 190 ISH2=ISH2+1
14274 IF(ISH2.GT.NPT2) ISH2=2
14275 IF(ISH2.EQ.ISN2) GOTO 200
14276 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
14277 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
14278 NPT2=NPT2+1
14279 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14280 INX2(NPT2)=INX2(ISH2)
14281 INX2(ISH2)=NPT2
14282 GOTO 130
14283 ENDIF
14284
14285C...Calculate integral over outer loop.
14286 200 FSUM2=0D0
14287 DO 210 IPT2=2,NPT2
14288 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
14289 & (XPT2(INX2(IPT2))-XPT2(IPT2))
14290 210 CONTINUE
14291 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
14292 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
14293 ELSE
14294 FSUM2=FUNC2
14295 ENDIF
14296
14297C...Save result; second integration for user-selected mass range.
14298 IF(LOOP.EQ.1) WIDW=FSUM2
14299 WID2=FSUM2
14300 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
14301 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
14302 LOOP=2
14303 GOTO 100
14304 ENDIF
14305 RET1=WIDW
14306 RET2=WID2/WIDW
14307
14308C...Select two decay product masses of a resonance.
14309 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
14310 220 DO 230 I=1,2
14311 IF(MBW(I).EQ.0) GOTO 230
14312 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
14313 & (ATU(I)-ATL(I)))
14314 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
14315 RMG(I)=(PMG(I)/PMMX)**2
14316 230 CONTINUE
14317 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14318 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
14319
14320C...Weight with matrix element (if none known, use beta factor).
14321 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
14322 IF(MMED.EQ.1) THEN
14323 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
14324 ELSEIF(MMED.EQ.2) THEN
14325 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
14326 & RMG(2)**2+10D0*RMG(1)*RMG(2))
14327 ELSEIF(MMED.EQ.3) THEN
14328 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
14329 ELSE
14330 WTBE=FLAM
14331 ENDIF
14332 IF(WTBE.LT.PYR(0)) GOTO 220
14333 RET1=PMG(1)
14334 RET2=PMG(2)
14335
14336C...Find suitable set of masses for initialization of 2 -> 2 processes.
14337 ELSEIF(MOFSH.EQ.3) THEN
14338 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
14339 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
14340 PMG(2)=PMD(2)
14341 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
14342 PMG(1)=PMD(1)
14343 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
14344 ELSE
14345 IDIV=-1
14346 240 IDIV=IDIV+1
14347 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
14348 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
14349 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
14350 ENDIF
14351 RET1=PMG(1)
14352 RET2=PMG(2)
14353
14354C...Evaluate importance of excluded tails of Breit-Wigners.
14355 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14356 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14357 IF(MEQL.LE.1) THEN
14358 VINT(80)=1D0
14359 DO 250 I=1,2
14360 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
14361 & PARU(1)
14362 250 CONTINUE
14363 ELSE
14364 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
14365 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
14366 ENDIF
14367 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
14368 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
14369 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
14370 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14371
14372C...Pick one particle to be the lighter (if improves efficiency).
14373 ELSEIF(MOFSH.EQ.4) THEN
14374 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14375 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14376 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
14377
14378C...Select two masses according to Breit-Wigner + flat in s + 1/s.
14379 DO 270 I=1,2
14380 IF(MBW(I).EQ.0) GOTO 270
14381 PMV=PMU(I)
14382 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14383 ATV=ATU(I)
14384 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14385 RBR=PYR(0)
14386 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14387 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
14388 IF(RBR.LT.0.8D0) THEN
14389 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
14390 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
14391 ELSEIF(RBR.LT.0.9D0) THEN
14392 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
14393 ELSEIF(RBR.LT.1.5D0) THEN
14394 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
14395 ELSE
14396 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
14397 & (PMV**2-PML(I)**2))))
14398 ENDIF
14399 270 CONTINUE
14400 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14401 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
14402 IF(MINT(48).EQ.1) THEN
14403 NGEN(0,1)=NGEN(0,1)+1
14404 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
14405 GOTO 260
14406 ELSE
14407 MINT(51)=1
14408 RETURN
14409 ENDIF
14410 ENDIF
14411 RET1=PMG(1)
14412 RET2=PMG(2)
14413
14414C...Give weight for selected mass distribution.
14415 VINT(80)=1D0
14416 DO 280 I=1,2
14417 IF(MBW(I).EQ.0) GOTO 280
14418 PMV=PMU(I)
14419 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14420 ATV=ATU(I)
14421 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14422 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
14423 & (PMD(I)*PGD(I))**2)/PARU(1)
14424 F1=1D0
14425 F2=1D0/PMG(I)**2
14426 F3=1D0/PMG(I)**4
14427 FI0=(ATV-ATL(I))/PARU(1)
14428 FI1=PMV**2-PML(I)**2
14429 FI2=2D0*LOG(PMV/PML(I))
14430 FI3=1D0/PML(I)**2-1D0/PMV**2
14431 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14432 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
14433 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
14434 & 5D0*F3/FI3))
14435 ELSE
14436 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
14437 ENDIF
14438 VINT(80)=VINT(80)*FI0
14439 280 CONTINUE
14440 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14441 ENDIF
14442
14443 RETURN
14444 END
14445
14446C***********************************************************************
14447
14448C...PYRECO
14449C...Handles the possibility of colour reconnection in W+W- events,
14450C...Based on the main scenarios of the Sjostrand and Khoze study:
14451C...I, II, II', intermediate and instantaneous; plus one model
14452C...along the lines of the Gustafson and Hakkinen: GH.
14453
14454 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
14455
14456C...Double precision and integer declarations.
14457 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14458 INTEGER PYK,PYCHGE,PYCOMP
14459C...Parameter value; number of points in MC integration.
14460 PARAMETER (NPT=100)
14461C...Commonblocks.
14462 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14463 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14464 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14465 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14466 COMMON/PYINT1/MINT(400),VINT(400)
14467 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14468C...Local arrays.
14469 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
14470 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
14471 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
14472 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
14473 &TMC(20),IJOIN(100)
14474
14475C...Functions to give four-product and to do determinants.
14476 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
14477 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
14478 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
14479 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
14480
14481C...Only allow fraction of recoupling for GH, intermediate and
14482C...instantaneous.
14483 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14484 IF(PYR(0).GT.PARP(120)) RETURN
14485 ENDIF
14486
14487C...Common part for scenarios I, II, II', and GH.
14488 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
14489 &MSTP(115).EQ.5) THEN
14490
14491C...Read out frequently-used parameters.
14492 PI=PARU(1)
14493 HBAR=PARU(3)
14494 PMW=PMAS(24,1)
14495 PGW=PMAS(24,2)
14496 TFRAG=PARP(115)
14497 RHAD=PARP(116)
14498 FACT=PARP(117)
14499 BLOWR=PARP(118)
14500 BLOWT=PARP(119)
14501
14502C...Find range of decay products of the W's.
14503C...Background: the W's are stored in IW1 and IW2.
14504C...Their direct decay products in NSD1+1 through NSD1+4.
14505C...Products after shower (if any) in NSD1+5 through NAFT1
14506C...for first W and in NAFT1+1 through N for the second.
14507 IF(K(IW1,2).GT.0) THEN
14508 JT=1
14509 ELSE
14510 JT=2
14511 ENDIF
14512 JR=3-JT
14513 IF(NAFT1.GT.NSD1+4) THEN
14514 NBEG(JT)=NSD1+5
14515 NEND(JT)=NAFT1
14516 ELSE
14517 NBEG(JT)=NSD1+1
14518 NEND(JT)=NSD1+2
14519 ENDIF
14520 IF(N.GT.NAFT1) THEN
14521 NBEG(JR)=NAFT1+1
14522 NEND(JR)=N
14523 ELSE
14524 NBEG(JR)=NSD1+3
14525 NEND(JR)=NSD1+4
14526 ENDIF
14527
14528C...Rearrange parton shower products along strings.
14529 NOLD=N
14530 CALL PYPREP(NSD1+1)
14531
14532C...Find partons pointing back to W+ and W-; store them with quark
14533C...end of string first.
14534 NNP=0
14535 NNM=0
14536 ISGP=0
14537 ISGM=0
14538 DO 120 I=NOLD+1,N
14539 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
14540 IF(IABS(K(I,2)).GE.22) GOTO 120
14541 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
14542 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
14543 NNP=NNP+1
14544 IF(ISGP.EQ.1) THEN
14545 INP(NNP)=I
14546 ELSE
14547 DO 100 I1=NNP,2,-1
14548 INP(I1)=INP(I1-1)
14549 100 CONTINUE
14550 INP(1)=I
14551 ENDIF
14552 IF(K(I,1).EQ.1) ISGP=0
14553 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
14554 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
14555 NNM=NNM+1
14556 IF(ISGM.EQ.1) THEN
14557 INM(NNM)=I
14558 ELSE
14559 DO 110 I1=NNM,2,-1
14560 INM(I1)=INM(I1-1)
14561 110 CONTINUE
14562 INM(1)=I
14563 ENDIF
14564 IF(K(I,1).EQ.1) ISGM=0
14565 ENDIF
14566 120 CONTINUE
14567
14568C...Boost to W+W- rest frame (not strictly needed).
14569 DO 130 J=1,3
14570 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
14571 130 CONTINUE
14572 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14573 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14574 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14575
14576C...Select decay vertices of W+ and W-.
14577 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
14578 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
14579 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
14580 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
14581 GTMAX=MAX(TP,TM)
14582 DO 140 J=1,3
14583 XP(J)=TP*P(IW1,J)/P(IW1,4)
14584 XM(J)=TM*P(IW2,J)/P(IW2,4)
14585 140 CONTINUE
14586
14587C...Begin scenario I specifics.
14588 IF(MSTP(115).EQ.1) THEN
14589
14590C...Reconstruct velocity and direction of W+ string pieces.
14591 DO 170 IIP=1,NNP-1
14592 IF(K(INP(IIP),2).LT.0) GOTO 170
14593 I1=INP(IIP)
14594 I2=INP(IIP+1)
14595 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14596 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14597 DO 150 J=1,3
14598 V1(J)=P(I1,J)/P1A
14599 V2(J)=P(I2,J)/P2A
14600 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
14601 DIRP(IIP,J)=V1(J)-V2(J)
14602 150 CONTINUE
14603 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
14604 & BETP(IIP,3)**2)
14605 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
14606 DO 160 J=1,3
14607 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
14608 160 CONTINUE
14609 170 CONTINUE
14610
14611C...Reconstruct velocity and direction of W- string pieces.
14612 DO 200 IIM=1,NNM-1
14613 IF(K(INM(IIM),2).LT.0) GOTO 200
14614 I1=INM(IIM)
14615 I2=INM(IIM+1)
14616 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14617 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14618 DO 180 J=1,3
14619 V1(J)=P(I1,J)/P1A
14620 V2(J)=P(I2,J)/P2A
14621 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
14622 DIRM(IIM,J)=V1(J)-V2(J)
14623 180 CONTINUE
14624 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
14625 & BETM(IIM,3)**2)
14626 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
14627 DO 190 J=1,3
14628 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
14629 190 CONTINUE
14630 200 CONTINUE
14631
14632C...Loop over number of space-time points.
14633 NACC=0
14634 SUM=0D0
14635 DO 250 IPT=1,NPT
14636
14637C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
14638 R=SQRT(-LOG(PYR(0)))
14639 PHI=2D0*PI*PYR(0)
14640 X=BLOWR*RHAD*R*COS(PHI)
14641 Y=BLOWR*RHAD*R*SIN(PHI)
14642 R=SQRT(-LOG(PYR(0)))
14643 PHI=2D0*PI*PYR(0)
14644 Z=BLOWR*RHAD*R*COS(PHI)
14645 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
14646
14647C...Weight for sample distribution.
14648 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
14649 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
14650
14651C...Loop over W+ string pieces and find one with largest weight.
14652 IMAXP=0
14653 WTMAXP=1D-10
14654 XD(1)=X-XP(1)
14655 XD(2)=Y-XP(2)
14656 XD(3)=Z-XP(3)
14657 XD(4)=T-TP
14658 DO 220 IIP=1,NNP-1
14659 IF(K(INP(IIP),2).LT.0) GOTO 220
14660 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
14661 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
14662 DO 210 J=1,3
14663 XB(J)=XD(J)+BEDG*BETP(IIP,J)
14664 210 CONTINUE
14665 XB(4)=BETP(IIP,4)*(XD(4)-BED)
14666 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14667 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
14668 & DIRP(IIP,3)*XB(3))**2
14669 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14670 & TFRAG**2)
14671 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
14672 IF(WTP.GT.WTMAXP) THEN
14673 IMAXP=IIP
14674 WTMAXP=WTP
14675 ENDIF
14676 220 CONTINUE
14677
14678C...Loop over W- string pieces and find one with largest weight.
14679 IMAXM=0
14680 WTMAXM=1D-10
14681 XD(1)=X-XM(1)
14682 XD(2)=Y-XM(2)
14683 XD(3)=Z-XM(3)
14684 XD(4)=T-TM
14685 DO 240 IIM=1,NNM-1
14686 IF(K(INM(IIM),2).LT.0) GOTO 240
14687 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
14688 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
14689 DO 230 J=1,3
14690 XB(J)=XD(J)+BEDG*BETM(IIM,J)
14691 230 CONTINUE
14692 XB(4)=BETM(IIM,4)*(XD(4)-BED)
14693 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14694 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
14695 & DIRM(IIM,3)*XB(3))**2
14696 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14697 & TFRAG**2)
14698 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
14699 IF(WTM.GT.WTMAXM) THEN
14700 IMAXM=IIM
14701 WTMAXM=WTM
14702 ENDIF
14703 240 CONTINUE
14704
14705C...Result of integration.
14706 WT=0D0
14707 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
14708 WT=WTMAXP*WTMAXM/WTSMP
14709 SUM=SUM+WT
14710 NACC=NACC+1
14711 IAP(NACC)=IMAXP
14712 IAM(NACC)=IMAXM
14713 WTA(NACC)=WT
14714 ENDIF
14715 250 CONTINUE
14716 RES=BLOWR**3*BLOWT*SUM/NPT
14717
14718C...Decide whether to reconnect and, if so, where.
14719 IACC=0
14720 PREC=1D0-EXP(-FACT*RES)
14721 IF(PREC.GT.PYR(0)) THEN
14722 RSUM=PYR(0)*SUM
14723 DO 260 IA=1,NACC
14724 IACC=IA
14725 RSUM=RSUM-WTA(IA)
14726 IF(RSUM.LE.0D0) GOTO 270
14727 260 CONTINUE
14728 270 IIP=IAP(IACC)
14729 IIM=IAM(IACC)
14730 ENDIF
14731
14732C...Begin scenario II and II' specifics.
14733 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
14734
14735C...Loop through all string pieces, one from W+ and one from W-.
14736 NCROSS=0
14737 TC(0)=0D0
14738 DO 340 IIP=1,NNP-1
14739 IF(K(INP(IIP),2).LT.0) GOTO 340
14740 I1P=INP(IIP)
14741 I2P=INP(IIP+1)
14742 DO 330 IIM=1,NNM-1
14743 IF(K(INM(IIM),2).LT.0) GOTO 330
14744 I1M=INM(IIM)
14745 I2M=INM(IIM+1)
14746
14747C...Find endpoint velocity vectors.
14748 DO 280 J=1,3
14749 V1P(J)=P(I1P,J)/P(I1P,4)
14750 V2P(J)=P(I2P,J)/P(I2P,4)
14751 V1M(J)=P(I1M,J)/P(I1M,4)
14752 V2M(J)=P(I2M,J)/P(I2M,4)
14753 280 CONTINUE
14754
14755C...Define q matrix and find t.
14756 DO 290 J=1,3
14757 Q(1,J)=V2P(J)-V1P(J)
14758 Q(2,J)=-(V2M(J)-V1M(J))
14759 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
14760 Q(4,J)=V1P(J)-V1M(J)
14761 290 CONTINUE
14762 T=-DETER(1,2,3)/DETER(1,2,4)
14763
14764C...Find alpha and beta; i.e. coordinates of crossing point.
14765 S11=Q(1,1)*(T-TP)
14766 S12=Q(2,1)*(T-TM)
14767 S13=Q(3,1)+Q(4,1)*T
14768 S21=Q(1,2)*(T-TP)
14769 S22=Q(2,2)*(T-TM)
14770 S23=Q(3,2)+Q(4,2)*T
14771 DEN=S11*S22-S12*S21
14772 ALP=(S12*S23-S22*S13)/DEN
14773 BET=(S21*S13-S11*S23)/DEN
14774
14775C...Check if solution acceptable.
14776 IANSW=1
14777 IF(T.LT.GTMAX) IANSW=0
14778 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
14779 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
14780
14781C...Find point of crossing and check that not inconsistent.
14782 DO 300 J=1,3
14783 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
14784 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
14785 300 CONTINUE
14786 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
14787 & (XPP(3)-XMM(3))**2
14788 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
14789 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
14790 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
14791
14792C...Find string eigentimes at crossing.
14793 IF(IANSW.EQ.1) THEN
14794 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
14795 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
14796 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
14797 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
14798 ELSE
14799 TAUP=0D0
14800 TAUM=0D0
14801 ENDIF
14802
14803C...Order crossings by time. End loop over crossings.
14804 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
14805 NCROSS=NCROSS+1
14806 DO 310 I1=NCROSS,1,-1
14807 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
14808 IPC(I1)=IIP
14809 IMC(I1)=IIM
14810 TC(I1)=T
14811 TPC(I1)=TAUP
14812 TMC(I1)=TAUM
14813 GOTO 320
14814 ELSE
14815 IPC(I1)=IPC(I1-1)
14816 IMC(I1)=IMC(I1-1)
14817 TC(I1)=TC(I1-1)
14818 TPC(I1)=TPC(I1-1)
14819 TMC(I1)=TMC(I1-1)
14820 ENDIF
14821 310 CONTINUE
14822 320 CONTINUE
14823 ENDIF
14824 330 CONTINUE
14825 340 CONTINUE
14826
14827C...Loop over crossings; find first (if any) acceptable one.
14828 IACC=0
14829 IF(NCROSS.GE.1) THEN
14830 DO 350 IC=1,NCROSS
14831 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
14832 IF(PNFRAG.GT.PYR(0)) THEN
14833C...Scenario II: only compare with fragmentation time.
14834 IF(MSTP(115).EQ.2) THEN
14835 IACC=IC
14836 IIP=IPC(IACC)
14837 IIM=IMC(IACC)
14838 GOTO 360
14839C...Scenario II': also require that string length decreases.
14840 ELSE
14841 IIP=IPC(IC)
14842 IIM=IMC(IC)
14843 I1P=INP(IIP)
14844 I2P=INP(IIP+1)
14845 I1M=INM(IIM)
14846 I2M=INM(IIM+1)
14847 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14848 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14849 IF(ELNEW.LT.ELOLD) THEN
14850 IACC=IC
14851 IIP=IPC(IACC)
14852 IIM=IMC(IACC)
14853 GOTO 360
14854 ENDIF
14855 ENDIF
14856 ENDIF
14857 350 CONTINUE
14858 360 CONTINUE
14859 ENDIF
14860
14861C...Begin scenario GH specifics.
14862 ELSEIF(MSTP(115).EQ.5) THEN
14863
14864C...Loop through all string pieces, one from W+ and one from W-.
14865 IACC=0
14866 ELMIN=1D0
14867 DO 380 IIP=1,NNP-1
14868 IF(K(INP(IIP),2).LT.0) GOTO 380
14869 I1P=INP(IIP)
14870 I2P=INP(IIP+1)
14871 DO 370 IIM=1,NNM-1
14872 IF(K(INM(IIM),2).LT.0) GOTO 370
14873 I1M=INM(IIM)
14874 I2M=INM(IIM+1)
14875
14876C...Look for largest decrease of (exponent of) Lambda measure.
14877 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14878 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14879 ELDIF=ELNEW/MAX(1D-10,ELOLD)
14880 IF(ELDIF.LT.ELMIN) THEN
14881 IACC=IIP+IIM
14882 ELMIN=ELDIF
14883 IPC(1)=IIP
14884 IMC(1)=IIM
14885 ENDIF
14886 370 CONTINUE
14887 380 CONTINUE
14888 IIP=IPC(1)
14889 IIM=IMC(1)
14890 ENDIF
14891
14892C...Common for scenarios I, II, II' and GH: reconnect strings.
14893 IF(IACC.NE.0) THEN
14894 MINT(32)=1
14895 NJOIN=0
14896 DO 390 IS=1,NNP+NNM
14897 NJOIN=NJOIN+1
14898 IF(IS.LE.IIP) THEN
14899 I=INP(IS)
14900 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
14901 I=INM(IS-IIP+IIM)
14902 ELSEIF(IS.LE.IIP+NNM) THEN
14903 I=INM(IS-IIP-NNM+IIM)
14904 ELSE
14905 I=INP(IS-NNM)
14906 ENDIF
14907 IJOIN(NJOIN)=I
14908 IF(K(I,2).LT.0) THEN
14909 CALL PYJOIN(NJOIN,IJOIN)
14910 NJOIN=0
14911 ENDIF
14912 390 CONTINUE
14913
14914C...Restore original event record if no reconnection.
14915 ELSE
14916 DO 400 I=NSD1+1,NOLD
14917 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
14918 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14919 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14920 ENDIF
14921 400 CONTINUE
14922 DO 410 I=NOLD+1,N
14923 K(K(I,3),1)=3
14924 410 CONTINUE
14925 N=NOLD
14926 ENDIF
14927
14928C...Boost back system.
14929 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14930 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14931 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
14932 & BEWW(1),BEWW(2),BEWW(3))
14933
14934C...Common part for intermediate and instantaneous scenarios.
14935 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14936 MINT(32)=1
14937
14938C...Remove old shower products and reset showering ones.
14939 N=NSD1+4
14940 DO 420 I=NSD1+1,NSD1+4
14941 K(I,1)=3
14942 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14943 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14944 420 CONTINUE
14945
14946C...Identify quark-antiquark pairs.
14947 IQ1=NSD1+1
14948 IQ2=NSD1+2
14949 IQ3=NSD1+3
14950 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
14951 IQ4=2*NSD1+7-IQ3
14952
14953C...Reconnect strings.
14954 IJOIN(1)=IQ1
14955 IJOIN(2)=IQ4
14956 CALL PYJOIN(2,IJOIN)
14957 IJOIN(1)=IQ3
14958 IJOIN(2)=IQ2
14959 CALL PYJOIN(2,IJOIN)
14960
14961C...Do new parton showers in intermediate scenario.
14962 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
14963 MSTJ50=MSTJ(50)
14964 MSTJ(50)=0
14965 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
14966 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
14967 MSTJ(50)=MSTJ50
14968
14969C...Do new parton showers in instantaneous scenario.
14970 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
14971 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
14972 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
14973 PPM=SQRT(MAX(0D0,PPM2))
14974 CALL PYSHOW(IQ1,IQ4,PPM)
14975 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
14976 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
14977 PPM=SQRT(MAX(0D0,PPM2))
14978 CALL PYSHOW(IQ3,IQ2,PPM)
14979 ENDIF
14980 ENDIF
14981
14982 RETURN
14983 END
14984
14985C***********************************************************************
14986
14987C...PYKLIM
14988C...Checks generated variables against pre-set kinematical limits;
14989C...also calculates limits on variables used in generation.
14990
14991 SUBROUTINE PYKLIM(ILIM)
14992
14993C...Double precision and integer declarations.
14994 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14995 INTEGER PYK,PYCHGE,PYCOMP
14996C...Commonblocks.
14997 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14998 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14999 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15000 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15001 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15002 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15003 COMMON/PYINT1/MINT(400),VINT(400)
15004 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15005 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15006 &/PYINT1/,/PYINT2/
15007
15008C...Common kinematical expressions.
15009 MINT(51)=0
15010 ISUB=MINT(1)
15011 ISTSB=ISET(ISUB)
15012 IF(ISUB.EQ.96) GOTO 100
15013 SQM3=VINT(63)
15014 SQM4=VINT(64)
15015 IF(ILIM.NE.0) THEN
15016 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
15017 CKIN09=MAX(CKIN(9),CKIN(13))
15018 CKIN10=MIN(CKIN(10),CKIN(14))
15019 CKIN11=MAX(CKIN(11),CKIN(15))
15020 CKIN12=MIN(CKIN(12),CKIN(16))
15021 ELSE
15022 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
15023 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
15024 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
15025 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
15026 ENDIF
15027 ENDIF
15028 IF(ILIM.NE.1) THEN
15029 TAU=VINT(21)
15030 RM3=SQM3/(TAU*VINT(2))
15031 RM4=SQM4/(TAU*VINT(2))
15032 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
15033 ENDIF
15034 PTHMIN=CKIN(3)
15035 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
15036 &PTHMIN=MAX(CKIN(3),CKIN(5))
15037
15038 IF(ILIM.EQ.0) THEN
15039C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15040C...pre-set kinematical limits.
15041 YST=VINT(22)
15042 CTH=VINT(23)
15043 TAUP=VINT(26)
15044 TAUE=TAU
15045 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
15046 X1=SQRT(TAUE)*EXP(YST)
15047 X2=SQRT(TAUE)*EXP(-YST)
15048 XF=X1-X2
15049 IF(MINT(47).NE.1) THEN
15050 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15051 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15052 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15053 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15054 ENDIF
15055 IF(MINT(45).NE.1) THEN
15056 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15057 ENDIF
15058 IF(MINT(46).NE.1) THEN
15059 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15060 ENDIF
15061 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
15062 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
15063 EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/
15064 & MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH)))
15065 EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/
15066 & MAX(1.D-10,(1D0-RM3+RM4+BE34*CTH)))
15067 Y3=YST+0.5D0*LOG(EXPY3)
15068 Y4=YST+0.5D0*LOG(EXPY4)
15069 YLARGE=MAX(Y3,Y4)
15070 YSMALL=MIN(Y3,Y4)
15071 ETALAR=10D0
15072 ETASMA=-10D0
15073 STH=SQRT(MAX(0D0,1D0-CTH**2))
15074 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
15075 & CTH)**2-4D0*RM3))
15076 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
15077 & CTH)**2-4D0*RM4))
15078 IF(STH.GE.1.D-6) THEN
15079 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
15080 & (BE34*STH)
15081 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
15082 & (BE34*STH)
15083 ETA3=LOG(MIN(1.D10,MAX(1.D-10,EXPET3)))
15084 ETA4=LOG(MIN(1.D10,MAX(1.D-10,EXPET4)))
15085 ETALAR=MAX(ETA3,ETA4)
15086 ETASMA=MIN(ETA3,ETA4)
15087 ENDIF
15088 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
15089 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
15090 CTSLAR=MIN(1D0,MAX(CTS3,CTS4))
15091 CTSSMA=MAX(-1D0,MIN(CTS3,CTS4))
15092 SH=TAU*VINT(2)
15093 RPTS=4D0*VINT(71)**2/SH
15094 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
15095 RM34=MAX(1D-20,2D0*RM3*RM4)
15096 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15097 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15098 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
15099 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
15100 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
15101 IF(PTH.LT.PTHMIN) MINT(51)=1
15102 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
15103 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15104 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15105 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15106 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15107 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15108 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15109 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15110 IF(THA.LT.CKIN(35)) MINT(51)=1
15111 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
15112 IF(UHA.LT.CKIN(37)) MINT(51)=1
15113 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
15114 ENDIF
15115 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
15116 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15117 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15118 ENDIF
15119
15120C...Additional cuts on W2 (approximately) in DIS.
15121 IF(ISUB.EQ.10) THEN
15122 XBJ=X2
15123 IF(IABS(MINT(12)).LT.20) XBJ=X1
15124 Q2BJ=THA
15125 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
15126 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
15127 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
15128 ENDIF
15129
15130 ELSEIF(ILIM.EQ.1) THEN
15131C...Calculate limits on tau
15132C...0) due to definition
15133 TAUMN0=0D0
15134 TAUMX0=1D0
15135C...1) due to limits on subsystem mass
15136 TAUMN1=CKIN(1)**2/VINT(2)
15137 TAUMX1=1D0
15138 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
15139C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15140 TM3=SQRT(SQM3+PTHMIN**2)
15141 TM4=SQRT(SQM4+PTHMIN**2)
15142 YDCOSH=1D0
15143 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
15144 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15145 TAUMX2=1D0
15146C...3) due to limits on pT-hat and cos(theta-hat)
15147 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15148 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15149 TAUMN3=0D0
15150 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
15151 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
15152 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
15153 TAUMX3=1D0
15154 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
15155 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
15156 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
15157C...4) due to limits on x1 and x2
15158 TAUMN4=CKIN(21)*CKIN(23)
15159 TAUMX4=CKIN(22)*CKIN(24)
15160C...5) due to limits on xF
15161 TAUMN5=0D0
15162 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
15163C...6) due to limits on that and uhat
15164 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
15165 TAUMX6=1D0
15166 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
15167 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
15168
15169C...Net effect of all separate limits.
15170 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
15171 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
15172 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15173 VINT(11)=0.99999D0
15174 VINT(31)=1.00001D0
15175 ELSEIF(MINT(47).EQ.5) THEN
15176 VINT(31)=MIN(VINT(31),0.999998D0)
15177 ENDIF
15178 IF(VINT(31).LE.VINT(11)) MINT(51)=1
15179
15180 ELSEIF(ILIM.EQ.2) THEN
15181C...Calculate limits on y*
15182 TAUE=TAU
15183 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15184 TAURT=SQRT(TAUE)
15185C...0) due to kinematics
15186 YSTMN0=LOG(TAURT)
15187 YSTMX0=-YSTMN0
15188C...1) due to explicit limits
15189 YSTMN1=CKIN(7)
15190 YSTMX1=CKIN(8)
15191C...2) due to limits on x1
15192 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
15193 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
15194C...3) due to limits on x2
15195 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
15196 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
15197C...4) due to limits on xF
15198 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
15199 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
15200 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
15201 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
15202C...5) due to simultaneous limits on y-large and y-small
15203 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
15204 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
15205 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
15206 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
15207 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
15208 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
15209C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15210C... y-small
15211 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
15212 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15213 RZMX=BE34*MIN(CKIN(28),CTHLIM)
15214 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
15215 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
15216 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
15217 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
15218 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
15219 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
15220
15221C...Net effect of all separate limits.
15222 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15223 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15224 IF(MINT(47).EQ.1) THEN
15225 VINT(12)=-0.00001D0
15226 VINT(32)=0.00001D0
15227 ELSEIF(MINT(47).EQ.2) THEN
15228 VINT(12)=0.99999D0*YSTMX0
15229 VINT(32)=1.00001D0*YSTMX0
15230 ELSEIF(MINT(47).EQ.3) THEN
15231 VINT(12)=-1.00001D0*YSTMX0
15232 VINT(32)=-0.99999D0*YSTMX0
15233 ELSEIF(MINT(47).EQ.5) THEN
15234 YSTEE=LOG(0.999999D0/TAURT)
15235 VINT(12)=MAX(VINT(12),-YSTEE)
15236 VINT(32)=MIN(VINT(32),YSTEE)
15237 ENDIF
15238 IF(VINT(32).LE.VINT(12)) MINT(51)=1
15239
15240 ELSEIF(ILIM.EQ.3) THEN
15241C...Calculate limits on cos(theta-hat)
15242 YST=VINT(22)
15243C...0) due to definition
15244 CTNMN0=-1D0
15245 CTNMX0=0D0
15246 CTPMN0=0D0
15247 CTPMX0=1D0
15248C...1) due to explicit limits
15249 CTNMN1=MIN(0D0,CKIN(27))
15250 CTNMX1=MIN(0D0,CKIN(28))
15251 CTPMN1=MAX(0D0,CKIN(27))
15252 CTPMX1=MAX(0D0,CKIN(28))
15253C...2) due to limits on pT-hat
15254 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
15255 CTPMX2=-CTNMN2
15256 CTNMX2=0D0
15257 CTPMN2=0D0
15258 IF(CKIN(4).GE.0D0) THEN
15259 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
15260 & (BE34**2*TAU*VINT(2))))
15261 CTPMN2=-CTNMX2
15262 ENDIF
15263C...3) due to limits on y-large and y-small
15264 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
15265 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
15266 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
15267 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
15268 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
15269 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
15270 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
15271 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
15272C...4) due to limits on that
15273 CTNMN4=-1D0
15274 CTNMX4=0D0
15275 CTPMN4=0D0
15276 CTPMX4=1D0
15277 SH=TAU*VINT(2)
15278 IF(CKIN(35).GT.0D0) THEN
15279 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
15280 IF(CTLIM.GT.0D0) THEN
15281 CTPMX4=CTLIM
15282 ELSE
15283 CTPMX4=0D0
15284 CTNMX4=CTLIM
15285 ENDIF
15286 ENDIF
15287 IF(CKIN(36).GT.0D0) THEN
15288 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
15289 IF(CTLIM.LT.0D0) THEN
15290 CTNMN4=CTLIM
15291 ELSE
15292 CTNMN4=0D0
15293 CTPMN4=CTLIM
15294 ENDIF
15295 ENDIF
15296C...5) due to limits on uhat
15297 CTNMN5=-1D0
15298 CTNMX5=0D0
15299 CTPMN5=0D0
15300 CTPMX5=1D0
15301 IF(CKIN(37).GT.0D0) THEN
15302 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
15303 IF(CTLIM.LT.0D0) THEN
15304 CTNMN5=CTLIM
15305 ELSE
15306 CTNMN5=0D0
15307 CTPMN5=CTLIM
15308 ENDIF
15309 ENDIF
15310 IF(CKIN(38).GT.0D0) THEN
15311 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
15312 IF(CTLIM.GT.0D0) THEN
15313 CTPMX5=CTLIM
15314 ELSE
15315 CTPMX5=0D0
15316 CTNMX5=CTLIM
15317 ENDIF
15318 ENDIF
15319
15320C...Net effect of all separate limits.
15321 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
15322 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
15323 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
15324 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
15325 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15326
15327 ELSEIF(ILIM.EQ.4) THEN
15328C...Calculate limits on tau'
15329C...0) due to kinematics
15330 TAPMN0=TAU
15331 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
15332 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
15333 TAPMN0=(SQRT(TAU)+PQRAT)**2
15334 ENDIF
15335 TAPMX0=1D0
15336C...1) due to explicit limits
15337 TAPMN1=CKIN(31)**2/VINT(2)
15338 TAPMX1=1D0
15339 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
15340
15341C...Net effect of all separate limits.
15342 VINT(16)=MAX(TAPMN0,TAPMN1)
15343 VINT(36)=MIN(TAPMX0,TAPMX1)
15344 IF(MINT(47).EQ.1) THEN
15345 VINT(16)=0.99999D0
15346 VINT(36)=1.00001D0
15347 ENDIF
15348 IF(VINT(36).LE.VINT(16)) MINT(51)=1
15349
15350 ENDIF
15351 RETURN
15352
15353C...Special case for low-pT and multiple interactions:
15354C...effective kinematical limits for tau, y*, cos(theta-hat).
15355 100 IF(ILIM.EQ.0) THEN
15356 ELSEIF(ILIM.EQ.1) THEN
15357 IF(MSTP(82).LE.1) VINT(11)=4D0*PARP(81)**2/VINT(2)
15358 IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15359 VINT(31)=1D0
15360 ELSEIF(ILIM.EQ.2) THEN
15361 VINT(12)=0.5D0*LOG(VINT(21))
15362 VINT(32)=-VINT(12)
15363 ELSEIF(ILIM.EQ.3) THEN
15364 IF(MSTP(82).LE.1) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2))
15365 IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2))
15366 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
15367 VINT(33)=0D0
15368 VINT(14)=0D0
15369 VINT(34)=-VINT(13)
15370 ENDIF
15371
15372 RETURN
15373 END
15374
15375C*********************************************************************
15376
15377C...PYKMAP
15378C...Maps a uniform distribution into a distribution of a kinematical
15379C...variable according to one of the possibilities allowed. It is
15380C...assumed that kinematical limits have been set by a PYKLIM call.
15381
15382 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
15383
15384C...Double precision and integer declarations.
15385 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15386 INTEGER PYK,PYCHGE,PYCOMP
15387C...Commonblocks.
15388 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15389 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15390 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15391 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15392 COMMON/PYINT1/MINT(400),VINT(400)
15393 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15394 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
15395
15396C...Convert VVAR to tau variable.
15397 ISUB=MINT(1)
15398 ISTSB=ISET(ISUB)
15399 IF(IVAR.EQ.1) THEN
15400 TAUMIN=VINT(11)
15401 TAUMAX=VINT(31)
15402 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
15403 TAURE=VINT(73)
15404 GAMRE=VINT(74)
15405 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
15406 TAURE=VINT(75)
15407 GAMRE=VINT(76)
15408 ENDIF
15409 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15410 TAU=1D0
15411 ELSEIF(MVAR.EQ.1) THEN
15412 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
15413 ELSEIF(MVAR.EQ.2) THEN
15414 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
15415 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
15416 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
15417 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
15418 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
15419 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
15420 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
15421 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
15422 ELSE
15423 AUPP=LOG(MAX(2D-6,1D0-TAUMAX))
15424 ALOW=LOG(MAX(2D-6,1D0-TAUMIN))
15425 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15426 ENDIF
15427 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
15428
15429C...Convert VVAR to y* variable.
15430 ELSEIF(IVAR.EQ.2) THEN
15431 YSTMIN=VINT(12)
15432 YSTMAX=VINT(32)
15433 TAUE=VINT(21)
15434 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15435 IF(MINT(47).EQ.1) THEN
15436 YST=0D0
15437 ELSEIF(MINT(47).EQ.2) THEN
15438 YST=-0.5D0*LOG(TAUE)
15439 ELSEIF(MINT(47).EQ.3) THEN
15440 YST=0.5D0*LOG(TAUE)
15441 ELSEIF(MVAR.EQ.1) THEN
15442 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
15443 ELSEIF(MVAR.EQ.2) THEN
15444 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
15445 ELSEIF(MVAR.EQ.3) THEN
15446 AUPP=ATAN(EXP(YSTMAX))
15447 ALOW=ATAN(EXP(YSTMIN))
15448 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
15449 ELSEIF(MVAR.EQ.4) THEN
15450 YST0=-0.5D0*LOG(TAUE)
15451 AUPP=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0))
15452 ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
15453 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
15454 ELSE
15455 YST0=-0.5D0*LOG(TAUE)
15456 AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
15457 ALOW=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0))
15458 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
15459 ENDIF
15460 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
15461
15462C...Convert VVAR to cos(theta-hat) variable.
15463 ELSEIF(IVAR.EQ.3) THEN
15464 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
15465 RSQM=1D0+RM34
15466 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15467 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15468 CTNMIN=VINT(13)
15469 CTNMAX=VINT(33)
15470 CTPMIN=VINT(14)
15471 CTPMAX=VINT(34)
15472 IF(MVAR.EQ.1) THEN
15473 ANEG=CTNMAX-CTNMIN
15474 APOS=CTPMAX-CTPMIN
15475 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15476 VCTN=VVAR*(ANEG+APOS)/ANEG
15477 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
15478 ELSE
15479 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15480 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
15481 ENDIF
15482 ELSEIF(MVAR.EQ.2) THEN
15483 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15484 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15485 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15486 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15487 ANEG=LOG(RMNMIN/RMNMAX)
15488 APOS=LOG(RMPMIN/RMPMAX)
15489 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15490 VCTN=VVAR*(ANEG+APOS)/ANEG
15491 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
15492 ELSE
15493 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15494 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
15495 ENDIF
15496 ELSEIF(MVAR.EQ.3) THEN
15497 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15498 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15499 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15500 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15501 ANEG=LOG(RMNMAX/RMNMIN)
15502 APOS=LOG(RMPMAX/RMPMIN)
15503 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15504 VCTN=VVAR*(ANEG+APOS)/ANEG
15505 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
15506 ELSE
15507 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15508 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
15509 ENDIF
15510 ELSEIF(MVAR.EQ.4) THEN
15511 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15512 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15513 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15514 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15515 ANEG=1D0/RMNMAX-1D0/RMNMIN
15516 APOS=1D0/RMPMAX-1D0/RMPMIN
15517 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15518 VCTN=VVAR*(ANEG+APOS)/ANEG
15519 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
15520 ELSE
15521 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15522 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
15523 ENDIF
15524 ELSEIF(MVAR.EQ.5) THEN
15525 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15526 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15527 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15528 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15529 ANEG=1D0/RMNMIN-1D0/RMNMAX
15530 APOS=1D0/RMPMIN-1D0/RMPMAX
15531 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15532 VCTN=VVAR*(ANEG+APOS)/ANEG
15533 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
15534 ELSE
15535 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15536 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
15537 ENDIF
15538 ENDIF
15539 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
15540 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
15541 VINT(23)=CTH
15542
15543C...Convert VVAR to tau' variable.
15544 ELSEIF(IVAR.EQ.4) THEN
15545 TAU=VINT(21)
15546 TAUPMN=VINT(16)
15547 TAUPMX=VINT(36)
15548 IF(MINT(47).EQ.1) THEN
15549 TAUP=1D0
15550 ELSEIF(MVAR.EQ.1) THEN
15551 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
15552 ELSEIF(MVAR.EQ.2) THEN
15553 AUPP=(1D0-TAU/TAUPMX)**4
15554 ALOW=(1D0-TAU/TAUPMN)**4
15555 TAUP=TAU/MAX(1D-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
15556 ELSE
15557 AUPP=LOG(MAX(2D-6,1D0-TAUPMX))
15558 ALOW=LOG(MAX(2D-6,1D0-TAUPMN))
15559 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15560 ENDIF
15561 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
15562
15563C...Selection of extra variables needed in 2 -> 3 process:
15564C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
15565C...Since no options are available, the functions of PYKLIM
15566C...and PYKMAP are joint for these choices.
15567 ELSEIF(IVAR.EQ.5) THEN
15568
15569C...Read out total energy and particle masses.
15570 MINT(51)=0
15571 MPTPK=1
15572 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
15573 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179) MPTPK=2
15574 SHP=VINT(26)*VINT(2)
15575 SHPR=SQRT(SHP)
15576 PM1=VINT(201)
15577 PM2=VINT(206)
15578 PM3=SQRT(VINT(21))*VINT(1)
15579 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
15580 MINT(51)=1
15581 RETURN
15582 ENDIF
15583 PMRS1=VINT(204)**2
15584 PMRS2=VINT(209)**2
15585
15586C...Specify coefficients of pT choice; upper and lower limits.
15587 IF(MPTPK.EQ.1) THEN
15588 HWT1=0.4D0
15589 HWT2=0.4D0
15590 ELSE
15591 HWT1=0.05D0
15592 HWT2=0.05D0
15593 ENDIF
15594 HWT3=1D0-HWT1-HWT2
15595 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
15596 & (4D0*SHP)
15597 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
15598 PTSMN1=CKIN(51)**2
15599 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
15600 & (4D0*SHP)
15601 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
15602 PTSMN2=CKIN(53)**2
15603
15604C...Select transverse momenta according to
15605C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
15606 HMX=PMRS1+PTSMX1
15607 HMN=PMRS1+PTSMN1
15608 IF(HMX.LT.1.0001D0*HMN) THEN
15609 MINT(51)=1
15610 RETURN
15611 ENDIF
15612 HDE=PTSMX1-PTSMN1
15613 RPT=PYR(0)
15614 IF(RPT.LT.HWT1) THEN
15615 PTS1=PTSMN1+PYR(0)*HDE
15616 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15617 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
15618 ELSE
15619 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
15620 ENDIF
15621 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
15622 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
15623 HMX=PMRS2+PTSMX2
15624 HMN=PMRS2+PTSMN2
15625 IF(HMX.LT.1.0001D0*HMN) THEN
15626 MINT(51)=1
15627 RETURN
15628 ENDIF
15629 HDE=PTSMX2-PTSMN2
15630 RPT=PYR(0)
15631 IF(RPT.LT.HWT1) THEN
15632 PTS2=PTSMN2+PYR(0)*HDE
15633 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15634 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
15635 ELSE
15636 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
15637 ENDIF
15638 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
15639 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
15640
15641C...Select azimuthal angles and check pT choice.
15642 PHI1=PARU(2)*PYR(0)
15643 PHI2=PARU(2)*PYR(0)
15644 PHIR=PHI2-PHI1
15645 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
15646 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
15647 & CKIN(56)**2)) THEN
15648 MINT(51)=1
15649 RETURN
15650 ENDIF
15651
15652C...Calculate transverse masses and check phase space not closed.
15653 PMS1=PM1**2+PTS1
15654 PMS2=PM2**2+PTS2
15655 PMS3=PM3**2+PTS3
15656 PMT1=SQRT(PMS1)
15657 PMT2=SQRT(PMS2)
15658 PMT3=SQRT(PMS3)
15659 PM12=(PMT1+PMT2)**2
15660 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
15661 MINT(51)=1
15662 RETURN
15663 ENDIF
15664
15665C...Select rapidity for particle 3 and check phase space not closed.
15666 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
15667 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
15668 IF(Y3MAX.LT.1D-6) THEN
15669 MINT(51)=1
15670 RETURN
15671 ENDIF
15672 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
15673 PZ3=PMT3*SINH(Y3)
15674 PE3=PMT3*COSH(Y3)
15675
15676C...Find momentum transfers in two mirror solutions (in 1-2 frame).
15677 PZ12=-PZ3
15678 PE12=SHPR-PE3
15679 PMS12=PE12**2-PZ12**2
15680 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
15681 IF(SQL12.LT.1D-6*SHP) THEN
15682 MINT(51)=1
15683 RETURN
15684 ENDIF
15685 PMM1=PMS12+PMS1-PMS2
15686 PMM2=PMS12+PMS2-PMS1
15687 TFAC=-SHPR/(2D0*PMS12)
15688 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
15689 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
15690 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
15691 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
15692
15693C...Construct relative mirror weights and make choice.
15694 IF(MPTPK.EQ.1) THEN
15695 WTPU=1D0
15696 WTNU=1D0
15697 ELSE
15698 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
15699 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
15700 ENDIF
15701 WTP=WTPU/(WTPU+WTNU)
15702 WTN=WTNU/(WTPU+WTNU)
15703 EPS=1D0
15704 IF(WTN.GT.PYR(0)) EPS=-1D0
15705
15706C...Store result of variable choice and associated weights.
15707 VINT(202)=PTS1
15708 VINT(207)=PTS2
15709 VINT(203)=PHI1
15710 VINT(208)=PHI2
15711 VINT(205)=WTPTS1
15712 VINT(210)=WTPTS2
15713 VINT(211)=Y3
15714 VINT(212)=Y3MAX
15715 VINT(213)=EPS
15716 IF(EPS.GT.0D0) THEN
15717 VINT(214)=1D0/WTP
15718 VINT(215)=T1P
15719 VINT(216)=T2P
15720 ELSE
15721 VINT(214)=1D0/WTN
15722 VINT(215)=T1N
15723 VINT(216)=T2N
15724 ENDIF
15725 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
15726 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
15727 VINT(219)=0.5D0*(PMS12-PTS3)
15728 VINT(220)=SQL12
15729 ENDIF
15730
15731 RETURN
15732 END
15733
15734C***********************************************************************
15735
15736C...PYSIGH
15737C...Differential matrix elements for all included subprocesses
15738C...Note that what is coded is (disregarding the COMFAC factor)
15739C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15740C...when d(sigma-hat) is given in the zero-width limit, the delta
15741C...function in tau is replaced by a (modified) Breit-Wigner:
15742C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
15743C...where H_res = s-hat/m_res*Gamma_res(s-hat);
15744C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15745C...i.e., dimensionless quantities
15746C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
15747C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
15748C...(2pi)^4 delta^4(P - sum p_i)
15749C...COMFAC contains the factor pi/s (or equivalent) and
15750C...the conversion factor from GeV^-2 to mb
15751
15752 SUBROUTINE PYSIGH(NCHN,SIGS)
15753
15754C...Double precision and integer declarations
15755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15756 INTEGER PYK,PYCHGE,PYCOMP
15757C...Parameter statement to help give large particle numbers.
15758 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
15759C...Commonblocks
15760 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15761 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15762 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15763 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15764 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15765 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15766 COMMON/PYINT1/MINT(400),VINT(400)
15767 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15768 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15769 COMMON/PYINT4/MWID(500),WIDS(500,5)
15770 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15771 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15772 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15773 &SFMIX(16,4)
15774 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15775 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
15776 &/PYSSMT/
15777C...Local arrays and complex variables
15778 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
15779 &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
15780 COMPLEX A004,A204,A114,A00U,A20U,A11U
15781 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
15782 &COULCK,COULCP,COULCD,COULCR,COULCS
15783 REAL A00L,A11L,A20L,COULXX
15784
15785C...Reset number of channels and cross-section
15786 NCHN=0
15787 SIGS=0D0
15788
15789C...Convert H or A process into equivalent h one
15790 ISUB=MINT(1)
15791 ISUBSV=ISUB
15792 IHIGG=1
15793 KFHIGG=25
15794 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
15795 &ISUB.LE.190)) THEN
15796 IHIGG=2
15797 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
15798 KFHIGG=33+IHIGG
15799 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
15800 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
15801 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
15802 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
15803 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
15804 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
15805 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
15806 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
15807 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
15808 ENDIF
15809
15810CMRENNA++
15811C...Convert almost equivalent SUSY processes into each other
15812C...Extract differences in flavours and couplings
15813 IF(ISUB.GE.200.AND.ISUB.LE.280) THEN
15814
15815C...Sleptons and sneutrinos
15816 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
15817 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15818 ISUB=201
15819 ILR=0
15820 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
15821 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15822 ISUB=201
15823 ILR=1
15824 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
15825 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15826 ISUB=203
15827 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
15828 IF(ISUB.EQ.210) THEN
15829 RKF=2.0D0
15830 ELSEIF(ISUB.EQ.211) THEN
15831 RKF=SFMIX(15,1)**2
15832 ELSEIF(ISUB.EQ.212) THEN
15833 RKF=SFMIX(15,2)**2
15834 ENDIF
15835 ISUB=210
15836 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
15837 IF(ISUB.EQ.213) THEN
15838 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15839 RKF=2.0D0
15840 ELSEIF(ISUB.EQ.214) THEN
15841 KFID=16
15842 RKF=1.0D0
15843 ENDIF
15844 ISUB=213
15845
15846C...Neutralinos
15847 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
15848 IF(ISUB.EQ.216) THEN
15849 IZID1=1
15850 IZID2=1
15851 ELSEIF(ISUB.EQ.217) THEN
15852 IZID1=2
15853 IZID2=2
15854 ELSEIF(ISUB.EQ.218) THEN
15855 IZID1=3
15856 IZID2=3
15857 ELSEIF(ISUB.EQ.219) THEN
15858 IZID1=4
15859 IZID2=4
15860 ELSEIF(ISUB.EQ.220) THEN
15861 IZID1=1
15862 IZID2=2
15863 ELSEIF(ISUB.EQ.221) THEN
15864 IZID1=1
15865 IZID2=3
15866 ELSEIF(ISUB.EQ.222) THEN
15867 IZID1=1
15868 IZID2=4
15869 ELSEIF(ISUB.EQ.223) THEN
15870 IZID1=2
15871 IZID2=3
15872 ELSEIF(ISUB.EQ.224) THEN
15873 IZID1=2
15874 IZID2=4
15875 ELSEIF(ISUB.EQ.225) THEN
15876 IZID1=3
15877 IZID2=4
15878 ENDIF
15879 ISUB=216
15880
15881C...Charginos
15882 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
15883 IF(ISUB.EQ.226) THEN
15884 IZID1=1
15885 IZID2=1
15886 ELSEIF(ISUB.EQ.227) THEN
15887 IZID1=2
15888 IZID2=2
15889 ELSEIF(ISUB.EQ.228) THEN
15890 IZID1=1
15891 IZID2=2
15892 ENDIF
15893 ISUB=226
15894
15895C...Neutralino + chargino
15896 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
15897 IF(ISUB.EQ.229) THEN
15898 IZID1=1
15899 IZID2=1
15900 ELSEIF(ISUB.EQ.230) THEN
15901 IZID1=1
15902 IZID2=2
15903 ELSEIF(ISUB.EQ.231) THEN
15904 IZID1=1
15905 IZID2=3
15906 ELSEIF(ISUB.EQ.232) THEN
15907 IZID1=1
15908 IZID2=4
15909 ELSEIF(ISUB.EQ.233) THEN
15910 IZID1=2
15911 IZID2=1
15912 ELSEIF(ISUB.EQ.234) THEN
15913 IZID1=2
15914 IZID2=2
15915 ELSEIF(ISUB.EQ.235) THEN
15916 IZID1=2
15917 IZID2=3
15918 ELSEIF(ISUB.EQ.236) THEN
15919 IZID1=2
15920 IZID2=4
15921 ENDIF
15922 ISUB=229
15923
15924C...Gluino + neutralino
15925 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
15926 IF(ISUB.EQ.237) THEN
15927 IZID=1
15928 ELSEIF(ISUB.EQ.238) THEN
15929 IZID=2
15930 ELSEIF(ISUB.EQ.239) THEN
15931 IZID=3
15932 ELSEIF(ISUB.EQ.240) THEN
15933 IZID=4
15934 ENDIF
15935 ISUB=237
15936
15937C...Gluino + chargino
15938 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
15939 IF(ISUB.EQ.241) THEN
15940 IZID=1
15941 ELSEIF(ISUB.EQ.242) THEN
15942 IZID=2
15943 ENDIF
15944 ISUB=241
15945
15946C...Squark + neutralino
15947 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
15948 ILR=0
15949 IF(MOD(ISUB,2).NE.0) ILR=1
15950 IF(ISUB.LE.247) THEN
15951 IZID=1
15952 ELSEIF(ISUB.LE.249) THEN
15953 IZID=2
15954 ELSEIF(ISUB.LE.251) THEN
15955 IZID=3
15956 ELSEIF(ISUB.LE.253) THEN
15957 IZID=4
15958 ENDIF
15959 ISUB=246
15960 RKF=5D0
15961
15962C...Squark + chargino
15963 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
15964 IF(ISUB.LE.255) THEN
15965 IZID=1
15966 ELSEIF(ISUB.LE.257) THEN
15967 IZID=2
15968 ENDIF
15969 IF(MOD(ISUB,2).EQ.0) THEN
15970 ILR=0
15971 ELSE
15972 ILR=1
15973 ENDIF
15974 ISUB=254
15975 RKF=5D0
15976
15977C...Squark + gluino
15978 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
15979 ISUB=258
15980 RKF=5D0
15981
15982C...Stops
15983 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
15984 ILR=0
15985 IF(ISUB.EQ.262) ILR=1
15986 ISUB=261
15987 ELSEIF(ISUB.EQ.265) THEN
15988 ISUB=264
15989
15990C...Squarks
15991 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
15992 ILR=0
15993 IF(ISUB.LE.273) THEN
15994 IF(ISUB.EQ.273) ILR=1
15995 ISUB=271
15996 RKF=25D0
15997 ELSEIF(ISUB.LE.276) THEN
15998 IF(ISUB.EQ.276) ILR=1
15999 ISUB=274
16000 RKF=25D0
16001 ELSEIF(ISUB.LE.278) THEN
16002 IF(ISUB.EQ.278) ILR=1
16003 ISUB=277
16004 RKF=5D0
16005 ELSE
16006 IF(ISUB.EQ.280) ILR=1
16007 ISUB=279
16008 RKF=5D0
16009 ENDIF
16010 ENDIF
16011 ENDIF
16012CMRENNA--
16013
16014C...Read kinematical variables and limits
16015 ISTSB=ISET(ISUBSV)
16016 TAUMIN=VINT(11)
16017 YSTMIN=VINT(12)
16018 CTNMIN=VINT(13)
16019 CTPMIN=VINT(14)
16020 TAUPMN=VINT(16)
16021 TAU=VINT(21)
16022 YST=VINT(22)
16023 CTH=VINT(23)
16024 XT2=VINT(25)
16025 TAUP=VINT(26)
16026 TAUMAX=VINT(31)
16027 YSTMAX=VINT(32)
16028 CTNMAX=VINT(33)
16029 CTPMAX=VINT(34)
16030 TAUPMX=VINT(36)
16031
16032C...Derive kinematical quantities
16033 TAUE=TAU
16034 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
16035 X(1)=SQRT(TAUE)*EXP(YST)
16036 X(2)=SQRT(TAUE)*EXP(-YST)
16037 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
16038 IF(X(1).GT.0.9999D0) RETURN
16039 ELSEIF(MINT(45).EQ.3) THEN
16040 X(1)=MIN(0.9999989D0,X(1))
16041 ENDIF
16042 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
16043 IF(X(2).GT.0.9999D0) RETURN
16044 ELSEIF(MINT(46).EQ.3) THEN
16045 X(2)=MIN(0.9999989D0,X(2))
16046 ENDIF
16047 SH=TAU*VINT(2)
16048 SQM3=VINT(63)
16049 SQM4=VINT(64)
16050 RM3=SQM3/SH
16051 RM4=SQM4/SH
16052 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
16053 RPTS=4D0*VINT(71)**2/SH
16054 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
16055 RM34=MAX(1D-20,2D0*RM3*RM4)
16056 RSQM=1D0+RM34
16057 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) RM34=MAX(RM34,
16058 &2D0*VINT(71)**2/(VINT(21)*VINT(2)))
16059 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
16060 IF(ISTSB.EQ.0) THEN
16061 TH=VINT(45)
16062 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16063 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
16064 ELSE
16065 TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
16066 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16067 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
16068 ENDIF
16069 SHR=SQRT(SH)
16070 SH2=SH**2
16071 TH2=TH**2
16072 UH2=UH**2
16073
16074C...Choice of Q2 scale: hard, parton distributions, parton showers
16075 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
16076 Q2=SH
16077 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
16078 IF(MSTP(32).EQ.1) THEN
16079 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
16080 ELSEIF(MSTP(32).EQ.2) THEN
16081 Q2=SQPTH+0.5D0*(SQM3+SQM4)
16082 ELSEIF(MSTP(32).EQ.3) THEN
16083 Q2=MIN(-TH,-UH)
16084 ELSEIF(MSTP(32).EQ.4) THEN
16085 Q2=SH
16086 ELSEIF(MSTP(32).EQ.5) THEN
16087 Q2=-TH
16088 ENDIF
16089 IF(ISTSB.EQ.9) Q2=SQPTH
16090 IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND.
16091 & MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2
16092 ENDIF
16093 Q2SF=Q2
16094 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16095 Q2SF=PMAS(23,1)**2
16096 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124)
16097 & Q2SF=PMAS(24,1)**2
16098 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
16099 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
16100 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
16101 IF(MSTP(39).EQ.3) Q2SF=SH
16102 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
16103 ENDIF
16104 ENDIF
16105 Q2PS=Q2SF
16106 Q2SF=Q2SF*PARP(34)
16107 IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2)
16108 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
16109 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
16110 XBJ=X(2)
16111 IF(MINT(43).EQ.3) XBJ=X(1)
16112 IF(MSTP(22).EQ.1) THEN
16113 Q2PS=-TH
16114 ELSEIF(MSTP(22).EQ.2) THEN
16115 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
16116 ELSEIF(MSTP(22).EQ.3) THEN
16117 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
16118 ELSE
16119 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
16120 ENDIF
16121 ENDIF
16122 IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2)
16123
16124C...Store derived kinematical quantities
16125 VINT(41)=X(1)
16126 VINT(42)=X(2)
16127 VINT(44)=SH
16128 VINT(43)=SQRT(SH)
16129 VINT(45)=TH
16130 VINT(46)=UH
16131 VINT(48)=SQPTH
16132 VINT(47)=SQRT(SQPTH)
16133 VINT(50)=TAUP*VINT(2)
16134 VINT(49)=SQRT(MAX(0D0,VINT(50)))
16135 VINT(52)=Q2
16136 VINT(51)=SQRT(Q2)
16137 VINT(54)=Q2SF
16138 VINT(53)=SQRT(Q2SF)
16139 VINT(56)=Q2PS
16140 VINT(55)=SQRT(Q2PS)
16141
16142C...Calculate parton distributions
16143 IF(ISTSB.LE.0) GOTO 170
16144 IF(MINT(47).GE.2) THEN
16145 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
16146 XSF=X(I)
16147 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
16148 MINT(105)=MINT(102+I)
16149 MINT(109)=MINT(106+I)
16150 IF(MSTP(57).LE.1) THEN
16151 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
16152 ELSE
16153 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
16154 ENDIF
16155 DO 100 KFL=-25,25
16156 XSFX(I,KFL)=XPQ(KFL)
16157 100 CONTINUE
16158 110 CONTINUE
16159 ENDIF
16160
16161C...Calculate alpha_em, alpha_strong and K-factor
16162 XW=PARU(102)
16163 XWV=XW
16164 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
16165 &1D0-(PMAS(24,1)/PMAS(23,1))**2
16166 XW1=1D0-XW
16167 XWC=1D0/(16D0*XW*XW1)
16168 AEM=PYALEM(Q2)
16169 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16170 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
16171 FACK=1D0
16172 FACA=1D0
16173 IF(MSTP(33).EQ.1) THEN
16174 FACK=PARP(31)
16175 ELSEIF(MSTP(33).EQ.2) THEN
16176 FACK=PARP(31)
16177 FACA=PARP(32)/PARP(31)
16178 ELSEIF(MSTP(33).EQ.3) THEN
16179 Q2AS=PARP(33)*Q2
16180 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
16181 & PARU(112)*PARP(82)
16182 AS=PYALPS(Q2AS)
16183 ENDIF
16184 VINT(138)=1D0
16185 VINT(57)=AEM
16186 VINT(58)=AS
16187
16188C...Set flags for allowed reacting partons/leptons
16189 DO 140 I=1,2
16190 DO 120 J=-25,25
16191 KFAC(I,J)=0
16192 120 CONTINUE
16193 IF(MINT(44+I).EQ.1) THEN
16194 KFAC(I,MINT(10+I))=1
16195 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
16196 KFAC(I,MINT(10+I))=1
16197 KFAC(I,22)=1
16198 KFAC(I,24)=1
16199 KFAC(I,-24)=1
16200 ELSE
16201 DO 130 J=-25,25
16202 KFAC(I,J)=KFIN(I,J)
16203 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
16204 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
16205 130 CONTINUE
16206 ENDIF
16207 140 CONTINUE
16208
16209C...Lower and upper limit for fermion flavour loops
16210 MMIN1=0
16211 MMAX1=0
16212 MMIN2=0
16213 MMAX2=0
16214 DO 150 J=-20,20
16215 IF(KFAC(1,-J).EQ.1) MMIN1=-J
16216 IF(KFAC(1,J).EQ.1) MMAX1=J
16217 IF(KFAC(2,-J).EQ.1) MMIN2=-J
16218 IF(KFAC(2,J).EQ.1) MMAX2=J
16219 150 CONTINUE
16220 MMINA=MIN(MMIN1,MMIN2)
16221 MMAXA=MAX(MMAX1,MMAX2)
16222
16223C...Common resonance mass and width combinations
16224 SQMZ=PMAS(23,1)**2
16225 SQMW=PMAS(24,1)**2
16226 SQMH=PMAS(KFHIGG,1)**2
16227 GMMZ=PMAS(23,1)*PMAS(23,2)
16228 GMMW=PMAS(24,1)*PMAS(24,2)
16229 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
16230C...MRENNA+++
16231 ZWID=PMAS(23,2)
16232 WWID=PMAS(24,2)
16233 TANW=SQRT(XW/XW1)
16234C...MRENNA---
16235
16236C...Phase space integral in tau
16237 COMFAC=PARU(1)*PARU(5)/VINT(2)
16238 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
16239 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
16240 &ISTSB.NE.9) THEN
16241 ATAU1=LOG(TAUMAX/TAUMIN)
16242 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16243 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
16244 IF(MINT(72).GE.1) THEN
16245 TAUR1=VINT(73)
16246 GAMR1=VINT(74)
16247 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
16248 ATAU3=ATAUD/TAUR1
16249 IF(ATAUD.GT.1D-6) H1=H1+
16250 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
16251 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
16252 ATAU4=ATAUD/GAMR1
16253 IF(ATAUD.GT.1D-6) H1=H1+
16254 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16255 ENDIF
16256 IF(MINT(72).EQ.2) THEN
16257 TAUR2=VINT(75)
16258 GAMR2=VINT(76)
16259 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
16260 ATAU5=ATAUD/TAUR2
16261 IF(ATAUD.GT.1D-6) H1=H1+
16262 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
16263 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
16264 ATAU6=ATAUD/GAMR2
16265 IF(ATAUD.GT.1D-6) H1=H1+
16266 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16267 ENDIF
16268 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
16269 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
16270 IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
16271 & MAX(2D-6,1D0-TAU)
16272 ENDIF
16273 COMFAC=COMFAC*ATAU1/(TAU*H1)
16274 ENDIF
16275
16276C...Phase space integral in y*
16277 IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN
16278 AYST0=YSTMAX-YSTMIN
16279 IF(AYST0.LT.1D-6) THEN
16280 COMFAC=0D0
16281 ELSE
16282 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16283 AYST2=AYST1
16284 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16285 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16286 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16287 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16288 IF(MINT(45).EQ.3) THEN
16289 YST0=-0.5D0*LOG(TAUE)
16290 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
16291 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
16292 IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
16293 & MAX(1D-6,1D0-EXP(YST-YST0))
16294 ENDIF
16295 IF(MINT(46).EQ.3) THEN
16296 YST0=-0.5D0*LOG(TAUE)
16297 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
16298 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
16299 IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
16300 & MAX(1D-6,1D0-EXP(-YST-YST0))
16301 ENDIF
16302 COMFAC=COMFAC*AYST0/H2
16303 ENDIF
16304 ENDIF
16305
16306C...2 -> 1 processes: reduction in angular part of phase space integral
16307C...for case of decaying resonance
16308 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16309 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
16310 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
16311 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
16312 & KFPR(ISUB,1).EQ.39) THEN
16313 COMFAC=COMFAC*0.5D0*ACTH0
16314 ELSE
16315 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
16316 & CTPMAX**3-CTPMIN**3)
16317 ENDIF
16318 ENDIF
16319
16320C...2 -> 2 processes: angular part of phase space integral
16321 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
16322 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16323 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16324 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16325 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16326 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
16327 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
16328 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
16329 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
16330 H3=COEF(ISUBSV,13)+
16331 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
16332 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
16333 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
16334 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
16335 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
16336
16337C...2 -> 2 processes: take into account final state Breit-Wigners
16338 COMFAC=COMFAC*VINT(80)
16339 ENDIF
16340
16341C...2 -> 3, 4 processes: phace space integral in tau'
16342 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16343 ATAUP1=LOG(TAUPMX/TAUPMN)
16344 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
16345 H4=COEF(ISUBSV,18)+
16346 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
16347 IF(MINT(47).EQ.5) THEN
16348 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
16349 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,1D0-TAUP)
16350 ENDIF
16351 COMFAC=COMFAC*ATAUP1/H4
16352 ENDIF
16353
16354C...2 -> 3, 4 processes: effective W/Z parton distributions
16355 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
16356 IF(1D0-TAU/TAUP.GT.1.D-4) THEN
16357 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
16358 ELSE
16359 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
16360 ENDIF
16361 COMFAC=COMFAC*FZW
16362 ENDIF
16363
16364C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
16365 IF(ISTSB.EQ.5) THEN
16366 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
16367 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
16368 ENDIF
16369
16370C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
16371 IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC*
16372 &SQPTH**2/(PARP(82)**2+SQPTH)**2
16373
16374C...gamma + gamma: include factor 2 when different nature
16375 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4)
16376 &COMFAC=2D0*COMFAC
16377
16378C...Phase space integral for low-pT and multiple interactions
16379 IF(ISTSB.EQ.9) THEN
16380 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
16381 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
16382 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
16383 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
16384 COMFAC=COMFAC*ATAU1/H1
16385 AYST0=YSTMAX-YSTMIN
16386 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16387 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16388 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16389 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16390 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16391 COMFAC=COMFAC*AYST0/H2
16392 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
16393C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16394C...introduced to make cross-section finite for xT2 -> 0
16395 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16396 & (1D0+VINT(149)))
16397 ENDIF
16398
16399C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
16400 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
16401 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
16402C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
16403 IF(MSTP(46).LE.4) THEN
16404 HDTLH=LOG(PMAS(25,1)/PARP(44))
16405 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
16406 HDTNR=-1D0/18D0+HDTLH/6D0
16407 ELSE
16408 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
16409 HDTLQ=LOG(PARP(45)/PARP(44))
16410 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
16411 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
16412 ENDIF
16413
16414C...Calculate lowest and next-to-lowest order partial wave amplitudes
16415 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
16416 A00L=SNGL(HDTV*SH)
16417 A20L=-0.5*A00L
16418 A11L=A00L/6.
16419 HDTLS=LOG(SH/PARP(44)**2)
16420 A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16421 & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
16422 & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
16423 A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16424 & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
16425 & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
16426 A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
16427 & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
16428
16429C...Unitarize partial wave amplitudes with Pade or K-matrix method
16430 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
16431 A00U=A00L/(1.-A004/A00L)
16432 A20U=A20L/(1.-A204/A20L)
16433 A11U=A11L/(1.-A114/A11L)
16434 ELSE
16435 A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
16436 A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
16437 A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
16438 ENDIF
16439 ENDIF
16440
16441C...Supersymmetric processes - all of type 2 -> 2 :
16442C...correct final-state Breit-Wigners from fixed to running width.
16443 IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN
16444 DO 160 I=1,2
16445 KFLW=KFPR(ISUBSV,I)
16446 KCW=PYCOMP(KFLW)
16447 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
16448 IF(I.EQ.1) SQMI=SQM3
16449 IF(I.EQ.2) SQMI=SQM4
16450 SQMS=PMAS(KCW,1)**2
16451 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
16452 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
16453 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
16454 GMMI=SQRT(SQMI)*WDTP(0)
16455 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
16456 COMFAC=COMFAC*(HBWI/HBWS)
16457 160 CONTINUE
16458 ENDIF
16459
16460C...A: 2 -> 1, tree diagrams
16461
16462 170 IF(ISUB.LE.10) THEN
16463 IF(ISUB.EQ.1) THEN
16464C...f + fbar -> gamma*/Z0
16465 MINT(61)=2
16466 CALL PYWIDT(23,SH,WDTP,WDTE)
16467 HS=SHR*WDTP(0)
16468 FACZ=4D0*COMFAC*3D0
16469 HP0=AEM/3D0*SH
16470 HP1=AEM/3D0*XWC*SH
16471 DO 180 I=MMINA,MMAXA
16472 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16473 EI=KCHG(IABS(I),1)/3D0
16474 AI=SIGN(1D0,EI)
16475 VI=AI-4D0*EI*XWV
16476 HI0=HP0
16477 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
16478 HI1=HP1
16479 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
16480 NCHN=NCHN+1
16481 ISIG(NCHN,1)=I
16482 ISIG(NCHN,2)=-I
16483 ISIG(NCHN,3)=1
16484 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
16485 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
16486 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
16487 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
16488 180 CONTINUE
16489
16490 ELSEIF(ISUB.EQ.2) THEN
16491C...f + fbar' -> W+/-
16492 CALL PYWIDT(24,SH,WDTP,WDTE)
16493 HS=SHR*WDTP(0)
16494 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
16495 HP=AEM/(24D0*XW)*SH
16496 DO 200 I=MMIN1,MMAX1
16497 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16498 IA=IABS(I)
16499 DO 190 J=MMIN2,MMAX2
16500 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16501 JA=IABS(J)
16502 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
16503 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16504 & GOTO 190
16505 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16506 HI=HP*2D0
16507 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
16508 NCHN=NCHN+1
16509 ISIG(NCHN,1)=I
16510 ISIG(NCHN,2)=J
16511 ISIG(NCHN,3)=1
16512 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16513 SIGH(NCHN)=HI*FACBW*HF
16514 190 CONTINUE
16515 200 CONTINUE
16516
16517 ELSEIF(ISUB.EQ.3) THEN
16518C...f + fbar -> h0 (or H0, or A0)
16519 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
16520 HS=SHR*WDTP(0)
16521 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16522 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
16523 & FACBW=0D0
16524 HP=AEM/(8D0*XW)*SH/SQMW*SH
16525 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16526 DO 210 I=MMINA,MMAXA
16527 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
16528 IA=IABS(I)
16529 RMQ=PMAS(IA,1)**2/SH
16530 HI=HP*RMQ
16531 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
16532 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI*
16533 & (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/
16534 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
16535 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16536 IKFI=1
16537 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
16538 IF(IA.GT.10) IKFI=3
16539 HI=HI*PARU(150+10*IHIGG+IKFI)**2
16540 ENDIF
16541 NCHN=NCHN+1
16542 ISIG(NCHN,1)=I
16543 ISIG(NCHN,2)=-I
16544 ISIG(NCHN,3)=1
16545 SIGH(NCHN)=HI*FACBW*HF
16546 210 CONTINUE
16547
16548 ELSEIF(ISUB.EQ.4) THEN
16549C...gamma + W+/- -> W+/-
16550
16551 ELSEIF(ISUB.EQ.5) THEN
16552C...Z0 + Z0 -> h0
16553 CALL PYWIDT(25,SH,WDTP,WDTE)
16554 HS=SHR*WDTP(0)
16555 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16556 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16557 HP=AEM/(8D0*XW)*SH/SQMW*SH
16558 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16559 HI=HP/4D0
16560 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
16561 DO 230 I=MMIN1,MMAX1
16562 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
16563 DO 220 J=MMIN2,MMAX2
16564 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
16565 EI=KCHG(IABS(I),1)/3D0
16566 AI=SIGN(1D0,EI)
16567 VI=AI-4D0*EI*XWV
16568 EJ=KCHG(IABS(J),1)/3D0
16569 AJ=SIGN(1D0,EJ)
16570 VJ=AJ-4D0*EJ*XWV
16571 NCHN=NCHN+1
16572 ISIG(NCHN,1)=I
16573 ISIG(NCHN,2)=J
16574 ISIG(NCHN,3)=1
16575 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
16576 220 CONTINUE
16577 230 CONTINUE
16578
16579 ELSEIF(ISUB.EQ.6) THEN
16580C...Z0 + W+/- -> W+/-
16581
16582 ELSEIF(ISUB.EQ.7) THEN
16583C...W+ + W- -> Z0
16584
16585 ELSEIF(ISUB.EQ.8) THEN
16586C...W+ + W- -> h0
16587 CALL PYWIDT(25,SH,WDTP,WDTE)
16588 HS=SHR*WDTP(0)
16589 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16590 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16591 HP=AEM/(8D0*XW)*SH/SQMW*SH
16592 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16593 HI=HP/2D0
16594 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
16595 DO 250 I=MMIN1,MMAX1
16596 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
16597 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
16598 DO 240 J=MMIN2,MMAX2
16599 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
16600 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
16601 IF(EI*EJ.GT.0D0) GOTO 240
16602 NCHN=NCHN+1
16603 ISIG(NCHN,1)=I
16604 ISIG(NCHN,2)=J
16605 ISIG(NCHN,3)=1
16606 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
16607 240 CONTINUE
16608 250 CONTINUE
16609
16610C...B: 2 -> 2, tree diagrams
16611
16612 ELSEIF(ISUB.EQ.10) THEN
16613C...f + f' -> f + f' (gamma/Z/W exchange)
16614 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
16615 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
16616 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
16617 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
16618 DO 270 I=MMIN1,MMAX1
16619 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
16620 IA=IABS(I)
16621 DO 260 J=MMIN2,MMAX2
16622 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
16623 JA=IABS(J)
16624C...Electroweak couplings
16625 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
16626 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
16627 VI=AI-4D0*EI*XWV
16628 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
16629 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
16630 VJ=AJ-4D0*EJ*XWV
16631 EPSIJ=ISIGN(1,I*J)
16632C...gamma/Z exchange, only gamma exchange, or only Z exchange
16633 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
16634 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
16635 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
16636 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
16637 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
16638 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16639 ELSEIF(MSTP(21).EQ.2) THEN
16640 FACNCF=FACGGF*EI**2*EJ**2
16641 ELSE
16642 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
16643 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16644 ENDIF
16645 NCHN=NCHN+1
16646 ISIG(NCHN,1)=I
16647 ISIG(NCHN,2)=J
16648 ISIG(NCHN,3)=1
16649 SIGH(NCHN)=FACNCF
16650 ENDIF
16651C...W exchange
16652 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
16653 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
16654 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
16655 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
16656 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
16657 NCHN=NCHN+1
16658 ISIG(NCHN,1)=I
16659 ISIG(NCHN,2)=J
16660 ISIG(NCHN,3)=2
16661 SIGH(NCHN)=FACCCF
16662 ENDIF
16663 260 CONTINUE
16664 270 CONTINUE
16665 ENDIF
16666
16667 ELSEIF(ISUB.LE.20) THEN
16668 IF(ISUB.EQ.11) THEN
16669C...f + f' -> f + f' (g exchange)
16670 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
16671 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
16672 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
16673 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
16674 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
16675 IF(MSTP(5).GE.1) THEN
16676C...Modifications from contact interactions (compositeness)
16677 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
16678 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16679 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
16680 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16681 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
16682 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
16683 ENDIF
16684 DO 290 I=MMIN1,MMAX1
16685 IA=IABS(I)
16686 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
16687 DO 280 J=MMIN2,MMAX2
16688 JA=IABS(J)
16689 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
16690 NCHN=NCHN+1
16691 ISIG(NCHN,1)=I
16692 ISIG(NCHN,2)=J
16693 ISIG(NCHN,3)=1
16694 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
16695 & JA.GE.3))) THEN
16696 SIGH(NCHN)=FACQQ1
16697 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16698 ELSE
16699 SIGH(NCHN)=FACCI1
16700 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
16701 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
16702 ENDIF
16703 IF(I.EQ.J) THEN
16704 SIGH(NCHN)=0.5D0*SIGH(NCHN)
16705 NCHN=NCHN+1
16706 ISIG(NCHN,1)=I
16707 ISIG(NCHN,2)=J
16708 ISIG(NCHN,3)=2
16709 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
16710 SIGH(NCHN)=0.5D0*FACQQ2
16711 ELSE
16712 SIGH(NCHN)=0.5D0*FACCI2
16713 ENDIF
16714 ENDIF
16715 280 CONTINUE
16716 290 CONTINUE
16717
16718 ELSEIF(ISUB.EQ.12) THEN
16719C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
16720 CALL PYWIDT(21,SH,WDTP,WDTE)
16721 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
16722 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16723 IF(MSTP(5).EQ.1) THEN
16724C...Modifications from contact interactions (compositeness)
16725 FACCIB=FACQQB
16726 DO 300 I=1,2
16727 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
16728 & WDTE(I,2)+WDTE(I,4))
16729 300 CONTINUE
16730 ELSEIF(MSTP(5).GE.2) THEN
16731 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
16732 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16733 ENDIF
16734 DO 310 I=MMINA,MMAXA
16735 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16736 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16737 NCHN=NCHN+1
16738 ISIG(NCHN,1)=I
16739 ISIG(NCHN,2)=-I
16740 ISIG(NCHN,3)=1
16741 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
16742 SIGH(NCHN)=FACQQB
16743 ELSE
16744 SIGH(NCHN)=FACCIB
16745 ENDIF
16746 310 CONTINUE
16747
16748 ELSEIF(ISUB.EQ.13) THEN
16749C...f + fbar -> g + g (q + qbar -> g + g only)
16750 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
16751 & UH2/SH2)
16752 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
16753 & TH2/SH2)
16754 DO 320 I=MMINA,MMAXA
16755 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16756 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16757 NCHN=NCHN+1
16758 ISIG(NCHN,1)=I
16759 ISIG(NCHN,2)=-I
16760 ISIG(NCHN,3)=1
16761 SIGH(NCHN)=0.5D0*FACGG1
16762 NCHN=NCHN+1
16763 ISIG(NCHN,1)=I
16764 ISIG(NCHN,2)=-I
16765 ISIG(NCHN,3)=2
16766 SIGH(NCHN)=0.5D0*FACGG2
16767 320 CONTINUE
16768
16769 ELSEIF(ISUB.EQ.14) THEN
16770C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
16771 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
16772 DO 330 I=MMINA,MMAXA
16773 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16774 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
16775 EI=KCHG(IABS(I),1)/3D0
16776 NCHN=NCHN+1
16777 ISIG(NCHN,1)=I
16778 ISIG(NCHN,2)=-I
16779 ISIG(NCHN,3)=1
16780 SIGH(NCHN)=FACGG*EI**2
16781 330 CONTINUE
16782
16783 ELSEIF(ISUB.EQ.15) THEN
16784C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
16785 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16786C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16787 HFGG=0D0
16788 HFGZ=0D0
16789 HFZZ=0D0
16790 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16791 DO 340 I=1,MIN(16,MDCY(23,3))
16792 IDC=I+MDCY(23,2)-1
16793 IF(MDME(IDC,1).LT.0) GOTO 340
16794 IMDM=0
16795 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16796 & IMDM=1
16797 IF(I.LE.8) THEN
16798 EF=KCHG(I,1)/3D0
16799 AF=SIGN(1D0,EF+0.1D0)
16800 VF=AF-4D0*EF*XWV
16801 ELSEIF(I.LE.16) THEN
16802 EF=KCHG(I+2,1)/3D0
16803 AF=SIGN(1D0,EF+0.1D0)
16804 VF=AF-4D0*EF*XWV
16805 ENDIF
16806 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16807 IF(4D0*RM1.LT.1D0) THEN
16808 FCOF=1D0
16809 IF(I.LE.8) FCOF=3D0*RADC4
16810 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16811 IF(IMDM.EQ.1) THEN
16812 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16813 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16814 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16815 & AF**2*(1D0-4D0*RM1))*BE34
16816 ENDIF
16817 ENDIF
16818 340 CONTINUE
16819C...Propagators: as simulated in PYOFSH and as desired
16820 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16821 MINT(15)=1
16822 MINT(61)=1
16823 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16824 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16825 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16826 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16827 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16828C...Loop over flavours; consider full gamma/Z structure
16829 DO 350 I=MMINA,MMAXA
16830 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16831 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16832 EI=KCHG(IABS(I),1)/3D0
16833 AI=SIGN(1D0,EI)
16834 VI=AI-4D0*EI*XWV
16835 NCHN=NCHN+1
16836 ISIG(NCHN,1)=I
16837 ISIG(NCHN,2)=-I
16838 ISIG(NCHN,3)=1
16839 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
16840 & (VI**2+AI**2)*HFZZ)/HBW4
16841 350 CONTINUE
16842
16843 ELSEIF(ISUB.EQ.16) THEN
16844C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
16845 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16846C...Propagators: as simulated in PYOFSH and as desired
16847 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16848 CALL PYWIDT(24,SQM4,WDTP,WDTE)
16849 GMMWC=SQRT(SQM4)*WDTP(0)
16850 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16851 FACWG=FACWG*HBW4C/HBW4
16852 DO 370 I=MMIN1,MMAX1
16853 IA=IABS(I)
16854 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
16855 DO 360 J=MMIN2,MMAX2
16856 JA=IABS(J)
16857 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
16858 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16859 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16860 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16861 FCKM=VCKM((IA+1)/2,(JA+1)/2)
16862 NCHN=NCHN+1
16863 ISIG(NCHN,1)=I
16864 ISIG(NCHN,2)=J
16865 ISIG(NCHN,3)=1
16866 SIGH(NCHN)=FACWG*FCKM*WIDSC
16867 360 CONTINUE
16868 370 CONTINUE
16869
16870 ELSEIF(ISUB.EQ.17) THEN
16871C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
16872
16873 ELSEIF(ISUB.EQ.18) THEN
16874C...f + fbar -> gamma + gamma
16875 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
16876 DO 380 I=MMINA,MMAXA
16877 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16878 EI=KCHG(IABS(I),1)/3D0
16879 FCOI=1D0
16880 IF(IABS(I).LE.10) FCOI=FACA/3D0
16881 NCHN=NCHN+1
16882 ISIG(NCHN,1)=I
16883 ISIG(NCHN,2)=-I
16884 ISIG(NCHN,3)=1
16885 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
16886 380 CONTINUE
16887
16888 ELSEIF(ISUB.EQ.19) THEN
16889C...f + fbar -> gamma + (gamma*/Z0)
16890 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16891C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16892 HFGG=0D0
16893 HFGZ=0D0
16894 HFZZ=0D0
16895 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16896 DO 390 I=1,MIN(16,MDCY(23,3))
16897 IDC=I+MDCY(23,2)-1
16898 IF(MDME(IDC,1).LT.0) GOTO 390
16899 IMDM=0
16900 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16901 & IMDM=1
16902 IF(I.LE.8) THEN
16903 EF=KCHG(I,1)/3D0
16904 AF=SIGN(1D0,EF+0.1D0)
16905 VF=AF-4D0*EF*XWV
16906 ELSEIF(I.LE.16) THEN
16907 EF=KCHG(I+2,1)/3D0
16908 AF=SIGN(1D0,EF+0.1D0)
16909 VF=AF-4D0*EF*XWV
16910 ENDIF
16911 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16912 IF(4D0*RM1.LT.1D0) THEN
16913 FCOF=1D0
16914 IF(I.LE.8) FCOF=3D0*RADC4
16915 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16916 IF(IMDM.EQ.1) THEN
16917 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16918 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16919 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16920 & AF**2*(1D0-4D0*RM1))*BE34
16921 ENDIF
16922 ENDIF
16923 390 CONTINUE
16924C...Propagators: as simulated in PYOFSH and as desired
16925 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16926 MINT(15)=1
16927 MINT(61)=1
16928 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16929 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16930 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16931 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16932 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16933C...Loop over flavours; consider full gamma/Z structure
16934 DO 400 I=MMINA,MMAXA
16935 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
16936 EI=KCHG(IABS(I),1)/3D0
16937 AI=SIGN(1D0,EI)
16938 VI=AI-4D0*EI*XWV
16939 FCOI=1D0
16940 IF(IABS(I).LE.10) FCOI=FACA/3D0
16941 NCHN=NCHN+1
16942 ISIG(NCHN,1)=I
16943 ISIG(NCHN,2)=-I
16944 ISIG(NCHN,3)=1
16945 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
16946 & (VI**2+AI**2)*HFZZ)/HBW4
16947 400 CONTINUE
16948
16949 ELSEIF(ISUB.EQ.20) THEN
16950C...f + fbar' -> gamma + W+/-
16951 FACGW=COMFAC*0.5D0*AEM**2/XW
16952C...Propagators: as simulated in PYOFSH and as desired
16953 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16954 CALL PYWIDT(24,SQM4,WDTP,WDTE)
16955 GMMWC=SQRT(SQM4)*WDTP(0)
16956 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16957 FACGW=FACGW*HBW4C/HBW4
16958C...Anomalous couplings
16959 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16960 TERM2=0D0
16961 TERM3=0D0
16962 IF(MSTP(5).GE.1) THEN
16963 TERM2=PARU(153)*(TH-UH)/(TH+UH)
16964 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
16965 & (4D0*SQMW))/(TH+UH)**2
16966 ENDIF
16967 DO 420 I=MMIN1,MMAX1
16968 IA=IABS(I)
16969 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
16970 DO 410 J=MMIN2,MMAX2
16971 JA=IABS(J)
16972 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
16973 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
16974 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16975 & GOTO 410
16976 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16977 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16978 IF(IA.LE.10) THEN
16979 FACWR=UH/(TH+UH)-1D0/3D0
16980 FCKM=VCKM((IA+1)/2,(JA+1)/2)
16981 FCOI=FACA/3D0
16982 ELSE
16983 FACWR=-TH/(TH+UH)
16984 FCKM=1D0
16985 FCOI=1D0
16986 ENDIF
16987 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
16988 NCHN=NCHN+1
16989 ISIG(NCHN,1)=I
16990 ISIG(NCHN,2)=J
16991 ISIG(NCHN,3)=1
16992 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
16993 410 CONTINUE
16994 420 CONTINUE
16995 ENDIF
16996
16997 ELSEIF(ISUB.LE.30) THEN
16998 IF(ISUB.EQ.21) THEN
16999C...f + fbar -> gamma + h0
17000
17001 ELSEIF(ISUB.EQ.22) THEN
17002C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
17003C...Kinematics dependence
17004 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
17005 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
17006C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17007 DO 440 I=1,6
17008 DO 430 J=1,3
17009 HGZ(I,J)=0D0
17010 430 CONTINUE
17011 440 CONTINUE
17012 RADC3=1D0+PYALPS(SQM3)/PARU(1)
17013 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17014 DO 450 I=1,MIN(16,MDCY(23,3))
17015 IDC=I+MDCY(23,2)-1
17016 IF(MDME(IDC,1).LT.0) GOTO 450
17017 IMDM=0
17018 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
17019 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
17020 IF(I.LE.8) THEN
17021 EF=KCHG(I,1)/3D0
17022 AF=SIGN(1D0,EF+0.1D0)
17023 VF=AF-4D0*EF*XWV
17024 ELSEIF(I.LE.16) THEN
17025 EF=KCHG(I+2,1)/3D0
17026 AF=SIGN(1D0,EF+0.1D0)
17027 VF=AF-4D0*EF*XWV
17028 ENDIF
17029 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
17030 IF(4D0*RM1.LT.1D0) THEN
17031 FCOF=1D0
17032 IF(I.LE.8) FCOF=3D0*RADC3
17033 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17034 IF(IMDM.GE.1) THEN
17035 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17036 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17037 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17038 & AF**2*(1D0-4D0*RM1))*BE34
17039 ENDIF
17040 ENDIF
17041 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17042 IF(4D0*RM1.LT.1D0) THEN
17043 FCOF=1D0
17044 IF(I.LE.8) FCOF=3D0*RADC4
17045 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17046 IF(IMDM.GE.1) THEN
17047 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17048 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17049 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17050 & AF**2*(1D0-4D0*RM1))*BE34
17051 ENDIF
17052 ENDIF
17053 450 CONTINUE
17054C...Propagators: as simulated in PYOFSH and as desired
17055 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
17056 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17057 MINT(15)=1
17058 MINT(61)=1
17059 CALL PYWIDT(23,SQM3,WDTP,WDTE)
17060 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17061 DO 460 J=1,3
17062 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
17063 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
17064 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
17065 460 CONTINUE
17066 MINT(61)=1
17067 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17068 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17069 DO 470 J=1,3
17070 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
17071 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
17072 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
17073 470 CONTINUE
17074C...Loop over flavours; separate left- and right-handed couplings
17075 DO 490 I=MMINA,MMAXA
17076 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
17077 EI=KCHG(IABS(I),1)/3D0
17078 AI=SIGN(1D0,EI)
17079 VI=AI-4D0*EI*XWV
17080 VALI=VI-AI
17081 VARI=VI+AI
17082 FCOI=1D0
17083 IF(IABS(I).LE.10) FCOI=FACA/3D0
17084 DO 480 J=1,3
17085 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
17086 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
17087 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
17088 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
17089 480 CONTINUE
17090 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
17091 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
17092 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
17093 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
17094 NCHN=NCHN+1
17095 ISIG(NCHN,1)=I
17096 ISIG(NCHN,2)=-I
17097 ISIG(NCHN,3)=1
17098 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
17099 490 CONTINUE
17100
17101 ELSEIF(ISUB.EQ.23) THEN
17102C...f + fbar' -> Z0 + W+/-
17103 FACZW=COMFAC*0.5D0*(AEM/XW)**2
17104 FACZW=FACZW*WIDS(23,2)
17105 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17106 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17107 DO 510 I=MMIN1,MMAX1
17108 IA=IABS(I)
17109 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
17110 DO 500 J=MMIN2,MMAX2
17111 JA=IABS(J)
17112 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
17113 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
17114 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17115 & GOTO 500
17116 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17117 EI=KCHG(IA,1)/3D0
17118 AI=SIGN(1D0,EI+0.1D0)
17119 VI=AI-4D0*EI*XWV
17120 EJ=KCHG(JA,1)/3D0
17121 AJ=SIGN(1D0,EJ+0.1D0)
17122 VJ=AJ-4D0*EJ*XWV
17123 IF(VI+AI.GT.0) THEN
17124 VISAV=VI
17125 AISAV=AI
17126 VI=VJ
17127 AI=AJ
17128 VJ=VISAV
17129 AJ=AISAV
17130 ENDIF
17131 FCKM=1D0
17132 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17133 FCOI=1D0
17134 IF(IA.LE.10) FCOI=FACA/3D0
17135 NCHN=NCHN+1
17136 ISIG(NCHN,1)=I
17137 ISIG(NCHN,2)=J
17138 ISIG(NCHN,3)=1
17139 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
17140 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
17141 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
17142 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
17143 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
17144 & WIDS(24,(5-KCHW)/2)
17145 500 CONTINUE
17146 510 CONTINUE
17147
17148 ELSEIF(ISUB.EQ.24) THEN
17149C...f + fbar -> Z0 + h0 (or H0, or A0)
17150 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17151 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
17152 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
17153 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
17154 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
17155 & PARU(154+10*IHIGG)**2
17156 DO 520 I=MMINA,MMAXA
17157 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
17158 EI=KCHG(IABS(I),1)/3D0
17159 AI=SIGN(1D0,EI)
17160 VI=AI-4D0*EI*XWV
17161 FCOI=1D0
17162 IF(IABS(I).LE.10) FCOI=FACA/3D0
17163 NCHN=NCHN+1
17164 ISIG(NCHN,1)=I
17165 ISIG(NCHN,2)=-I
17166 ISIG(NCHN,3)=1
17167 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
17168 520 CONTINUE
17169
17170 ELSEIF(ISUB.EQ.25) THEN
17171C...f + fbar -> W+ + W-
17172C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
17173 CALL PYWIDT(23,SH,WDTP,WDTE)
17174 GMMZC=SHR*WDTP(0)
17175 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
17176 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
17177 CALL PYWIDT(24,SQM3,WDTP,WDTE)
17178 GMMW3=SQRT(SQM3)*WDTP(0)
17179 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
17180 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17181 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17182 GMMW4=SQRT(SQM4)*WDTP(0)
17183 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
17184C...Kinematical functions
17185 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17186 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
17187 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
17188 GT=THUH34+4D0*THUH/TH2
17189 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
17190 GU=THUH34+4D0*THUH/UH2
17191 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
17192C...Common factors and couplings
17193 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
17194 FACWW=FACWW*WIDS(24,1)
17195 CGG=AEM**2/2D0
17196 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
17197 CZZ=AEM**2/(32D0*XW**2)*HBWZC
17198 CNG=AEM**2/(4D0*XW)
17199 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
17200 CNN=AEM**2/(16D0*XW**2)
17201C...Coulomb factor for W+W- pair
17202 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
17203 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
17204 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
17205 IF(COULE.LT.100D0*PMAS(24,2)) THEN
17206 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17207 & PMAS(24,2)**2)-COULE))
17208 ELSE
17209 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
17210 ENDIF
17211 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
17212 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17213 & PMAS(24,2)**2)+COULE))
17214 ELSE
17215 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
17216 & ABS(COULE)))
17217 ENDIF
17218 IF(MSTP(40).EQ.1) THEN
17219 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
17220 & MAX(1D-10,2D0*COULP*COULP1))
17221 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17222 ELSEIF(MSTP(40).EQ.2) THEN
17223 COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
17224 COULCP=CMPLX(0.,SNGL(COULP))
17225 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
17226 COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
17227 COULCS=CMPLX(0.,0.)
17228 NSTP=100
17229 DO 530 ISTP=1,NSTP
17230 COULXX=(ISTP-0.5)/NSTP
17231 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
17232 & (1.+COULXX/COULCD))
17233 530 CONTINUE
17234 COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
17235 & (COULCS/NSTP)
17236 FACCOU=ABS(COULCR)**2
17237 ELSEIF(MSTP(40).EQ.3) THEN
17238 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
17239 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
17240 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17241 ENDIF
17242 ELSEIF(MSTP(40).EQ.4) THEN
17243 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
17244 ELSE
17245 FACCOU=1D0
17246 ENDIF
17247 VINT(95)=FACCOU
17248 FACWW=FACWW*FACCOU
17249C...Loop over allowed flavours
17250 DO 540 I=MMINA,MMAXA
17251 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
17252 EI=KCHG(IABS(I),1)/3D0
17253 AI=SIGN(1D0,EI+0.1D0)
17254 VI=AI-4D0*EI*XWV
17255 FCOI=1D0
17256 IF(IABS(I).LE.10) FCOI=FACA/3D0
17257 IF(AI.LT.0D0) THEN
17258 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
17259 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
17260 ELSE
17261 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
17262 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
17263 ENDIF
17264 NCHN=NCHN+1
17265 ISIG(NCHN,1)=I
17266 ISIG(NCHN,2)=-I
17267 ISIG(NCHN,3)=1
17268 SIGH(NCHN)=FACWW*FCOI*DSIGWW
17269 540 CONTINUE
17270
17271 ELSEIF(ISUB.EQ.26) THEN
17272C...f + fbar' -> W+/- + h0 (or H0, or A0)
17273 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17274 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
17275 & ((SH-SQMW)**2+GMMW**2)
17276 FACHW=FACHW*WIDS(KFHIGG,2)
17277 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
17278 & PARU(155+10*IHIGG)**2
17279 DO 560 I=MMIN1,MMAX1
17280 IA=IABS(I)
17281 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
17282 DO 550 J=MMIN2,MMAX2
17283 JA=IABS(J)
17284 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
17285 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
17286 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17287 & GOTO 550
17288 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17289 FCKM=1D0
17290 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17291 FCOI=1D0
17292 IF(IA.LE.10) FCOI=FACA/3D0
17293 NCHN=NCHN+1
17294 ISIG(NCHN,1)=I
17295 ISIG(NCHN,2)=J
17296 ISIG(NCHN,3)=1
17297 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
17298 550 CONTINUE
17299 560 CONTINUE
17300
17301 ELSEIF(ISUB.EQ.27) THEN
17302C...f + fbar -> h0 + h0
17303
17304 ELSEIF(ISUB.EQ.28) THEN
17305C...f + g -> f + g (q + g -> q + g only)
17306 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
17307 & UH/SH)*FACA
17308 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
17309 & SH/UH)
17310 DO 580 I=MMINA,MMAXA
17311 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
17312 DO 570 ISDE=1,2
17313 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
17314 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
17315 NCHN=NCHN+1
17316 ISIG(NCHN,ISDE)=I
17317 ISIG(NCHN,3-ISDE)=21
17318 ISIG(NCHN,3)=1
17319 SIGH(NCHN)=FACQG1
17320 NCHN=NCHN+1
17321 ISIG(NCHN,ISDE)=I
17322 ISIG(NCHN,3-ISDE)=21
17323 ISIG(NCHN,3)=2
17324 SIGH(NCHN)=FACQG2
17325 570 CONTINUE
17326 580 CONTINUE
17327
17328 ELSEIF(ISUB.EQ.29) THEN
17329C...f + g -> f + gamma (q + g -> q + gamma only)
17330 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
17331 DO 600 I=MMINA,MMAXA
17332 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
17333 EI=KCHG(IABS(I),1)/3D0
17334 FACGQ=FGQ*EI**2
17335 DO 590 ISDE=1,2
17336 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
17337 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
17338 NCHN=NCHN+1
17339 ISIG(NCHN,ISDE)=I
17340 ISIG(NCHN,3-ISDE)=21
17341 ISIG(NCHN,3)=1
17342 SIGH(NCHN)=FACGQ
17343 590 CONTINUE
17344 600 CONTINUE
17345
17346 ELSEIF(ISUB.EQ.30) THEN
17347C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
17348 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
17349 & (-SH*UH)
17350C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17351 HFGG=0D0
17352 HFGZ=0D0
17353 HFZZ=0D0
17354 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17355 DO 610 I=1,MIN(16,MDCY(23,3))
17356 IDC=I+MDCY(23,2)-1
17357 IF(MDME(IDC,1).LT.0) GOTO 610
17358 IMDM=0
17359 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17360 & IMDM=1
17361 IF(I.LE.8) THEN
17362 EF=KCHG(I,1)/3D0
17363 AF=SIGN(1D0,EF+0.1D0)
17364 VF=AF-4D0*EF*XWV
17365 ELSEIF(I.LE.16) THEN
17366 EF=KCHG(I+2,1)/3D0
17367 AF=SIGN(1D0,EF+0.1D0)
17368 VF=AF-4D0*EF*XWV
17369 ENDIF
17370 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17371 IF(4D0*RM1.LT.1D0) THEN
17372 FCOF=1D0
17373 IF(I.LE.8) FCOF=3D0*RADC4
17374 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17375 IF(IMDM.EQ.1) THEN
17376 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17377 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17378 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17379 & AF**2*(1D0-4D0*RM1))*BE34
17380 ENDIF
17381 ENDIF
17382 610 CONTINUE
17383C...Propagators: as simulated in PYOFSH and as desired
17384 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17385 MINT(15)=1
17386 MINT(61)=1
17387 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17388 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17389 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17390 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17391 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17392C...Loop over flavours; consider full gamma/Z structure
17393 DO 630 I=MMINA,MMAXA
17394 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
17395 EI=KCHG(IABS(I),1)/3D0
17396 AI=SIGN(1D0,EI)
17397 VI=AI-4D0*EI*XWV
17398 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
17399 & (VI**2+AI**2)*HFZZ)/HBW4
17400 DO 620 ISDE=1,2
17401 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
17402 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
17403 NCHN=NCHN+1
17404 ISIG(NCHN,ISDE)=I
17405 ISIG(NCHN,3-ISDE)=21
17406 ISIG(NCHN,3)=1
17407 SIGH(NCHN)=FACZQ
17408 620 CONTINUE
17409 630 CONTINUE
17410 ENDIF
17411
17412 ELSEIF(ISUB.LE.40) THEN
17413 IF(ISUB.EQ.31) THEN
17414C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
17415 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
17416 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
17417C...Propagators: as simulated in PYOFSH and as desired
17418 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17419 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17420 GMMWC=SQRT(SQM4)*WDTP(0)
17421 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17422 FACWQ=FACWQ*HBW4C/HBW4
17423 DO 650 I=MMINA,MMAXA
17424 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
17425 IA=IABS(I)
17426 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17427 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17428 DO 640 ISDE=1,2
17429 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
17430 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
17431 NCHN=NCHN+1
17432 ISIG(NCHN,ISDE)=I
17433 ISIG(NCHN,3-ISDE)=21
17434 ISIG(NCHN,3)=1
17435 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17436 640 CONTINUE
17437 650 CONTINUE
17438
17439 ELSEIF(ISUB.EQ.32) THEN
17440C...f + g -> f + h0 (q + g -> q + h0 only)
17441
17442 ELSEIF(ISUB.EQ.33) THEN
17443C...f + gamma -> f + g (q + gamma -> q + g only)
17444 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
17445 DO 670 I=MMINA,MMAXA
17446 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
17447 EI=KCHG(IABS(I),1)/3D0
17448 FACGQ=FGQ*EI**2
17449 DO 660 ISDE=1,2
17450 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
17451 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
17452 NCHN=NCHN+1
17453 ISIG(NCHN,ISDE)=I
17454 ISIG(NCHN,3-ISDE)=22
17455 ISIG(NCHN,3)=1
17456 SIGH(NCHN)=FACGQ
17457 660 CONTINUE
17458 670 CONTINUE
17459
17460 ELSEIF(ISUB.EQ.34) THEN
17461C...f + gamma -> f + gamma
17462 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
17463 DO 690 I=MMINA,MMAXA
17464 IF(I.EQ.0) GOTO 690
17465 EI=KCHG(IABS(I),1)/3D0
17466 FACGQ=FGQ*EI**4
17467 DO 680 ISDE=1,2
17468 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
17469 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
17470 NCHN=NCHN+1
17471 ISIG(NCHN,ISDE)=I
17472 ISIG(NCHN,3-ISDE)=22
17473 ISIG(NCHN,3)=1
17474 SIGH(NCHN)=FACGQ
17475 680 CONTINUE
17476 690 CONTINUE
17477
17478 ELSEIF(ISUB.EQ.35) THEN
17479C...f + gamma -> f + (gamma*/Z0)
17480 FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH)
17481 FZQD=SQPTH*SQM4-SH*UH
17482C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17483 HFGG=0D0
17484 HFGZ=0D0
17485 HFZZ=0D0
17486 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17487 DO 700 I=1,MIN(16,MDCY(23,3))
17488 IDC=I+MDCY(23,2)-1
17489 IF(MDME(IDC,1).LT.0) GOTO 700
17490 IMDM=0
17491 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17492 & IMDM=1
17493 IF(I.LE.8) THEN
17494 EF=KCHG(I,1)/3D0
17495 AF=SIGN(1D0,EF+0.1D0)
17496 VF=AF-4D0*EF*XWV
17497 ELSEIF(I.LE.16) THEN
17498 EF=KCHG(I+2,1)/3D0
17499 AF=SIGN(1D0,EF+0.1D0)
17500 VF=AF-4D0*EF*XWV
17501 ENDIF
17502 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17503 IF(4D0*RM1.LT.1D0) THEN
17504 FCOF=1D0
17505 IF(I.LE.8) FCOF=3D0*RADC4
17506 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17507 IF(IMDM.EQ.1) THEN
17508 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17509 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17510 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17511 & AF**2*(1D0-4D0*RM1))*BE34
17512 ENDIF
17513 ENDIF
17514 700 CONTINUE
17515C...Propagators: as simulated in PYOFSH and as desired
17516 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17517 MINT(15)=1
17518 MINT(61)=1
17519 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17520 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17521 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17522 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17523 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17524C...Loop over flavours; consider full gamma/Z structure
17525 DO 720 I=MMINA,MMAXA
17526 IF(I.EQ.0) GOTO 720
17527 EI=KCHG(IABS(I),1)/3D0
17528 AI=SIGN(1D0,EI)
17529 VI=AI-4D0*EI*XWV
17530 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17531 & (VI**2+AI**2)*HFZZ)/HBW4
17532 DO 710 ISDE=1,2
17533 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
17534 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
17535 NCHN=NCHN+1
17536 ISIG(NCHN,ISDE)=I
17537 ISIG(NCHN,3-ISDE)=22
17538 ISIG(NCHN,3)=1
17539 SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD)
17540 710 CONTINUE
17541 720 CONTINUE
17542
17543 ELSEIF(ISUB.EQ.36) THEN
17544C...f + gamma -> f' + W+/-
17545 FWQ=COMFAC*AEM**2/(2D0*XW)*
17546 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
17547C...Propagators: as simulated in PYOFSH and as desired
17548 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17549 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17550 GMMWC=SQRT(SQM4)*WDTP(0)
17551 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17552 FWQ=FWQ*HBW4C/HBW4
17553 DO 740 I=MMINA,MMAXA
17554 IF(I.EQ.0) GOTO 740
17555 IA=IABS(I)
17556 EIA=ABS(KCHG(IABS(I),1)/3D0)
17557 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
17558 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17559 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17560 DO 730 ISDE=1,2
17561 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
17562 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
17563 NCHN=NCHN+1
17564 ISIG(NCHN,ISDE)=I
17565 ISIG(NCHN,3-ISDE)=22
17566 ISIG(NCHN,3)=1
17567 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17568 730 CONTINUE
17569 740 CONTINUE
17570
17571 ELSEIF(ISUB.EQ.37) THEN
17572C...f + gamma -> f + h0
17573
17574 ELSEIF(ISUB.EQ.38) THEN
17575C...f + Z0 -> f + g (q + Z0 -> q + g only)
17576
17577 ELSEIF(ISUB.EQ.39) THEN
17578C...f + Z0 -> f + gamma
17579
17580 ELSEIF(ISUB.EQ.40) THEN
17581C...f + Z0 -> f + Z0
17582 ENDIF
17583
17584 ELSEIF(ISUB.LE.50) THEN
17585 IF(ISUB.EQ.41) THEN
17586C...f + Z0 -> f' + W+/-
17587
17588 ELSEIF(ISUB.EQ.42) THEN
17589C...f + Z0 -> f + h0
17590
17591 ELSEIF(ISUB.EQ.43) THEN
17592C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
17593
17594 ELSEIF(ISUB.EQ.44) THEN
17595C...f + W+/- -> f' + gamma
17596
17597 ELSEIF(ISUB.EQ.45) THEN
17598C...f + W+/- -> f' + Z0
17599
17600 ELSEIF(ISUB.EQ.46) THEN
17601C...f + W+/- -> f' + W+/-
17602
17603 ELSEIF(ISUB.EQ.47) THEN
17604C...f + W+/- -> f' + h0
17605
17606 ELSEIF(ISUB.EQ.48) THEN
17607C...f + h0 -> f + g (q + h0 -> q + g only)
17608
17609 ELSEIF(ISUB.EQ.49) THEN
17610C...f + h0 -> f + gamma
17611
17612 ELSEIF(ISUB.EQ.50) THEN
17613C...f + h0 -> f + Z0
17614 ENDIF
17615
17616 ELSEIF(ISUB.LE.60) THEN
17617 IF(ISUB.EQ.51) THEN
17618C...f + h0 -> f' + W+/-
17619
17620 ELSEIF(ISUB.EQ.52) THEN
17621C...f + h0 -> f + h0
17622
17623 ELSEIF(ISUB.EQ.53) THEN
17624C...g + g -> f + fbar (g + g -> q + qbar only)
17625 CALL PYWIDT(21,SH,WDTP,WDTE)
17626 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
17627 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17628 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
17629 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17630 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
17631 NCHN=NCHN+1
17632 ISIG(NCHN,1)=21
17633 ISIG(NCHN,2)=21
17634 ISIG(NCHN,3)=1
17635 SIGH(NCHN)=FACQQ1
17636 NCHN=NCHN+1
17637 ISIG(NCHN,1)=21
17638 ISIG(NCHN,2)=21
17639 ISIG(NCHN,3)=2
17640 SIGH(NCHN)=FACQQ2
17641 750 CONTINUE
17642
17643 ELSEIF(ISUB.EQ.54) THEN
17644C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
17645 CALL PYWIDT(21,SH,WDTP,WDTE)
17646 WDTESU=0D0
17647 DO 760 I=1,MIN(8,MDCY(21,3))
17648 EF=KCHG(I,1)/3D0
17649 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17650 & WDTE(I,4))
17651 760 CONTINUE
17652 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
17653 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
17654 NCHN=NCHN+1
17655 ISIG(NCHN,1)=21
17656 ISIG(NCHN,2)=22
17657 ISIG(NCHN,3)=1
17658 SIGH(NCHN)=FACQQ
17659 ENDIF
17660 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
17661 NCHN=NCHN+1
17662 ISIG(NCHN,1)=22
17663 ISIG(NCHN,2)=21
17664 ISIG(NCHN,3)=1
17665 SIGH(NCHN)=FACQQ
17666 ENDIF
17667
17668 ELSEIF(ISUB.EQ.55) THEN
17669C...g + Z -> f + fbar (g + Z -> q + qbar only)
17670
17671 ELSEIF(ISUB.EQ.56) THEN
17672C...g + W -> f + f'bar (g + W -> q + q'bar only)
17673
17674 ELSEIF(ISUB.EQ.57) THEN
17675C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
17676
17677 ELSEIF(ISUB.EQ.58) THEN
17678C...gamma + gamma -> f + fbar
17679 CALL PYWIDT(22,SH,WDTP,WDTE)
17680 WDTESU=0D0
17681 DO 770 I=1,MIN(12,MDCY(22,3))
17682 IF(I.LE.8) EF= KCHG(I,1)/3D0
17683 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
17684 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17685 & WDTE(I,4))
17686 770 CONTINUE
17687 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
17688 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
17689 NCHN=NCHN+1
17690 ISIG(NCHN,1)=22
17691 ISIG(NCHN,2)=22
17692 ISIG(NCHN,3)=1
17693 SIGH(NCHN)=FACFF
17694 ENDIF
17695
17696 ELSEIF(ISUB.EQ.59) THEN
17697C...gamma + Z0 -> f + fbar
17698
17699 ELSEIF(ISUB.EQ.60) THEN
17700C...gamma + W+/- -> f + fbar'
17701 ENDIF
17702
17703 ELSEIF(ISUB.LE.70) THEN
17704 IF(ISUB.EQ.61) THEN
17705C...gamma + h0 -> f + fbar
17706
17707 ELSEIF(ISUB.EQ.62) THEN
17708C...Z0 + Z0 -> f + fbar
17709
17710 ELSEIF(ISUB.EQ.63) THEN
17711C...Z0 + W+/- -> f + fbar'
17712
17713 ELSEIF(ISUB.EQ.64) THEN
17714C...Z0 + h0 -> f + fbar
17715
17716 ELSEIF(ISUB.EQ.65) THEN
17717C...W+ + W- -> f + fbar
17718
17719 ELSEIF(ISUB.EQ.66) THEN
17720C...W+/- + h0 -> f + fbar'
17721
17722 ELSEIF(ISUB.EQ.67) THEN
17723C...h0 + h0 -> f + fbar
17724
17725 ELSEIF(ISUB.EQ.68) THEN
17726C...g + g -> g + g
17727 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
17728 & TH2/SH2)*FACA
17729 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
17730 & SH2/UH2)*FACA
17731 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
17732 & UH2/TH2)
17733 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
17734 NCHN=NCHN+1
17735 ISIG(NCHN,1)=21
17736 ISIG(NCHN,2)=21
17737 ISIG(NCHN,3)=1
17738 SIGH(NCHN)=0.5D0*FACGG1
17739 NCHN=NCHN+1
17740 ISIG(NCHN,1)=21
17741 ISIG(NCHN,2)=21
17742 ISIG(NCHN,3)=2
17743 SIGH(NCHN)=0.5D0*FACGG2
17744 NCHN=NCHN+1
17745 ISIG(NCHN,1)=21
17746 ISIG(NCHN,2)=21
17747 ISIG(NCHN,3)=3
17748 SIGH(NCHN)=0.5D0*FACGG3
17749 780 CONTINUE
17750
17751 ELSEIF(ISUB.EQ.69) THEN
17752C...gamma + gamma -> W+ + W-
17753 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17754 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
17755 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
17756 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
17757 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
17758 NCHN=NCHN+1
17759 ISIG(NCHN,1)=22
17760 ISIG(NCHN,2)=22
17761 ISIG(NCHN,3)=1
17762 SIGH(NCHN)=FACWW
17763 790 CONTINUE
17764
17765 ELSEIF(ISUB.EQ.70) THEN
17766C...gamma + W+/- -> Z0 + W+/-
17767 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17768 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
17769 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
17770 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
17771 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
17772 DO 810 KCHW=1,-1,-2
17773 DO 800 ISDE=1,2
17774 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
17775 NCHN=NCHN+1
17776 ISIG(NCHN,ISDE)=22
17777 ISIG(NCHN,3-ISDE)=24*KCHW
17778 ISIG(NCHN,3)=1
17779 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
17780 800 CONTINUE
17781 810 CONTINUE
17782 ENDIF
17783
17784 ELSEIF(ISUB.LE.80) THEN
17785 IF(ISUB.EQ.71) THEN
17786C...Z0 + Z0 -> Z0 + Z0
17787 IF(SH.LE.4.01D0*SQMZ) GOTO 840
17788
17789 IF(MSTP(46).LE.2) THEN
17790C...Exact scattering ME:s for on-mass-shell gauge bosons
17791 BE2=1D0-4D0*SQMZ/SH
17792 TH=-0.5D0*SH*BE2*(1D0-CTH)
17793 UH=-0.5D0*SH*BE2*(1D0+CTH)
17794 IF(MAX(TH,UH).GT.-1D0) GOTO 840
17795 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
17796 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17797 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17798 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
17799 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17800 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17801 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
17802 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
17803 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
17804 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17805 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17806 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
17807 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
17808 & (ASHIM+ATHIM+AUHIM)**2)
17809 IF(MSTP(46).EQ.2) FACZZ=0D0
17810
17811 ELSE
17812C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17813 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17814 & ABS(A00U+2.*A20U)**2
17815 ENDIF
17816 FACZZ=FACZZ*WIDS(23,1)
17817
17818 DO 830 I=MMIN1,MMAX1
17819 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
17820 EI=KCHG(IABS(I),1)/3D0
17821 AI=SIGN(1D0,EI)
17822 VI=AI-4D0*EI*XWV
17823 AVI=AI**2+VI**2
17824 DO 820 J=MMIN2,MMAX2
17825 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
17826 EJ=KCHG(IABS(J),1)/3D0
17827 AJ=SIGN(1D0,EJ)
17828 VJ=AJ-4D0*EJ*XWV
17829 AVJ=AJ**2+VJ**2
17830 NCHN=NCHN+1
17831 ISIG(NCHN,1)=I
17832 ISIG(NCHN,2)=J
17833 ISIG(NCHN,3)=1
17834 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
17835 820 CONTINUE
17836 830 CONTINUE
17837 840 CONTINUE
17838
17839 ELSEIF(ISUB.EQ.72) THEN
17840C...Z0 + Z0 -> W+ + W-
17841 IF(SH.LE.4.01D0*SQMZ) GOTO 870
17842
17843 IF(MSTP(46).LE.2) THEN
17844C...Exact scattering ME:s for on-mass-shell gauge bosons
17845 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17846 CTH2=CTH**2
17847 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17848 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17849 IF(MAX(TH,UH).GT.-1D0) GOTO 870
17850 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17851 & (1D0-2D0*SQMZ/SH)
17852 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17853 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17854 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
17855 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17856 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17857 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
17858 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17859 ATWIM=0D0
17860 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
17861 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17862 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17863 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
17864 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17865 AUWIM=0D0
17866 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
17867 A4IM=0D0
17868 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17869 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17870 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
17871 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
17872 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
17873 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
17874 & (ATWIM+AUWIM+A4IM)**2)
17875
17876 ELSE
17877C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17878 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17879 & ABS(A00U-A20U)**2
17880 ENDIF
17881 FACWW=FACWW*WIDS(24,1)
17882
17883 DO 860 I=MMIN1,MMAX1
17884 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
17885 EI=KCHG(IABS(I),1)/3D0
17886 AI=SIGN(1D0,EI)
17887 VI=AI-4D0*EI*XWV
17888 AVI=AI**2+VI**2
17889 DO 850 J=MMIN2,MMAX2
17890 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
17891 EJ=KCHG(IABS(J),1)/3D0
17892 AJ=SIGN(1D0,EJ)
17893 VJ=AJ-4D0*EJ*XWV
17894 AVJ=AJ**2+VJ**2
17895 NCHN=NCHN+1
17896 ISIG(NCHN,1)=I
17897 ISIG(NCHN,2)=J
17898 ISIG(NCHN,3)=1
17899 SIGH(NCHN)=FACWW*AVI*AVJ
17900 850 CONTINUE
17901 860 CONTINUE
17902 870 CONTINUE
17903
17904 ELSEIF(ISUB.EQ.73) THEN
17905C...Z0 + W+/- -> Z0 + W+/-
17906 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
17907
17908 IF(MSTP(46).LE.2) THEN
17909C...Exact scattering ME:s for on-mass-shell gauge bosons
17910 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
17911 EP1=1D0-(SQMZ-SQMW)/SH
17912 EP2=1D0+(SQMZ-SQMW)/SH
17913 TH=-0.5D0*SH*BE2*(1D0-CTH)
17914 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
17915 IF(MAX(TH,UH).GT.-1D0) GOTO 900
17916 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
17917 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17918 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17919 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
17920 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
17921 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
17922 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
17923 ASWIM=0D0
17924 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
17925 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
17926 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
17927 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
17928 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
17929 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
17930 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
17931 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
17932 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
17933 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
17934 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
17935 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
17936 AUWIM=0D0
17937 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
17938 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
17939 A4IM=0D0
17940 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
17941 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
17942 IF(MSTP(46).LE.0) FACZW=0D0
17943 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
17944 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
17945 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
17946 & (ASWIM+AUWIM+A4IM)**2)
17947
17948 ELSE
17949C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17950 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
17951 & ABS(A20U+3.*A11U*SNGL(CTH))**2
17952 ENDIF
17953 FACZW=FACZW*WIDS(23,2)
17954
17955 DO 890 I=MMIN1,MMAX1
17956 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
17957 EI=KCHG(IABS(I),1)/3D0
17958 AI=SIGN(1D0,EI)
17959 VI=AI-4D0*EI*XWV
17960 AVI=AI**2+VI**2
17961 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
17962 DO 880 J=MMIN2,MMAX2
17963 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
17964 EJ=KCHG(IABS(J),1)/3D0
17965 AJ=SIGN(1D0,EJ)
17966 VJ=AI-4D0*EJ*XWV
17967 AVJ=AJ**2+VJ**2
17968 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
17969 NCHN=NCHN+1
17970 ISIG(NCHN,1)=I
17971 ISIG(NCHN,2)=J
17972 ISIG(NCHN,3)=1
17973 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
17974 NCHN=NCHN+1
17975 ISIG(NCHN,1)=I
17976 ISIG(NCHN,2)=J
17977 ISIG(NCHN,3)=2
17978 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
17979 880 CONTINUE
17980 890 CONTINUE
17981 900 CONTINUE
17982
17983 ELSEIF(ISUB.EQ.75) THEN
17984C...W+ + W- -> gamma + gamma
17985
17986 ELSEIF(ISUB.EQ.76) THEN
17987C...W+ + W- -> Z0 + Z0
17988 IF(SH.LE.4.01D0*SQMZ) GOTO 930
17989
17990 IF(MSTP(46).LE.2) THEN
17991C...Exact scattering ME:s for on-mass-shell gauge bosons
17992 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17993 CTH2=CTH**2
17994 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17995 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17996 IF(MAX(TH,UH).GT.-1D0) GOTO 930
17997 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17998 & (1D0-2D0*SQMZ/SH)
17999 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18000 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18001 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
18002 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18003 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18004 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
18005 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18006 ATWIM=0D0
18007 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
18008 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18009 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18010 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
18011 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18012 AUWIM=0D0
18013 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
18014 A4IM=0D0
18015 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18016 & (SH/SQMW)**2*SH2
18017 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
18018 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
18019 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
18020 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
18021 & (ATWIM+AUWIM+A4IM)**2)
18022
18023 ELSE
18024C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18025 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18026 & ABS(A00U-A20U)**2
18027 ENDIF
18028 FACZZ=FACZZ*WIDS(23,1)
18029
18030 DO 920 I=MMIN1,MMAX1
18031 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
18032 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18033 DO 910 J=MMIN2,MMAX2
18034 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
18035 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18036 IF(EI*EJ.GT.0D0) GOTO 910
18037 NCHN=NCHN+1
18038 ISIG(NCHN,1)=I
18039 ISIG(NCHN,2)=J
18040 ISIG(NCHN,3)=1
18041 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
18042 910 CONTINUE
18043 920 CONTINUE
18044 930 CONTINUE
18045
18046 ELSEIF(ISUB.EQ.77) THEN
18047C...W+/- + W+/- -> W+/- + W+/-
18048 IF(SH.LE.4.01D0*SQMW) GOTO 960
18049
18050 IF(MSTP(46).LE.2) THEN
18051C...Exact scattering ME:s for on-mass-shell gauge bosons
18052 BE2=1D0-4D0*SQMW/SH
18053 BE4=BE2**2
18054 CTH2=CTH**2
18055 CTH3=CTH**3
18056 TH=-0.5D0*SH*BE2*(1D0-CTH)
18057 UH=-0.5D0*SH*BE2*(1D0+CTH)
18058 IF(MAX(TH,UH).GT.-1D0) GOTO 960
18059 SHANG=(1D0+BE2)**2
18060 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18061 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18062 THANG=(BE2-CTH)**2
18063 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
18064 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
18065 UHANG=(BE2+CTH)**2
18066 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
18067 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
18068 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
18069 ASGRE=XW*SGZANG
18070 ASGIM=0D0
18071 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
18072 ASZIM=0D0
18073 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
18074 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
18075 ATGRE=0.5D0*XW*SH/TH*TGZANG
18076 ATGIM=0D0
18077 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
18078 ATZIM=0D0
18079 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
18080 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
18081 AUGRE=0.5D0*XW*SH/UH*UGZANG
18082 AUGIM=0D0
18083 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
18084 AUZIM=0D0
18085 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
18086 A4AIM=0D0
18087 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
18088 A4SIM=0D0
18089 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18090 & (SH/SQMW)**2*SH2
18091 IF(MSTP(46).LE.0) THEN
18092 AWWARE=ASHRE
18093 AWWAIM=ASHIM
18094 AWWSRE=0D0
18095 AWWSIM=0D0
18096 ELSEIF(MSTP(46).EQ.1) THEN
18097 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18098 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18099 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18100 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18101 ELSE
18102 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18103 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18104 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18105 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18106 ENDIF
18107 AWWA2=AWWARE**2+AWWAIM**2
18108 AWWS2=AWWSRE**2+AWWSIM**2
18109
18110 ELSE
18111C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18112 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18113 & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
18114 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
18115 ENDIF
18116
18117 DO 950 I=MMIN1,MMAX1
18118 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
18119 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18120 DO 940 J=MMIN2,MMAX2
18121 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
18122 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18123 IF(EI*EJ.LT.0D0) THEN
18124C...W+W-
18125 IF(MSTP(45).EQ.1) GOTO 940
18126 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
18127 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
18128 ELSE
18129C...W+W+/W-W-
18130 IF(MSTP(45).EQ.2) GOTO 940
18131 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
18132 IF(MSTP(46).GE.3) FACWW=FWWS
18133 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
18134 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
18135 ENDIF
18136 NCHN=NCHN+1
18137 ISIG(NCHN,1)=I
18138 ISIG(NCHN,2)=J
18139 ISIG(NCHN,3)=1
18140 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
18141 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
18142 940 CONTINUE
18143 950 CONTINUE
18144 960 CONTINUE
18145
18146 ELSEIF(ISUB.EQ.78) THEN
18147C...W+/- + h0 -> W+/- + h0
18148
18149 ELSEIF(ISUB.EQ.79) THEN
18150C...h0 + h0 -> h0 + h0
18151
18152 ELSEIF(ISUB.EQ.80) THEN
18153C...q + gamma -> q' + pi+/-
18154 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
18155 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
18156 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
18157 DELSH=UH*SQRT(ASSH*Q2FPSH)
18158 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
18159 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
18160 DELUH=SH*SQRT(ASUH*Q2FPUH)
18161 DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
18162 IF(I.EQ.0) GOTO 980
18163 EI=KCHG(IABS(I),1)/3D0
18164 EJ=SIGN(1D0-ABS(EI),EI)
18165 DO 970 ISDE=1,2
18166 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
18167 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
18168 NCHN=NCHN+1
18169 ISIG(NCHN,ISDE)=I
18170 ISIG(NCHN,3-ISDE)=22
18171 ISIG(NCHN,3)=1
18172 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
18173 970 CONTINUE
18174 980 CONTINUE
18175
18176 ENDIF
18177
18178C...C: 2 -> 2, tree diagrams with masses
18179
18180 ELSEIF(ISUB.LE.90) THEN
18181 IF(ISUB.EQ.81) THEN
18182C...q + qbar -> Q + Qbar
18183 FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+
18184 & (UH-SQM3)**2)/SH2+2D0*SQM3/SH)
18185 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,0D0)
18186 WID2=1D0
18187 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18188 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18189 FACQQB=FACQQB*WID2
18190 DO 990 I=MMINA,MMAXA
18191 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18192 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
18193 NCHN=NCHN+1
18194 ISIG(NCHN,1)=I
18195 ISIG(NCHN,2)=-I
18196 ISIG(NCHN,3)=1
18197 SIGH(NCHN)=FACQQB
18198 990 CONTINUE
18199
18200 ELSEIF(ISUB.EQ.82) THEN
18201C...g + g -> Q + Qbar
18202 IF(MSTP(34).EQ.0) THEN
18203 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18204 & 2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18205 & (TH-SQM3)**2)
18206 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18207 & 2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18208 & (UH-SQM3)**2)
18209 ELSE
18210 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18211 & 2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18212 & (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/
18213 & (SH*(TH-SQM3)))
18214 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18215 & 2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18216 & (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/
18217 & (SH*(UH-SQM3)))
18218 ENDIF
18219 IF(MSTP(35).GE.1) THEN
18220 FATRE=PYHFTH(SH,SQM3,2D0/7D0)
18221 FACQQ1=FACQQ1*FATRE
18222 FACQQ2=FACQQ2*FATRE
18223 ENDIF
18224 WID2=1D0
18225 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18226 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18227 FACQQ1=FACQQ1*WID2
18228 FACQQ2=FACQQ2*WID2
18229 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
18230 NCHN=NCHN+1
18231 ISIG(NCHN,1)=21
18232 ISIG(NCHN,2)=21
18233 ISIG(NCHN,3)=1
18234 SIGH(NCHN)=FACQQ1
18235 NCHN=NCHN+1
18236 ISIG(NCHN,1)=21
18237 ISIG(NCHN,2)=21
18238 ISIG(NCHN,3)=2
18239 SIGH(NCHN)=FACQQ2
18240 1000 CONTINUE
18241
18242 ELSEIF(ISUB.EQ.83) THEN
18243C...f + q -> f' + Q
18244 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
18245 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
18246 DO 1020 I=MMIN1,MMAX1
18247 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
18248 DO 1010 J=MMIN2,MMAX2
18249 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
18250 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
18251 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
18252 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
18253 & THEN
18254 NCHN=NCHN+1
18255 ISIG(NCHN,1)=I
18256 ISIG(NCHN,2)=J
18257 ISIG(NCHN,3)=1
18258 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18259 & (IABS(I)+1)/2)*VINT(180+J)
18260 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
18261 & (MINT(55)+1)/2)*VINT(180+J)
18262 WID2=1D0
18263 IF(I.GT.0) THEN
18264 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18265 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18266 & WIDS(MINT(55),2)
18267 ELSE
18268 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18269 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18270 & WIDS(MINT(55),3)
18271 ENDIF
18272 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18273 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18274 ENDIF
18275 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
18276 & THEN
18277 NCHN=NCHN+1
18278 ISIG(NCHN,1)=I
18279 ISIG(NCHN,2)=J
18280 ISIG(NCHN,3)=2
18281 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18282 & (IABS(J)+1)/2)*VINT(180+I)
18283 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
18284 & (MINT(55)+1)/2)*VINT(180+I)
18285 IF(J.GT.0) THEN
18286 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18287 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18288 & WIDS(MINT(55),2)
18289 ELSE
18290 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18291 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18292 & WIDS(MINT(55),3)
18293 ENDIF
18294 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18295 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18296 ENDIF
18297 1010 CONTINUE
18298 1020 CONTINUE
18299
18300 ELSEIF(ISUB.EQ.84) THEN
18301C...g + gamma -> Q + Qbar
18302 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18303 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
18304 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18305 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0)
18306 WID2=1D0
18307 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18308 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18309 FACQQ=FACQQ*WID2
18310 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18311 NCHN=NCHN+1
18312 ISIG(NCHN,1)=21
18313 ISIG(NCHN,2)=22
18314 ISIG(NCHN,3)=1
18315 SIGH(NCHN)=FACQQ
18316 ENDIF
18317 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18318 NCHN=NCHN+1
18319 ISIG(NCHN,1)=22
18320 ISIG(NCHN,2)=21
18321 ISIG(NCHN,3)=1
18322 SIGH(NCHN)=FACQQ
18323 ENDIF
18324
18325 ELSEIF(ISUB.EQ.85) THEN
18326C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
18327 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18328 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
18329 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18330 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
18331 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
18332 & FACFF=FACFF*PYHFTH(SH,SQM3,1D0)
18333 WID2=1D0
18334 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
18335 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
18336 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
18337 FACFF=FACFF*WID2
18338 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18339 NCHN=NCHN+1
18340 ISIG(NCHN,1)=22
18341 ISIG(NCHN,2)=22
18342 ISIG(NCHN,3)=1
18343 SIGH(NCHN)=FACFF
18344 ENDIF
18345
18346 ELSEIF(ISUB.EQ.86) THEN
18347C...g + g -> J/Psi + g
18348 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
18349 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18350 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18351 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18352 NCHN=NCHN+1
18353 ISIG(NCHN,1)=21
18354 ISIG(NCHN,2)=21
18355 ISIG(NCHN,3)=1
18356 SIGH(NCHN)=FACQQG
18357 ENDIF
18358
18359 ELSEIF(ISUB.EQ.87) THEN
18360C...g + g -> chi_0c + g
18361 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18362 QGTW=(SH*TH*UH)/SH**3
18363 RGTW=SQM3/SH
18364 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18365 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18366 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
18367 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
18368 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
18369 & (QGTW*(QGTW-RGTW*PGTW)**4)
18370 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18371 NCHN=NCHN+1
18372 ISIG(NCHN,1)=21
18373 ISIG(NCHN,2)=21
18374 ISIG(NCHN,3)=1
18375 SIGH(NCHN)=FACQQG
18376 ENDIF
18377
18378 ELSEIF(ISUB.EQ.88) THEN
18379C...g + g -> chi_1c + g
18380 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18381 QGTW=(SH*TH*UH)/SH**3
18382 RGTW=SQM3/SH
18383 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18384 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
18385 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
18386 & (QGTW-RGTW*PGTW)**4
18387 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18388 NCHN=NCHN+1
18389 ISIG(NCHN,1)=21
18390 ISIG(NCHN,2)=21
18391 ISIG(NCHN,3)=1
18392 SIGH(NCHN)=FACQQG
18393 ENDIF
18394
18395 ELSEIF(ISUB.EQ.89) THEN
18396C...g + g -> chi_2c + g
18397 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18398 QGTW=(SH*TH*UH)/SH**3
18399 RGTW=SQM3/SH
18400 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18401 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18402 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
18403 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
18404 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
18405 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
18406 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18407 NCHN=NCHN+1
18408 ISIG(NCHN,1)=21
18409 ISIG(NCHN,2)=21
18410 ISIG(NCHN,3)=1
18411 SIGH(NCHN)=FACQQG
18412 ENDIF
18413 ENDIF
18414
18415C...D: Mimimum bias processes
18416
18417 ELSEIF(ISUB.LE.100) THEN
18418 IF(ISUB.EQ.91) THEN
18419C...Elastic scattering
18420 SIGS=SIGT(0,0,1)
18421
18422 ELSEIF(ISUB.EQ.92) THEN
18423C...Single diffractive scattering (first side, i.e. XB)
18424 SIGS=SIGT(0,0,2)
18425
18426 ELSEIF(ISUB.EQ.93) THEN
18427C...Single diffractive scattering (second side, i.e. AX)
18428 SIGS=SIGT(0,0,3)
18429
18430 ELSEIF(ISUB.EQ.94) THEN
18431C...Double diffractive scattering
18432 SIGS=SIGT(0,0,4)
18433
18434 ELSEIF(ISUB.EQ.95) THEN
18435C...Low-pT scattering
18436 SIGS=SIGT(0,0,5)
18437
18438 ELSEIF(ISUB.EQ.96) THEN
18439C...Multiple interactions: sum of QCD processes
18440 CALL PYWIDT(21,SH,WDTP,WDTE)
18441
18442C...q + q' -> q + q'
18443 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
18444 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
18445 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
18446 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
18447 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
18448 DO 1040 I=-3,3
18449 IF(I.EQ.0) GOTO 1040
18450 DO 1030 J=-3,3
18451 IF(J.EQ.0) GOTO 1030
18452 NCHN=NCHN+1
18453 ISIG(NCHN,1)=I
18454 ISIG(NCHN,2)=J
18455 ISIG(NCHN,3)=111
18456 SIGH(NCHN)=FACQQ1
18457 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
18458 IF(I.EQ.J) THEN
18459 SIGH(NCHN)=0.5D0*SIGH(NCHN)
18460 NCHN=NCHN+1
18461 ISIG(NCHN,1)=I
18462 ISIG(NCHN,2)=J
18463 ISIG(NCHN,3)=112
18464 SIGH(NCHN)=0.5D0*FACQQ2
18465 ENDIF
18466 1030 CONTINUE
18467 1040 CONTINUE
18468
18469C...q + qbar -> q' + qbar' or g + g
18470 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
18471 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
18472 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18473 & UH2/SH2)
18474 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18475 & TH2/SH2)
18476 DO 1050 I=-3,3
18477 IF(I.EQ.0) GOTO 1050
18478 NCHN=NCHN+1
18479 ISIG(NCHN,1)=I
18480 ISIG(NCHN,2)=-I
18481 ISIG(NCHN,3)=121
18482 SIGH(NCHN)=FACQQB
18483 NCHN=NCHN+1
18484 ISIG(NCHN,1)=I
18485 ISIG(NCHN,2)=-I
18486 ISIG(NCHN,3)=131
18487 SIGH(NCHN)=0.5D0*FACGG1
18488 NCHN=NCHN+1
18489 ISIG(NCHN,1)=I
18490 ISIG(NCHN,2)=-I
18491 ISIG(NCHN,3)=132
18492 SIGH(NCHN)=0.5D0*FACGG2
18493 1050 CONTINUE
18494
18495C...q + g -> q + g
18496 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
18497 & UH/SH)*FACA
18498 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
18499 & SH/UH)
18500 DO 1070 I=-3,3
18501 IF(I.EQ.0) GOTO 1070
18502 DO 1060 ISDE=1,2
18503 NCHN=NCHN+1
18504 ISIG(NCHN,ISDE)=I
18505 ISIG(NCHN,3-ISDE)=21
18506 ISIG(NCHN,3)=281
18507 SIGH(NCHN)=FACQG1
18508 NCHN=NCHN+1
18509 ISIG(NCHN,ISDE)=I
18510 ISIG(NCHN,3-ISDE)=21
18511 ISIG(NCHN,3)=282
18512 SIGH(NCHN)=FACQG2
18513 1060 CONTINUE
18514 1070 CONTINUE
18515
18516C...g + g -> q + qbar or g + g
18517 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18518 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18519 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18520 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18521 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
18522 & 2D0*TH/SH+TH2/SH2)*FACA
18523 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
18524 & 2D0*SH/UH+SH2/UH2)*FACA
18525 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
18526 & 2D0*UH/TH+UH2/TH2)
18527 NCHN=NCHN+1
18528 ISIG(NCHN,1)=21
18529 ISIG(NCHN,2)=21
18530 ISIG(NCHN,3)=531
18531 SIGH(NCHN)=FACQQ1
18532 NCHN=NCHN+1
18533 ISIG(NCHN,1)=21
18534 ISIG(NCHN,2)=21
18535 ISIG(NCHN,3)=532
18536 SIGH(NCHN)=FACQQ2
18537 NCHN=NCHN+1
18538 ISIG(NCHN,1)=21
18539 ISIG(NCHN,2)=21
18540 ISIG(NCHN,3)=681
18541 SIGH(NCHN)=0.5D0*FACGG1
18542 NCHN=NCHN+1
18543 ISIG(NCHN,1)=21
18544 ISIG(NCHN,2)=21
18545 ISIG(NCHN,3)=682
18546 SIGH(NCHN)=0.5D0*FACGG2
18547 NCHN=NCHN+1
18548 ISIG(NCHN,1)=21
18549 ISIG(NCHN,2)=21
18550 ISIG(NCHN,3)=683
18551 SIGH(NCHN)=0.5D0*FACGG3
18552 ENDIF
18553
18554C...E: 2 -> 1, loop diagrams
18555
18556 ELSEIF(ISUB.LE.110) THEN
18557 IF(ISUB.EQ.101) THEN
18558C...g + g -> gamma*/Z0
18559
18560 ELSEIF(ISUB.EQ.102) THEN
18561C...g + g -> h0 (or H0, or A0)
18562 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18563 HS=SHR*WDTP(0)
18564 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18565 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18566 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18567 & FACBW=0D0
18568 HI=SHR*WDTP(13)/32D0
18569 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
18570 NCHN=NCHN+1
18571 ISIG(NCHN,1)=21
18572 ISIG(NCHN,2)=21
18573 ISIG(NCHN,3)=1
18574 SIGH(NCHN)=HI*FACBW*HF
18575 1080 CONTINUE
18576
18577 ELSEIF(ISUB.EQ.103) THEN
18578C...gamma + gamma -> h0 (or H0, or A0)
18579 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18580 HS=SHR*WDTP(0)
18581 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18582 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18583 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18584 & FACBW=0D0
18585 HI=SHR*WDTP(14)*2D0
18586 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
18587 NCHN=NCHN+1
18588 ISIG(NCHN,1)=22
18589 ISIG(NCHN,2)=22
18590 ISIG(NCHN,3)=1
18591 SIGH(NCHN)=HI*FACBW*HF
18592 1090 CONTINUE
18593
18594C...Continuation C: 2 -> 2, tree diagrams with masses.
18595
18596 ELSEIF(ISUB.EQ.106) THEN
18597C...g + g -> J/Psi + gamma.
18598 EQ=2D0/3D0
18599 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
18600 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18601 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18602 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18603 NCHN=NCHN+1
18604 ISIG(NCHN,1)=21
18605 ISIG(NCHN,2)=21
18606 ISIG(NCHN,3)=1
18607 SIGH(NCHN)=FACQQG
18608 ENDIF
18609
18610 ELSEIF(ISUB.EQ.107) THEN
18611C...g + gamma -> J/Psi + g.
18612 EQ=2D0/3D0
18613 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
18614 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18615 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18616 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18617 NCHN=NCHN+1
18618 ISIG(NCHN,1)=21
18619 ISIG(NCHN,2)=22
18620 ISIG(NCHN,3)=1
18621 SIGH(NCHN)=FACQQG
18622 ENDIF
18623 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18624 NCHN=NCHN+1
18625 ISIG(NCHN,1)=22
18626 ISIG(NCHN,2)=21
18627 ISIG(NCHN,3)=1
18628 SIGH(NCHN)=FACQQG
18629 ENDIF
18630
18631 ELSEIF(ISUB.EQ.108) THEN
18632C...gamma + gamma -> J/Psi + gamma.
18633 EQ=2D0/3D0
18634 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
18635 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18636 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18637 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18638 NCHN=NCHN+1
18639 ISIG(NCHN,1)=22
18640 ISIG(NCHN,2)=22
18641 ISIG(NCHN,3)=1
18642 SIGH(NCHN)=FACQQG
18643 ENDIF
18644
18645C...F: 2 -> 2, box diagrams
18646
18647 ELSEIF(ISUB.EQ.110) THEN
18648C...f + fbar -> gamma + h0
18649 THUH=MAX(TH*UH,SH*CKIN(3)**2)
18650 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
18651 FACHG=FACHG*WIDS(KFHIGG,2)
18652C...Calculate loop contributions for intermediate gamma* and Z0
18653 CIGTOT=CMPLX(0.,0.)
18654 CIZTOT=CMPLX(0.,0.)
18655 JMAX=3*MSTP(1)+1
18656 DO 1100 J=1,JMAX
18657 IF(J.LE.2*MSTP(1)) THEN
18658 FNC=1D0
18659 EJ=KCHG(J,1)/3D0
18660 AJ=SIGN(1D0,EJ+0.1D0)
18661 VJ=AJ-4D0*EJ*XWV
18662 BALP=SQM4/(2D0*PMAS(J,1))**2
18663 BBET=SH/(2D0*PMAS(J,1))**2
18664 ELSEIF(J.LE.3*MSTP(1)) THEN
18665 FNC=3D0
18666 JL=2*(J-2*MSTP(1))-1
18667 EJ=KCHG(10+JL,1)/3D0
18668 AJ=SIGN(1D0,EJ+0.1D0)
18669 VJ=AJ-4D0*EJ*XWV
18670 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
18671 BBET=SH/(2D0*PMAS(10+JL,1))**2
18672 ELSE
18673 BALP=SQM4/(2D0*PMAS(24,1))**2
18674 BBET=SH/(2D0*PMAS(24,1))**2
18675 ENDIF
18676 BABI=1D0/(BALP-BBET)
18677 IF(BALP.LT.1D0) THEN
18678 F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
18679 F1ALP=F0ALP**2
18680 ELSE
18681 F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
18682 & -SNGL(0.5D0*PARU(1)))
18683 F1ALP=-F0ALP**2
18684 ENDIF
18685 F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
18686 IF(BBET.LT.1D0) THEN
18687 F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
18688 F1BET=F0BET**2
18689 ELSE
18690 F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
18691 & -SNGL(0.5D0*PARU(1)))
18692 F1BET=-F0BET**2
18693 ENDIF
18694 F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
18695 IF(J.LE.3*MSTP(1)) THEN
18696 FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
18697 & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
18698 CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
18699 CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
18700 ELSE
18701 TXW=XW/XW1
18702 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
18703 & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
18704 & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
18705 CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
18706 & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
18707 & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
18708 & (F1BET-F1ALP))
18709 ENDIF
18710 1100 CONTINUE
18711 CIGTOT=CIGTOT/SNGL(SH)
18712 CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
18713C...Loop over initial flavours
18714 DO 1110 I=MMINA,MMAXA
18715 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
18716 EI=KCHG(IABS(I),1)/3D0
18717 AI=SIGN(1D0,EI)
18718 VI=AI-4D0*EI*XWV
18719 FCOI=1D0
18720 IF(IABS(I).LE.10) FCOI=FACA/3D0
18721 NCHN=NCHN+1
18722 ISIG(NCHN,1)=I
18723 ISIG(NCHN,2)=-I
18724 ISIG(NCHN,3)=1
18725 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
18726 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
18727 1110 CONTINUE
18728
18729 ENDIF
18730
18731 ELSEIF(ISUB.LE.120) THEN
18732 IF(ISUB.EQ.111) THEN
18733C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
18734 A5STUR=0D0
18735 A5STUI=0D0
18736 DO 1120 I=1,2*MSTP(1)
18737 SQMQ=PMAS(I,1)**2
18738 EPSS=4D0*SQMQ/SH
18739 EPSH=4D0*SQMQ/SQMH
18740 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18741 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18742 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18743 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18744 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
18745 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
18746 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
18747 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
18748 1120 CONTINUE
18749 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18750 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
18751 FACGH=FACGH*WIDS(25,2)
18752 DO 1130 I=MMINA,MMAXA
18753 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18754 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
18755 NCHN=NCHN+1
18756 ISIG(NCHN,1)=I
18757 ISIG(NCHN,2)=-I
18758 ISIG(NCHN,3)=1
18759 SIGH(NCHN)=FACGH
18760 1130 CONTINUE
18761
18762 ELSEIF(ISUB.EQ.112) THEN
18763C...f + g -> f + h0 (q + g -> q + h0 only)
18764 A5TSUR=0D0
18765 A5TSUI=0D0
18766 DO 1140 I=1,2*MSTP(1)
18767 SQMQ=PMAS(I,1)**2
18768 EPST=4D0*SQMQ/TH
18769 EPSH=4D0*SQMQ/SQMH
18770 CALL PYWAUX(1,EPST,W1TR,W1TI)
18771 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18772 CALL PYWAUX(2,EPST,W2TR,W2TI)
18773 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18774 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
18775 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
18776 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
18777 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
18778 1140 CONTINUE
18779 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18780 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
18781 FACQH=FACQH*WIDS(25,2)
18782 DO 1160 I=MMINA,MMAXA
18783 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
18784 DO 1150 ISDE=1,2
18785 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
18786 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
18787 NCHN=NCHN+1
18788 ISIG(NCHN,ISDE)=I
18789 ISIG(NCHN,3-ISDE)=21
18790 ISIG(NCHN,3)=1
18791 SIGH(NCHN)=FACQH
18792 1150 CONTINUE
18793 1160 CONTINUE
18794
18795 ELSEIF(ISUB.EQ.113) THEN
18796C...g + g -> g + h0
18797 A2STUR=0D0
18798 A2STUI=0D0
18799 A2USTR=0D0
18800 A2USTI=0D0
18801 A2TUSR=0D0
18802 A2TUSI=0D0
18803 A4STUR=0D0
18804 A4STUI=0D0
18805 DO 1170 I=1,2*MSTP(1)
18806 SQMQ=PMAS(I,1)**2
18807 EPSS=4D0*SQMQ/SH
18808 EPST=4D0*SQMQ/TH
18809 EPSU=4D0*SQMQ/UH
18810 EPSH=4D0*SQMQ/SQMH
18811 IF(EPSH.LT.1.D-6) GOTO 1170
18812 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18813 CALL PYWAUX(1,EPST,W1TR,W1TI)
18814 CALL PYWAUX(1,EPSU,W1UR,W1UI)
18815 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18816 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18817 CALL PYWAUX(2,EPST,W2TR,W2TI)
18818 CALL PYWAUX(2,EPSU,W2UR,W2UI)
18819 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18820 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18821 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18822 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18823 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18824 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18825 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18826 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
18827 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
18828 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
18829 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
18830 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
18831 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
18832 W3STUR=YHSTUR-Y3STUR-Y3UTSR
18833 W3STUI=YHSTUI-Y3STUI-Y3UTSI
18834 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
18835 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
18836 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
18837 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
18838 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
18839 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
18840 W3USTR=YHUSTR-Y3USTR-Y3TSUR
18841 W3USTI=YHUSTI-Y3USTI-Y3TSUI
18842 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
18843 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
18844 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
18845 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
18846 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
18847 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
18848 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
18849 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
18850 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
18851 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
18852 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
18853 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
18854 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
18855 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
18856 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
18857 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
18858 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
18859 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
18860 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
18861 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
18862 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
18863 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
18864 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
18865 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
18866 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
18867 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
18868 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
18869 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
18870 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
18871 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
18872 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
18873 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
18874 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
18875 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
18876 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
18877 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
18878 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
18879 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
18880 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
18881 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
18882 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
18883 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
18884 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
18885 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
18886 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
18887 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
18888 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
18889 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
18890 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
18891 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
18892 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
18893 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
18894 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
18895 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
18896 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
18897 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
18898 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
18899 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
18900 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
18901 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
18902 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
18903 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
18904 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18905 & (W2SR-W2HR+W3STUR))
18906 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
18907 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18908 & (W2TR-W2HR+W3TUSR))
18909 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
18910 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18911 & (W2UR-W2HR+W3USTR))
18912 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
18913 A2STUR=A2STUR+B2STUR+B2SUTR
18914 A2STUI=A2STUI+B2STUI+B2SUTI
18915 A2USTR=A2USTR+B2USTR+B2UTSR
18916 A2USTI=A2USTI+B2USTI+B2UTSI
18917 A2TUSR=A2TUSR+B2TUSR+B2TSUR
18918 A2TUSI=A2TUSI+B2TUSI+B2TSUI
18919 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
18920 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
18921 1170 CONTINUE
18922 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
18923 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
18924 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
18925 FACGH=FACGH*WIDS(25,2)
18926 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
18927 NCHN=NCHN+1
18928 ISIG(NCHN,1)=21
18929 ISIG(NCHN,2)=21
18930 ISIG(NCHN,3)=1
18931 SIGH(NCHN)=FACGH
18932 1180 CONTINUE
18933
18934 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
18935C...g + g -> gamma + gamma or g + g -> g + gamma
18936 A0STUR=0D0
18937 A0STUI=0D0
18938 A0TSUR=0D0
18939 A0TSUI=0D0
18940 A0UTSR=0D0
18941 A0UTSI=0D0
18942 A1STUR=0D0
18943 A1STUI=0D0
18944 A2STUR=0D0
18945 A2STUI=0D0
18946 ALST=LOG(-SH/TH)
18947 ALSU=LOG(-SH/UH)
18948 ALTU=LOG(TH/UH)
18949 IMAX=2*MSTP(1)
18950 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
18951 DO 1190 I=1,IMAX
18952 EI=KCHG(IABS(I),1)/3D0
18953 EIWT=EI**2
18954 IF(ISUB.EQ.115) EIWT=EI
18955 SQMQ=PMAS(I,1)**2
18956 EPSS=4D0*SQMQ/SH
18957 EPST=4D0*SQMQ/TH
18958 EPSU=4D0*SQMQ/UH
18959 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1.D-4) THEN
18960 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
18961 & PARU(1)**2)
18962 B0STUI=0D0
18963 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
18964 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
18965 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
18966 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
18967 B1STUR=-1D0
18968 B1STUI=0D0
18969 B2STUR=-1D0
18970 B2STUI=0D0
18971 ELSE
18972 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18973 CALL PYWAUX(1,EPST,W1TR,W1TI)
18974 CALL PYWAUX(1,EPSU,W1UR,W1UI)
18975 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18976 CALL PYWAUX(2,EPST,W2TR,W2TI)
18977 CALL PYWAUX(2,EPSU,W2UR,W2UI)
18978 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18979 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18980 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18981 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18982 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18983 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18984 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
18985 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
18986 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
18987 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
18988 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
18989 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
18990 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
18991 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
18992 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
18993 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
18994 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
18995 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
18996 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
18997 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
18998 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
18999 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
19000 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19001 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
19002 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
19003 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
19004 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
19005 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
19006 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19007 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
19008 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
19009 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
19010 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
19011 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
19012 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19013 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
19014 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
19015 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
19016 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
19017 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
19018 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19019 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
19020 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
19021 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
19022 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
19023 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19024 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
19025 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
19026 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
19027 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19028 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
19029 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
19030 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
19031 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
19032 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
19033 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
19034 ENDIF
19035 A0STUR=A0STUR+EIWT*B0STUR
19036 A0STUI=A0STUI+EIWT*B0STUI
19037 A0TSUR=A0TSUR+EIWT*B0TSUR
19038 A0TSUI=A0TSUI+EIWT*B0TSUI
19039 A0UTSR=A0UTSR+EIWT*B0UTSR
19040 A0UTSI=A0UTSI+EIWT*B0UTSI
19041 A1STUR=A1STUR+EIWT*B1STUR
19042 A1STUI=A1STUI+EIWT*B1STUI
19043 A2STUR=A2STUR+EIWT*B2STUR
19044 A2STUI=A2STUI+EIWT*B2STUI
19045 1190 CONTINUE
19046 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
19047 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
19048 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
19049 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
19050 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
19051 NCHN=NCHN+1
19052 ISIG(NCHN,1)=21
19053 ISIG(NCHN,2)=21
19054 ISIG(NCHN,3)=1
19055 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
19056 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
19057 1200 CONTINUE
19058
19059 ELSEIF(ISUB.EQ.116) THEN
19060C...g + g -> gamma + Z0
19061
19062 ELSEIF(ISUB.EQ.117) THEN
19063C...g + g -> Z0 + Z0
19064
19065 ELSEIF(ISUB.EQ.118) THEN
19066C...g + g -> W+ + W-
19067
19068 ENDIF
19069
19070C...G: 2 -> 3, tree diagrams
19071
19072 ELSEIF(ISUB.LE.140) THEN
19073 IF(ISUB.EQ.121) THEN
19074C...g + g -> Q + Qbar + h0
19075 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
19076 IA=KFPR(ISUBSV,2)
19077 PMF=PMAS(IA,1)
19078 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19079 & (0.5D0*PMF/PMAS(24,1))**2
19080 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19081 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19082 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19083 WID2=1D0
19084 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19085 FACQQH=FACQQH*WID2
19086 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19087 IKFI=1
19088 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19089 IF(IA.GT.10) IKFI=3
19090 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19091 ENDIF
19092 CALL PYQQBH(WTQQBH)
19093 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19094 HS=SHR*WDTP(0)
19095 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19096 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19097 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19098 & FACBW=0D0
19099 NCHN=NCHN+1
19100 ISIG(NCHN,1)=21
19101 ISIG(NCHN,2)=21
19102 ISIG(NCHN,3)=1
19103 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19104 1210 CONTINUE
19105
19106 ELSEIF(ISUB.EQ.122) THEN
19107C...q + qbar -> Q + Qbar + h0
19108 IA=KFPR(ISUBSV,2)
19109 PMF=PMAS(IA,1)
19110 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19111 & (0.5D0*PMF/PMAS(24,1))**2
19112 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19113 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19114 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19115 WID2=1D0
19116 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19117 FACQQH=FACQQH*WID2
19118 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19119 IKFI=1
19120 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19121 IF(IA.GT.10) IKFI=3
19122 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19123 ENDIF
19124 CALL PYQQBH(WTQQBH)
19125 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19126 HS=SHR*WDTP(0)
19127 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19128 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19129 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19130 & FACBW=0D0
19131 DO 1220 I=MMINA,MMAXA
19132 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19133 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
19134 NCHN=NCHN+1
19135 ISIG(NCHN,1)=I
19136 ISIG(NCHN,2)=-I
19137 ISIG(NCHN,3)=1
19138 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19139 1220 CONTINUE
19140
19141 ELSEIF(ISUB.EQ.123) THEN
19142C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
19143C...inner process)
19144 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
19145 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19146 & PARU(154+10*IHIGG)**2
19147 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19148 & (VINT(216)-VINT(209)**2))**2
19149 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19150 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
19151 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19152 HS=SHR*WDTP(0)
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))
19156 & FACBW=0D0
19157 DO 1240 I=MMIN1,MMAX1
19158 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
19159 IA=IABS(I)
19160 DO 1230 J=MMIN2,MMAX2
19161 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
19162 JA=IABS(J)
19163 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19164 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19165 VI=AI-4D0*EI*XWV
19166 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19167 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19168 VJ=AJ-4D0*EJ*XWV
19169 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
19170 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
19171 NCHN=NCHN+1
19172 ISIG(NCHN,1)=I
19173 ISIG(NCHN,2)=J
19174 ISIG(NCHN,3)=1
19175 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
19176 1230 CONTINUE
19177 1240 CONTINUE
19178
19179 ELSEIF(ISUB.EQ.124) THEN
19180C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
19181C...inner process)
19182 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
19183 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19184 & PARU(155+10*IHIGG)**2
19185 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19186 & (VINT(216)-VINT(209)**2))**2
19187 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19188 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19189 HS=SHR*WDTP(0)
19190 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19191 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19192 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19193 & FACBW=0D0
19194 DO 1260 I=MMIN1,MMAX1
19195 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
19196 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19197 DO 1250 J=MMIN2,MMAX2
19198 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
19199 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19200 IF(EI*EJ.GT.0D0) GOTO 1250
19201 FACLR=VINT(180+I)*VINT(180+J)
19202 NCHN=NCHN+1
19203 ISIG(NCHN,1)=I
19204 ISIG(NCHN,2)=J
19205 ISIG(NCHN,3)=1
19206 SIGH(NCHN)=FACLR*FACWW*FACBW
19207 1250 CONTINUE
19208 1260 CONTINUE
19209
19210 ELSEIF(ISUB.EQ.131) THEN
19211C...g + g -> Z0 + q + qbar
19212
19213 ENDIF
19214
19215C...H: 2 -> 1, tree diagrams, non-standard model processes
19216
19217 ELSEIF(ISUB.LE.160) THEN
19218 IF(ISUB.EQ.141) THEN
19219C...f + fbar -> gamma*/Z0/Z'0
19220 SQMZP=PMAS(32,1)**2
19221 MINT(61)=2
19222 CALL PYWIDT(32,SH,WDTP,WDTE)
19223 HP0=AEM/3D0*SH
19224 HP1=AEM/3D0*XWC*SH
19225 HP2=HP1
19226 HS=SHR*VINT(117)
19227 HSP=SHR*WDTP(0)
19228 FACZP=4D0*COMFAC*3D0
19229 DO 1270 I=MMINA,MMAXA
19230 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270
19231 EI=KCHG(IABS(I),1)/3D0
19232 AI=SIGN(1D0,EI)
19233 VI=AI-4D0*EI*XWV
19234 IF(IABS(I).LT.10) THEN
19235 VPI=PARU(123-2*MOD(IABS(I),2))
19236 API=PARU(124-2*MOD(IABS(I),2))
19237 ELSE
19238 VPI=PARU(127-2*MOD(IABS(I),2))
19239 API=PARU(128-2*MOD(IABS(I),2))
19240 ENDIF
19241 HI0=HP0
19242 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19243 HI1=HP1
19244 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19245 HI2=HP2
19246 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
19247 NCHN=NCHN+1
19248 ISIG(NCHN,1)=I
19249 ISIG(NCHN,2)=-I
19250 ISIG(NCHN,3)=1
19251 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
19252 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
19253 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
19254 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
19255 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
19256 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
19257 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
19258 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
19259 1270 CONTINUE
19260
19261 ELSEIF(ISUB.EQ.142) THEN
19262C...f + fbar' -> W'+/-
19263 SQMWP=PMAS(34,1)**2
19264 CALL PYWIDT(34,SH,WDTP,WDTE)
19265 HS=SHR*WDTP(0)
19266 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
19267 HP=AEM/(24D0*XW)*SH
19268 DO 1290 I=MMIN1,MMAX1
19269 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290
19270 IA=IABS(I)
19271 DO 1280 J=MMIN2,MMAX2
19272 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280
19273 JA=IABS(J)
19274 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280
19275 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19276 & GOTO 1280
19277 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19278 HI=HP*(PARU(133)**2+PARU(134)**2)
19279 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
19280 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19281 NCHN=NCHN+1
19282 ISIG(NCHN,1)=I
19283 ISIG(NCHN,2)=J
19284 ISIG(NCHN,3)=1
19285 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19286 SIGH(NCHN)=HI*FACBW*HF
19287 1280 CONTINUE
19288 1290 CONTINUE
19289
19290 ELSEIF(ISUB.EQ.143) THEN
19291C...f + fbar' -> H+/-
19292 SQMHC=PMAS(37,1)**2
19293 CALL PYWIDT(37,SH,WDTP,WDTE)
19294 HS=SHR*WDTP(0)
19295 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
19296 HP=AEM/(8D0*XW)*SH/SQMW*SH
19297 DO 1310 I=MMIN1,MMAX1
19298 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310
19299 IA=IABS(I)
19300 IM=(MOD(IA,10)+1)/2
19301 DO 1300 J=MMIN2,MMAX2
19302 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300
19303 JA=IABS(J)
19304 JM=(MOD(JA,10)+1)/2
19305 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300
19306 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19307 & GOTO 1300
19308 IF(MOD(IA,2).EQ.0) THEN
19309 IU=IA
19310 IL=JA
19311 ELSE
19312 IU=JA
19313 IL=IA
19314 ENDIF
19315 RML=PMAS(IL,1)**2/SH
19316 RMU=PMAS(IU,1)**2/SH
19317 IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML=
19318 & RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/
19319 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-
19320 & 2D0*MSTU(118)))
19321 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
19322 IF(IA.LE.10) HI=HI*FACA/3D0
19323 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19324 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
19325 NCHN=NCHN+1
19326 ISIG(NCHN,1)=I
19327 ISIG(NCHN,2)=J
19328 ISIG(NCHN,3)=1
19329 SIGH(NCHN)=HI*FACBW*HF
19330 1300 CONTINUE
19331 1310 CONTINUE
19332
19333 ELSEIF(ISUB.EQ.144) THEN
19334C...f + fbar' -> R
19335 SQMR=PMAS(40,1)**2
19336 CALL PYWIDT(40,SH,WDTP,WDTE)
19337 HS=SHR*WDTP(0)
19338 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
19339 HP=AEM/(12D0*XW)*SH
19340 DO 1330 I=MMIN1,MMAX1
19341 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330
19342 IA=IABS(I)
19343 DO 1320 J=MMIN2,MMAX2
19344 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320
19345 JA=IABS(J)
19346 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320
19347 HI=HP
19348 IF(IA.LE.10) HI=HI*FACA/3D0
19349 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
19350 NCHN=NCHN+1
19351 ISIG(NCHN,1)=I
19352 ISIG(NCHN,2)=J
19353 ISIG(NCHN,3)=1
19354 SIGH(NCHN)=HI*FACBW*HF
19355 1320 CONTINUE
19356 1330 CONTINUE
19357
19358 ELSEIF(ISUB.EQ.145) THEN
19359C...q + l -> LQ (leptoquark)
19360 SQMLQ=PMAS(39,1)**2
19361 CALL PYWIDT(39,SH,WDTP,WDTE)
19362 HS=SHR*WDTP(0)
19363 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
19364 IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
19365 HP=AEM/4D0*SH
19366 KFLQQ=KFDP(MDCY(39,2),1)
19367 KFLQL=KFDP(MDCY(39,2),2)
19368 DO 1350 I=MMIN1,MMAX1
19369 IF(KFAC(1,I).EQ.0) GOTO 1350
19370 IA=IABS(I)
19371 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350
19372 DO 1340 J=MMIN2,MMAX2
19373 IF(KFAC(2,J).EQ.0) GOTO 1340
19374 JA=IABS(J)
19375 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340
19376 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340
19377 IF(JA.EQ.IA) GOTO 1340
19378 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
19379 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
19380 HI=HP*PARU(151)
19381 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
19382 NCHN=NCHN+1
19383 ISIG(NCHN,1)=I
19384 ISIG(NCHN,2)=J
19385 ISIG(NCHN,3)=1
19386 SIGH(NCHN)=HI*FACBW*HF
19387 1340 CONTINUE
19388 1350 CONTINUE
19389
19390 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
19391C...d + g -> d* and u + g -> u* (excited quarks)
19392 KFQSTR=KFPR(ISUB,1)
19393 KCQSTR=PYCOMP(KFQSTR)
19394 KFQEXC=MOD(KFQSTR,KEXCIT)
19395 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
19396 HS=SHR*WDTP(0)
19397 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
19398 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
19399 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
19400 & FACBW=0D0
19401 HP=SH
19402 DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC
19403 DO 1360 ISDE=1,2
19404 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
19405 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
19406 HI=HP
19407 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19408 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
19409 NCHN=NCHN+1
19410 ISIG(NCHN,ISDE)=I
19411 ISIG(NCHN,3-ISDE)=21
19412 ISIG(NCHN,3)=1
19413 SIGH(NCHN)=HI*FACBW*HF
19414 1360 CONTINUE
19415 1370 CONTINUE
19416
19417 ELSEIF(ISUB.EQ.149) THEN
19418C...g + g -> eta_techni
19419 CALL PYWIDT(38,SH,WDTP,WDTE)
19420 HS=SHR*WDTP(0)
19421 FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
19422 IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
19423 HP=SH
19424 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380
19425 HI=HP*WDTP(3)
19426 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19427 NCHN=NCHN+1
19428 ISIG(NCHN,1)=21
19429 ISIG(NCHN,2)=21
19430 ISIG(NCHN,3)=1
19431 SIGH(NCHN)=HI*FACBW*HF
19432 1380 CONTINUE
19433
19434 ENDIF
19435
19436C...I: 2 -> 2, tree diagrams, non-standard model processes
19437
19438 ELSEIF(ISUB.LE.200) THEN
19439 IF(ISUB.EQ.161) THEN
19440C...f + g -> f' + H+/- (b + g -> t + H+/- only)
19441C...(choice of only b and t to avoid kinematics problems)
19442 SQMHC=PMAS(37,1)**2
19443 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
19444 DO 1400 I=MMINA,MMAXA
19445 IA=IABS(I)
19446 IF(IA.NE.5) GOTO 1400
19447 SQML=PMAS(IA,1)**2
19448 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
19449 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
19450 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19451 IUA=IA+MOD(IA,2)
19452 SQMQ=PMAS(IUA,1)**2
19453 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
19454 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
19455 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
19456 & (SQMHC-SQMQ-SH)/SH)
19457 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
19458 DO 1390 ISDE=1,2
19459 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390
19460 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390
19461 NCHN=NCHN+1
19462 ISIG(NCHN,ISDE)=I
19463 ISIG(NCHN,3-ISDE)=21
19464 ISIG(NCHN,3)=1
19465 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
19466 1390 CONTINUE
19467 1400 CONTINUE
19468
19469 ELSEIF(ISUB.EQ.162) THEN
19470C...q + g -> LQ + lbar; LQ=leptoquark
19471 SQMLQ=PMAS(39,1)**2
19472 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
19473 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
19474 KFLQQ=KFDP(MDCY(39,2),1)
19475 DO 1420 I=MMINA,MMAXA
19476 IF(IABS(I).NE.KFLQQ) GOTO 1420
19477 KCHLQ=ISIGN(1,I)
19478 DO 1410 ISDE=1,2
19479 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410
19480 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410
19481 NCHN=NCHN+1
19482 ISIG(NCHN,ISDE)=I
19483 ISIG(NCHN,3-ISDE)=21
19484 ISIG(NCHN,3)=1
19485 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
19486 1410 CONTINUE
19487 1420 CONTINUE
19488
19489 ELSEIF(ISUB.EQ.163) THEN
19490C...g + g -> LQ + LQbar; LQ=leptoquark
19491 SQMLQ=PMAS(39,1)**2
19492 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
19493 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
19494 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
19495 & ((TH-SQMLQ)*(UH-SQMLQ)))
19496 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430
19497 NCHN=NCHN+1
19498 ISIG(NCHN,1)=21
19499 ISIG(NCHN,2)=21
19500C...Since don't know proper colour flow, randomize between alternatives
19501 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
19502 SIGH(NCHN)=FACLQ
19503 1430 CONTINUE
19504
19505 ELSEIF(ISUB.EQ.164) THEN
19506C...q + qbar -> LQ + LQbar; LQ=leptoquark
19507 SQMLQ=PMAS(39,1)**2
19508 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
19509 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
19510 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
19511 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
19512 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
19513 KFLQQ=KFDP(MDCY(39,2),1)
19514 DO 1440 I=MMINA,MMAXA
19515 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19516 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440
19517 NCHN=NCHN+1
19518 ISIG(NCHN,1)=I
19519 ISIG(NCHN,2)=-I
19520 ISIG(NCHN,3)=1
19521 SIGH(NCHN)=FACLQA
19522 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
19523 1440 CONTINUE
19524
19525 ELSEIF(ISUB.EQ.165) THEN
19526C...q + qbar -> l+ + l- (including contact term for compositeness)
19527 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19528 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19529 KFF=IABS(KFPR(ISUB,1))
19530 EF=KCHG(KFF,1)/3D0
19531 AF=SIGN(1D0,EF+0.1D0)
19532 VF=AF-4D0*EF*XWV
19533 VALF=VF+AF
19534 VARF=VF-AF
19535 FCOF=1D0
19536 IF(KFF.LE.10) FCOF=3D0
19537 WID2=1D0
19538 IF(KFF.EQ.6) WID2=WIDS(6,1)
19539 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
19540 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19541 DO 1450 I=MMINA,MMAXA
19542 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450
19543 EI=KCHG(IABS(I),1)/3D0
19544 AI=SIGN(1D0,EI+0.1D0)
19545 VI=AI-4D0*EI*XWV
19546 VALI=VI+AI
19547 VARI=VI-AI
19548 FCOI=1D0
19549 IF(IABS(I).LE.10) FCOI=FACA/3D0
19550 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
19551 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
19552 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
19553 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19554 ELSE
19555 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
19556 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19557 ENDIF
19558 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
19559 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
19560 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
19561 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
19562 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
19563 NCHN=NCHN+1
19564 ISIG(NCHN,1)=I
19565 ISIG(NCHN,2)=-I
19566 ISIG(NCHN,3)=1
19567 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
19568 1450 CONTINUE
19569
19570 ELSEIF(ISUB.EQ.166) THEN
19571C...q + q'bar -> l + nu_l (including contact term for compositeness)
19572 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
19573 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
19574 KFF=IABS(KFPR(ISUB,1))
19575 FCOF=1D0
19576 IF(KFF.LE.10) FCOF=3D0
19577 DO 1470 I=MMIN1,MMAX1
19578 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
19579 IA=IABS(I)
19580 DO 1460 J=MMIN2,MMAX2
19581 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
19582 JA=IABS(J)
19583 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460
19584 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19585 & GOTO 1460
19586 FCOI=1D0
19587 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19588 WID2=1D0
19589 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
19590 & MOD(J,2).EQ.0)) THEN
19591 IF(KFF.EQ.5) WID2=WIDS(6,2)
19592 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
19593 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
19594 ELSE
19595 IF(KFF.EQ.5) WID2=WIDS(6,3)
19596 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
19597 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
19598 ENDIF
19599 NCHN=NCHN+1
19600 ISIG(NCHN,1)=I
19601 ISIG(NCHN,2)=J
19602 ISIG(NCHN,3)=1
19603 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
19604 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
19605 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
19606 1460 CONTINUE
19607 1470 CONTINUE
19608
19609 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
19610C...d + g -> d* and u + g -> u* (excited quarks)
19611 KFQSTR=KFPR(ISUB,2)
19612 KCQSTR=PYCOMP(KFQSTR)
19613 KFQEXC=MOD(KFQSTR,KEXCIT)
19614 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
19615 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
19616 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
19617C...Propagators: as simulated in PYOFSH and as desired
19618 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
19619 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
19620 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
19621 GMMQC=SQRT(SQM4)*WDTP(0)
19622 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
19623 FACQSA=FACQSA*HBW4C/HBW4
19624 FACQSB=FACQSB*HBW4C/HBW4
19625 DO 1490 I=MMIN1,MMAX1
19626 IA=IABS(I)
19627 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490
19628 DO 1480 J=MMIN2,MMAX2
19629 JA=IABS(J)
19630 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480
19631 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
19632 NCHN=NCHN+1
19633 ISIG(NCHN,1)=I
19634 ISIG(NCHN,2)=J
19635 ISIG(NCHN,3)=1
19636 SIGH(NCHN)=(4D0/3D0)*FACQSA
19637 NCHN=NCHN+1
19638 ISIG(NCHN,1)=I
19639 ISIG(NCHN,2)=J
19640 ISIG(NCHN,3)=2
19641 SIGH(NCHN)=(4D0/3D0)*FACQSA
19642 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
19643 NCHN=NCHN+1
19644 ISIG(NCHN,1)=I
19645 ISIG(NCHN,2)=J
19646 ISIG(NCHN,3)=1
19647 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19648 SIGH(NCHN)=FACQSA
19649 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
19650 NCHN=NCHN+1
19651 ISIG(NCHN,1)=I
19652 ISIG(NCHN,2)=J
19653 ISIG(NCHN,3)=1
19654 SIGH(NCHN)=(8D0/3D0)*FACQSB
19655 NCHN=NCHN+1
19656 ISIG(NCHN,1)=I
19657 ISIG(NCHN,2)=J
19658 ISIG(NCHN,3)=2
19659 SIGH(NCHN)=(8D0/3D0)*FACQSB
19660 ELSEIF(I.EQ.-J) THEN
19661 NCHN=NCHN+1
19662 ISIG(NCHN,1)=I
19663 ISIG(NCHN,2)=J
19664 ISIG(NCHN,3)=1
19665 SIGH(NCHN)=FACQSB
19666 NCHN=NCHN+1
19667 ISIG(NCHN,1)=I
19668 ISIG(NCHN,2)=J
19669 ISIG(NCHN,3)=2
19670 SIGH(NCHN)=FACQSB
19671 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
19672 NCHN=NCHN+1
19673 ISIG(NCHN,1)=I
19674 ISIG(NCHN,2)=J
19675 ISIG(NCHN,3)=1
19676 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19677 SIGH(NCHN)=FACQSB
19678 ENDIF
19679 1480 CONTINUE
19680 1490 CONTINUE
19681
19682 ELSEIF(ISUB.EQ.191) THEN
19683C...q + qbar -> rho_tech0.
19684 SQMRHT=PMAS(54,1)**2
19685 CALL PYWIDT(54,SH,WDTP,WDTE)
19686 HS=SHR*WDTP(0)
19687 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19688 IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
19689 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19690 ALPRHT=2.91D0*(3D0/PARP(144))
19691 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
19692 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19693 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19694 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19695 DO 1500 I=MMINA,MMAXA
19696 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
19697 IA=IABS(I)
19698 EI=KCHG(IABS(I),1)/3D0
19699 AI=SIGN(1D0,EI+0.1D0)
19700 VI=AI-4D0*EI*XWV
19701 VALI=0.5D0*(VI+AI)
19702 VARI=0.5D0*(VI-AI)
19703 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
19704 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
19705 IF(IA.LE.10) HI=HI*FACA/3D0
19706 NCHN=NCHN+1
19707 ISIG(NCHN,1)=I
19708 ISIG(NCHN,2)=-I
19709 ISIG(NCHN,3)=1
19710 SIGH(NCHN)=HI*FACBW*HF
19711 1500 CONTINUE
19712
19713 ELSEIF(ISUB.EQ.192) THEN
19714C...q + qbar' -> rho_tech+/-.
19715 SQMRHT=PMAS(55,1)**2
19716 CALL PYWIDT(55,SH,WDTP,WDTE)
19717 HS=SHR*WDTP(0)
19718 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19719 IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
19720 ALPRHT=2.91D0*(3D0/PARP(144))
19721 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
19722 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
19723 DO 1520 I=MMIN1,MMAX1
19724 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520
19725 IA=IABS(I)
19726 DO 1510 J=MMIN2,MMAX2
19727 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510
19728 JA=IABS(J)
19729 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510
19730 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19731 & GOTO 1510
19732 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19733 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
19734 HI=HP
19735 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19736 NCHN=NCHN+1
19737 ISIG(NCHN,1)=I
19738 ISIG(NCHN,2)=J
19739 ISIG(NCHN,3)=1
19740 SIGH(NCHN)=HI*FACBW*HF
19741 1510 CONTINUE
19742 1520 CONTINUE
19743
19744 ELSEIF(ISUB.EQ.193) THEN
19745C...q + qbar -> omega_tech0.
19746 SQMOMT=PMAS(56,1)**2
19747 CALL PYWIDT(56,SH,WDTP,WDTE)
19748 HS=SHR*WDTP(0)
19749 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
19750 IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
19751 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19752 ALPRHT=2.91D0*(3D0/PARP(144))
19753 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
19754 & (2D0*PARP(143)-1D0)**2
19755 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19756 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19757 DO 1530 I=MMINA,MMAXA
19758 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530
19759 IA=IABS(I)
19760 EI=KCHG(IABS(I),1)/3D0
19761 AI=SIGN(1D0,EI+0.1D0)
19762 VI=AI-4D0*EI*XWV
19763 VALI=0.5D0*(VI+AI)
19764 VARI=0.5D0*(VI-AI)
19765 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
19766 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
19767 IF(IA.LE.10) HI=HI*FACA/3D0
19768 NCHN=NCHN+1
19769 ISIG(NCHN,1)=I
19770 ISIG(NCHN,2)=-I
19771 ISIG(NCHN,3)=1
19772 SIGH(NCHN)=HI*FACBW*HF
19773 1530 CONTINUE
19774
19775 ELSEIF(ISUB.EQ.194) THEN
19776C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
19777 SQMRHT=PMAS(54,1)**2
19778 CALL PYWIDT(54,SH,WDTP,WDTE)
19779 HSRHT=SHR*WDTP(0)
19780 BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2)
19781 BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2)
19782 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19783 SQMOMT=PMAS(56,1)**2
19784 CALL PYWIDT(56,SH,WDTP,WDTE)
19785 HSOMT=SHR*WDTP(0)
19786 BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2)
19787 BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2)
19788 XWOMT=0.5D0/(1D0-XW)
19789 KFF=IABS(KFPR(ISUB,1))
19790 EF=KCHG(KFF,1)/3D0
19791 AF=SIGN(1D0,EF+0.1D0)
19792 VF=AF-4D0*EF*XWV
19793 VALF=0.5D0*(VF+AF)
19794 VARF=0.5D0*(VF-AF)
19795 FCOF=1D0
19796 IF(KFF.LE.10) FCOF=3D0
19797 WID2=1D0
19798 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
19799 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19800 ALPRHT=2.91D0*(3D0/PARP(144))
19801 FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2
19802 BWZ=SH/(SH-SQMZ)
19803 ALEFTF=EF+VALF*XWRHT*BWZ
19804 ARIGHF=EF+VARF*XWRHT*BWZ
19805 BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19806 BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19807 DO 1540 I=MMINA,MMAXA
19808 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
19809 EI=KCHG(IABS(I),1)/3D0
19810 AI=SIGN(1D0,EI+0.1D0)
19811 VI=AI-4D0*EI*XWV
19812 VALI=0.5D0*(VI+AI)
19813 VARI=0.5D0*(VI-AI)
19814 FCOI=1D0
19815 IF(IABS(I).LE.10) FCOI=FACA/3D0
19816 ALEFTI=EI+VALI*XWRHT*BWZ
19817 ARIGHI=EI+VARI*XWRHT*BWZ
19818 BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19819 BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19820 DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+
19821 & (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2
19822 DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+
19823 & (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2
19824 DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+
19825 & (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2
19826 DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+
19827 & (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2
19828 FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2
19829 NCHN=NCHN+1
19830 ISIG(NCHN,1)=I
19831 ISIG(NCHN,2)=-I
19832 ISIG(NCHN,3)=1
19833 SIGH(NCHN)=FACTC*FCOI*FACSIG
19834 1540 CONTINUE
19835
19836 ENDIF
19837
19838CMRENNA++
19839C...J: 2 -> 2, tree diagrams, SUSY processes
19840
19841 ELSEIF(ISUB.LE.210) THEN
19842 IF(ISUB.EQ.201) THEN
19843C...f + fbar -> e_L + e_Lbar
19844 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
19845 DO 1570 I=MMIN1,MMAX1
19846 IA=IABS(I)
19847 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570
19848 EI=KCHG(IA,1)/3D0
19849 TT3I=SIGN(1D0,EI+1D-6)/2D0
19850 EJ=-1D0
19851 TT3J=-1D0/2D0
19852 FCOL=1D0
19853C...Color factor for e+ e-
19854 IF(IA.GE.11) FCOL=3D0
19855 IF(ILR.EQ.1) THEN
19856 A1=SFMIX(KFID,3)**2
19857 A2=SFMIX(KFID,4)**2
19858 ELSEIF(ILR.EQ.0) THEN
19859 A1=SFMIX(KFID,1)**2
19860 A2=SFMIX(KFID,2)**2
19861 ENDIF
19862 XLQ=(TT3J-EJ*XW)*A1
19863 XRQ=(-EJ*XW)*A2
19864 XLF=(TT3I-EI*XW)
19865 XRF=(-EI*XW)
19866 TAA=2D0*(EI*EJ)**2
19867 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
19868 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
19869 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
19870 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
19871 TNN=0.0D0
19872 TAN=0.0D0
19873 TZN=0.0D0
19874 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19875 FAC2=SQRT(2D0)
19876 TNN1=0D0
19877 TNN2=0D0
19878 TNN3=0D0
19879 DO 1560 II=1,4
19880 DK=1D0/(TH-SMZ(II)**2)
19881 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19882 & ZMIX(II,1))
19883 FREK=FAC2*TANW*EI*ZMIX(II,1)
19884 TNN1=TNN1+FLEK**2*DK
19885 TNN2=TNN2+FREK**2*DK
19886 DO 1550 JJ=1,4
19887 DL=1D0/(TH-SMZ(JJ)**2)
19888 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19889 & ZMIX(JJ,1))
19890 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19891 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19892 1550 CONTINUE
19893 1560 CONTINUE
19894 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
19895 TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
19896 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
19897 & (TNN1*XLF*A1+TNN2*XRF*A2)
19898 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19899 & (1D0-SQMZ/SH)/SH
19900 TZN=TZN/XW**2/XW1
19901 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
19902 ENDIF
19903 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
19904 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
19905 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
19906 NCHN=NCHN+1
19907 ISIG(NCHN,1)=I
19908 ISIG(NCHN,2)=-I
19909 ISIG(NCHN,3)=1
19910 SIGH(NCHN)=FACQQ1+FACQQ2
19911 1570 CONTINUE
19912
19913 ELSEIF(ISUB.EQ.203) THEN
19914C...f + fbar -> e_L + e_Rbar
19915 DO 1600 I=MMIN1,MMAX1
19916 IA=IABS(I)
19917 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
19918 EI=KCHG(IABS(I),1)/3D0
19919 TT3I=SIGN(1D0,EI)/2D0
19920 EJ=-1
19921 TT3J=-1D0/2D0
19922 FCOL=1D0
19923C...Color factor for e+ e-
19924 IF(IA.GE.11) FCOL=3D0
19925 A1=SFMIX(KFID,1)**2
19926 A2=SFMIX(KFID,2)**2
19927 XLQ=(TT3J-EJ*XW)
19928 XRQ=(-EJ*XW)
19929 XLF=(TT3I-EI*XW)
19930 XRF=(-EI*XW)
19931 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
19932 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
19933 TNN=0.0D0
19934 TZN=0.0D0
19935 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19936 FAC2=SQRT(2D0)
19937 TNN1=0D0
19938 TNN2=0D0
19939 TNN3=0D0
19940 DO 1590 II=1,4
19941 DK=1D0/(TH-SMZ(II)**2)
19942 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19943 & ZMIX(II,1))
19944 FREK=FAC2*TANW*EI*ZMIX(II,1)
19945 TNN1=TNN1+FLEK**2*DK
19946 TNN2=TNN2+FREK**2*DK
19947 DO 1580 JJ=1,4
19948 DL=1D0/(TH-SMZ(JJ)**2)
19949 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19950 & ZMIX(JJ,1))
19951 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19952 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19953 1580 CONTINUE
19954 1590 CONTINUE
19955 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
19956 TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
19957 TZN=(UH*TH-SQM3*SQM4)*A1*A2
19958 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
19959 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19960 & (1D0-SQMZ/SH)/SH
19961 ENDIF
19962 FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
19963 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
19964 FACQQ=(FACQQ1+FACQQ2)
19965 NCHN=NCHN+1
19966 ISIG(NCHN,1)=I
19967 ISIG(NCHN,2)=-I
19968 ISIG(NCHN,3)=1
19969 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
19970 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
19971 NCHN=NCHN+1
19972 ISIG(NCHN,1)=I
19973 ISIG(NCHN,2)=-I
19974 ISIG(NCHN,3)=2
19975 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
19976 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
19977 1600 CONTINUE
19978
19979 ELSEIF(ISUB.EQ.210) THEN
19980C...q + qbar' -> W*- > ~l_L + ~nu_L
19981 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
19982 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
19983 DO 1620 I=MMIN1,MMAX1
19984 IA=IABS(I)
19985 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620
19986 DO 1610 J=MMIN2,MMAX2
19987 JA=IABS(J)
19988 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610
19989 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610
19990 FCKM=3D0
19991 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
19992 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
19993 KCHW=2
19994 IF(KCHSUM.LT.0) KCHW=3
19995 NCHN=NCHN+1
19996 ISIG(NCHN,1)=I
19997 ISIG(NCHN,2)=J
19998 ISIG(NCHN,3)=1
19999 SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),
20000 & 5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20001 1610 CONTINUE
20002 1620 CONTINUE
20003 ENDIF
20004
20005 ELSEIF(ISUB.LE.220) THEN
20006 IF(ISUB.EQ.213) THEN
20007C...f + fbar -> ~nu_L + ~nu_Lbar
20008 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20009 PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
20010 XLL=0.5D0
20011 XLR=0.0D0
20012 DO 1630 I=MMIN1,MMAX1
20013 IA=IABS(I)
20014 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
20015 EI=KCHG(IA,1)/3D0
20016 FCOL=1D0
20017C...Color factor for e+ e-
20018 IF(IA.GE.11) FCOL=3D0
20019 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20020 XRQ=-EI*XW
20021 TZC=0.0D0
20022 TCC=0.0D0
20023 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
20024 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
20025 & (TH-SMW(2)**2)
20026 TCC=TZC**2
20027 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
20028 ENDIF
20029 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
20030 FACQQ2=TZC+TCC/4D0
20031 NCHN=NCHN+1
20032 ISIG(NCHN,1)=I
20033 ISIG(NCHN,2)=-I
20034 ISIG(NCHN,3)=1
20035 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
20036 & *AEM**2*FCOL/3D0/XW**2
20037 1630 CONTINUE
20038
20039 ELSEIF(ISUB.EQ.216) THEN
20040C...q + qbar -> ~chi0_1 + ~chi0_1
20041 IF(IZID1.EQ.IZID2) THEN
20042 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20043 ELSE
20044 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20045 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20046 ENDIF
20047 FACGG1=COMFAC*AEM**2/3D0/XW**2
20048 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
20049 ZM12=SQM3
20050 ZM22=SQM4
20051 SR2=SQRT(2D0)
20052 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20053 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20054 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
20055 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20056 REPRPZ = (SH-SQMZ)/PROPZ2
20057 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
20058 & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
20059 DO 1640 I=MMINA,MMAXA
20060 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640
20061 EI=KCHG(IABS(I),1)/3D0
20062 FCOL=1D0
20063 IF(ABS(I).GE.11) FCOL=3D0
20064 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20065 XRQ=-EI*XW
20066 XLQ=XLQ/XW1
20067 XRQ=XRQ/XW1
20068C...Factored out sqrt(2)
20069 FR1=TANW*EI*ZMIX(IZID1,1)
20070 FR2=TANW*EI*ZMIX(IZID2,1)
20071 FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
20072 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
20073 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
20074 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
20075 FR12=FR1**2
20076 FR22=FR2**2
20077 FL12=FL1**2
20078 FL22=FL2**2
20079 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
20080 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
20081 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
20082 FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
20083 & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
20084 FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
20085 & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
20086 FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
20087 & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
20088 FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
20089 & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
20090 NCHN=NCHN+1
20091 ISIG(NCHN,1)=I
20092 ISIG(NCHN,2)=-I
20093 ISIG(NCHN,3)=1
20094 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
20095 1640 CONTINUE
20096 ENDIF
20097
20098 ELSEIF(ISUB.LE.230) THEN
20099 IF(ISUB.EQ.226) THEN
20100C...f + fbar -> ~chi+_1 + ~chi-_1
20101 FACGG1=COMFAC*AEM**2/3D0/XW**2
20102 ZM12=SQM3
20103 ZM22=SQM4
20104 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20105 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20106 WS2 = SMW(IZID1)*SMW(IZID2)/SH
20107 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20108 REPRPZ = (SH-SQMZ)/PROPZ2
20109 DIFF=0D0
20110 IF(IZID1.EQ.IZID2) DIFF=1D0
20111 DO 1650 I=MMINA,MMAXA
20112 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650
20113 EI=KCHG(IABS(I),1)/3D0
20114 FCOL=1D0
20115 IF(IABS(I).GE.11) FCOL=3D0
20116 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20117 XRQ=-EI*XW
20118 XLQ=XLQ/XW1
20119 XRQ=XRQ/XW1
20120 XLQ2=XLQ**2
20121 XRQ2=XRQ**2
20122 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
20123 & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
20124 ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
20125 & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
20126 ORP2=ORP**2
20127 OLP2=OLP**2
20128C...u-type quark - d-type squark
20129 IF(MOD(I,2).EQ.0) THEN
20130 FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1)
20131 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
20132C...d-type quark - u-type squark
20133 ELSE
20134 FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
20135 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
20136 ENDIF
20137 FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
20138 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
20139 & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
20140 & (WU2-WT2))*SH2/PROPZ2
20141 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
20142 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
20143 & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
20144 FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
20145 FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
20146 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
20147 NCHN=NCHN+1
20148 ISIG(NCHN,1)=I
20149 ISIG(NCHN,2)=-I
20150 ISIG(NCHN,3)=1
20151 IF(IZID1.EQ.IZID2) THEN
20152 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20153 ELSE
20154 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20155 & WIDS(PYCOMP(KFPR(ISUBSV,1)),2)
20156 NCHN=NCHN+1
20157 ISIG(NCHN,1)=I
20158 ISIG(NCHN,2)=-I
20159 ISIG(NCHN,3)=2
20160 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20161 & WIDS(PYCOMP(KFPR(ISUBSV,1)),3)
20162 ENDIF
20163 1650 CONTINUE
20164
20165 ELSEIF(ISUB.EQ.229) THEN
20166C...q + qbar' -> ~chi0_1 + ~chi+-_1
20167 FACGG1=COMFAC*AEM**2/6D0/XW**2
20168 ZM12=SQM3
20169 ZM22=SQM4
20170 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
20171 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
20172 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20173 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20174 WS2 = SMW(IZID1)*SMZ(IZID2)/SH
20175 RT2I = 1D0/SQRT(2D0)
20176 PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
20177 OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
20178 & ZMIX(IZID2,2)*VMIX(IZID1,1)
20179 OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
20180 & ZMIX(IZID2,2)*UMIX(IZID1,1)
20181 OL2=OL**2
20182 OR2=OR**2
20183 CROSS=2D0*OL*OR
20184 FACST0=UMIX(IZID1,1)
20185 FACSU0=VMIX(IZID1,1)
20186 FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20187 FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20188 FACT0=FACST0**2
20189 FACU0=FACSU0**2
20190 FACTU0=FACSU0*FACST0
20191 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
20192 & + SH2*WS2*OL)*FACST0
20193 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
20194 & + SH2*WS2*OR)*FACSU0
20195 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
20196 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
20197 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
20198 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
20199 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
20200 DO 1670 I=MMIN1,MMAX1
20201 IA=IABS(I)
20202 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670
20203 DO 1660 J=MMIN2,MMAX2
20204 JA=IABS(J)
20205 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660
20206 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660
20207 FCKM=3D0
20208 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20209 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20210 KCHW=2
20211 IF(KCHSUM.LT.0) KCHW=3
20212 NCHN=NCHN+1
20213 ISIG(NCHN,1)=I
20214 ISIG(NCHN,2)=J
20215 ISIG(NCHN,3)=1
20216 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20217 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20218 1660 CONTINUE
20219 1670 CONTINUE
20220 ENDIF
20221
20222 ELSEIF(ISUB.LE.240) THEN
20223 IF(ISUB.EQ.237) THEN
20224C...q + qbar -> gluino + ~chi0_1
20225 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20226 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20227 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
20228 GM2=SQM3
20229 ZM2=SQM4
20230 DO 1680 I=MMINA,MMAXA
20231 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680
20232 EI=KCHG(IABS(I),1)/3D0
20233 IA=IABS(I)
20234 XLQC = -TANW*EI*ZMIX(IZID,1)
20235 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20236 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20237 XLQ2=XLQC**2
20238 XRQ2=XRQC**2
20239 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
20240 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
20241 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
20242 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
20243 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
20244 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20245 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
20246 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
20247 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
20248 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20249 NCHN=NCHN+1
20250 ISIG(NCHN,1)=I
20251 ISIG(NCHN,2)=-I
20252 ISIG(NCHN,3)=1
20253 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
20254 1680 CONTINUE
20255 ENDIF
20256
20257 ELSEIF(ISUB.LE.250) THEN
20258 IF(ISUB.EQ.241) THEN
20259C...q + qbar' -> ~chi+-_1 + gluino
20260 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
20261 GM2=SQM3
20262 ZM2=SQM4
20263 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
20264 FAC0=UMIX(IZID,1)**2
20265 FAC1=VMIX(IZID,1)**2
20266 DO 1700 I=MMIN1,MMAX1
20267 IA=IABS(I)
20268 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700
20269 DO 1690 J=MMIN2,MMAX2
20270 JA=IABS(J)
20271 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690
20272 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690
20273 FCKM=1D0
20274 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20275 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20276 KCHW=2
20277 IF(KCHSUM.LT.0) KCHW=3
20278 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
20279 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
20280 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
20281 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
20282 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
20283 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
20284 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
20285 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
20286 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
20287 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
20288 & SH/(TH-XMU2)/(UH-XMD2))/2D0
20289 NCHN=NCHN+1
20290 ISIG(NCHN,1)=I
20291 ISIG(NCHN,2)=J
20292 ISIG(NCHN,3)=1
20293 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
20294 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20295 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20296 1690 CONTINUE
20297 1700 CONTINUE
20298
20299 ELSEIF(ISUB.EQ.243) THEN
20300C...q + qbar -> gluino + gluino
20301 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20302 XMT=SQM3-TH
20303 XMU=SQM3-UH
20304 DO 1710 I=MMINA,MMAXA
20305 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
20306 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
20307 NCHN=NCHN+1
20308 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
20309 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
20310 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20311 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20312 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20313 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20314 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
20315 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
20316 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20317 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20318 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20319 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20320 ISIG(NCHN,1)=I
20321 ISIG(NCHN,2)=-I
20322 ISIG(NCHN,3)=1
20323C...1/2 for identical particles
20324 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
20325 1710 CONTINUE
20326
20327 ELSEIF(ISUB.EQ.244) THEN
20328C...g + g -> gluino + gluino
20329 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20330 XMT=SQM3-TH
20331 XMU=SQM3-UH
20332 FACQQ1=COMFAC*AS**2*9D0/4D0*(
20333 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
20334 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
20335 FACQQ2=COMFAC*AS**2*9D0/4D0*(
20336 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
20337 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
20338 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
20339 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
20340 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
20341 NCHN=NCHN+1
20342 ISIG(NCHN,1)=21
20343 ISIG(NCHN,2)=21
20344 ISIG(NCHN,3)=1
20345 SIGH(NCHN)=FACQQ1/2D0
20346 NCHN=NCHN+1
20347 ISIG(NCHN,1)=21
20348 ISIG(NCHN,2)=21
20349 ISIG(NCHN,3)=2
20350 SIGH(NCHN)=FACQQ2/2D0
20351 NCHN=NCHN+1
20352 ISIG(NCHN,1)=21
20353 ISIG(NCHN,2)=21
20354 ISIG(NCHN,3)=3
20355 SIGH(NCHN)=FACQQ3/2D0
20356 1720 CONTINUE
20357
20358 ELSEIF(ISUB.EQ.246) THEN
20359C...g + q_j -> ~chi0_1 + ~q_j
20360 FAC0=COMFAC*AS*AEM/6D0/XW
20361 ZM2=SQM4
20362 QM2=SQM3
20363 FACZQ0=FAC0*( (ZM2-TH)/SH +
20364 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20365 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20366 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20367 DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ
20368 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740
20369 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
20370 EI=KCHG(IABS(I),1)/3D0
20371 IA=IABS(I)
20372 XRQZ = -TANW*EI*ZMIX(IZID,1)
20373 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20374 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20375 IF(ILR.EQ.0) THEN
20376 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
20377 ELSE
20378 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
20379 ENDIF
20380 FACZQ=FACZQ0*BS
20381 KCHQ=2
20382 IF(I.LT.0) KCHQ=3
20383 DO 1730 ISDE=1,2
20384 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730
20385 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730
20386 NCHN=NCHN+1
20387 ISIG(NCHN,ISDE)=I
20388 ISIG(NCHN,3-ISDE)=21
20389 ISIG(NCHN,3)=1
20390 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20391 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20392 1730 CONTINUE
20393 1740 CONTINUE
20394 ENDIF
20395
20396 ELSEIF(ISUB.LE.260) THEN
20397 IF(ISUB.EQ.254) THEN
20398C...g + q_j -> ~chi1_1 + ~q_i
20399 FAC0=COMFAC*AS*AEM/12D0/XW
20400 ZM2=SQM4
20401 QM2=SQM3
20402 AU=UMIX(IZID,1)**2
20403 AD=VMIX(IZID,1)**2
20404 FACZQ0=FAC0*( (ZM2-TH)/SH +
20405 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20406 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20407 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
20408 IF(MOD(KFNSQ1,2).EQ.0) THEN
20409 KFNSQ=KFNSQ1-1
20410 KCHW=2
20411 ELSE
20412 KFNSQ=KFNSQ1+1
20413 KCHW=3
20414 ENDIF
20415 DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ
20416 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760
20417 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760
20418 IA=IABS(I)
20419 IF(MOD(IA,2).EQ.0) THEN
20420 FACZQ=FACZQ0*AU
20421 ELSE
20422 FACZQ=FACZQ0*AD
20423 ENDIF
20424 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
20425 KCHQ=2
20426 IF(I.LT.0) KCHQ=3
20427 KCHWQ=KCHW
20428 IF(I.LT.0) KCHWQ=5-KCHW
20429 DO 1750 ISDE=1,2
20430 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750
20431 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750
20432 NCHN=NCHN+1
20433 ISIG(NCHN,ISDE)=I
20434 ISIG(NCHN,3-ISDE)=21
20435 ISIG(NCHN,3)=1
20436 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20437 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
20438 1750 CONTINUE
20439 1760 CONTINUE
20440
20441 ELSEIF(ISUB.EQ.258) THEN
20442C...g + q_j -> gluino + ~q_i
20443 XG2=SQM4
20444 XQ2=SQM3
20445 XMT=XG2-TH
20446 XMU=XG2-UH
20447 XST=XQ2-TH
20448 XSU=XQ2-UH
20449 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
20450 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
20451 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
20452 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
20453 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
20454 & (SH*(UH+XG2)
20455 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
20456 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
20457 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
20458 FACQG1=COMFAC*AS**2*FACQG1/2D0
20459 FACQG2=COMFAC*AS**2*FACQG2/2D0
20460 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20461 DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ
20462 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780
20463 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780
20464 KCHQ=2
20465 IF(I.LT.0) KCHQ=3
20466 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20467 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20468 DO 1770 ISDE=1,2
20469 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770
20470 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770
20471 NCHN=NCHN+1
20472 ISIG(NCHN,ISDE)=I
20473 ISIG(NCHN,3-ISDE)=21
20474 ISIG(NCHN,3)=1
20475 SIGH(NCHN)=FACQG1*FACSEL
20476 NCHN=NCHN+1
20477 ISIG(NCHN,ISDE)=I
20478 ISIG(NCHN,3-ISDE)=21
20479 ISIG(NCHN,3)=2
20480 SIGH(NCHN)=FACQG2*FACSEL
20481 1770 CONTINUE
20482 1780 CONTINUE
20483 ENDIF
20484
20485 ELSEIF(ISUB.LE.270) THEN
20486 IF(ISUB.EQ.261) THEN
20487C...q_i + q_ibar -> ~t_1 + ~t_1bar
20488 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
20489 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20490 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20491 FAC0=AS**2*4D0/9D0
20492 DO 1790 I=MMIN1,MMAX1
20493 IA=IABS(I)
20494 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790
20495 IF(IA.GE.11.AND.IA.LE.18) THEN
20496 EI=KCHG(IA,1)/3D0
20497 EJ=KCHG(KFNSQ,1)/3D0
20498 T3I=SIGN(1D0,EI)/2D0
20499 T3J=SIGN(1D0,EJ)/2D0
20500 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
20501 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
20502 XLF=2D0*(T3I-EI*XW)
20503 XRF=2D0*(-EI*XW)
20504 TAA=0.5D0*(EI*EJ)**2
20505 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20506 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20507 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20508 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20509 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20510 ENDIF
20511 NCHN=NCHN+1
20512 ISIG(NCHN,1)=I
20513 ISIG(NCHN,2)=-I
20514 ISIG(NCHN,3)=1
20515 SIGH(NCHN)=FACQQ1*FAC0
20516 1790 CONTINUE
20517
20518 ELSEIF(ISUB.EQ.263) THEN
20519C...f + fbar -> ~t1 + ~t2bar
20520 DO 1800 I=MMIN1,MMAX1
20521 IA=IABS(I)
20522 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
20523 EI=KCHG(IABS(I),1)/3D0
20524 TT3I=SIGN(1D0,EI)/2D0
20525 EJ=2D0/3D0
20526 TT3J=1D0/2D0
20527 FCOL=1D0
20528C...Color factor for e+ e-
20529 IF(IA.GE.11) FCOL=3D0
20530 XLQ=2D0*(TT3J-EJ*XW)
20531 XRQ=2D0*(-EJ*XW)
20532 XLF=2D0*(TT3I-EI*XW)
20533 XRF=2D0*(-EI*XW)
20534 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
20535 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
20536 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20537C...Factor of 2 for t1 t2bar + t2 t1bar
20538 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
20539 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
20540 NCHN=NCHN+1
20541 ISIG(NCHN,1)=I
20542 ISIG(NCHN,2)=-I
20543 ISIG(NCHN,3)=1
20544 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20545 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20546 NCHN=NCHN+1
20547 ISIG(NCHN,1)=I
20548 ISIG(NCHN,2)=-I
20549 ISIG(NCHN,3)=2
20550 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20551 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20552 1800 CONTINUE
20553
20554 ELSEIF(ISUB.EQ.264) THEN
20555C...g + g -> ~t_1 + ~t_1bar
20556 XSU=SQM3-UH
20557 XST=SQM3-TH
20558 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
20559 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20560 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20561 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20562 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810
20563 NCHN=NCHN+1
20564 ISIG(NCHN,1)=21
20565 ISIG(NCHN,2)=21
20566 ISIG(NCHN,3)=1
20567 SIGH(NCHN)=FACQQ1
20568 NCHN=NCHN+1
20569 ISIG(NCHN,1)=21
20570 ISIG(NCHN,2)=21
20571 ISIG(NCHN,3)=2
20572 SIGH(NCHN)=FACQQ2
20573 1810 CONTINUE
20574 ENDIF
20575
20576 ELSEIF(ISUB.LE.280) THEN
20577 IF(ISUB.EQ.271) THEN
20578C...q + q' -> ~q + ~q' (~g exchange)
20579 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20580 XMT=XMG2-TH
20581 XMU=XMG2-UH
20582 XSU1=SQM3-UH
20583 XSU2=SQM4-UH
20584 XST1=SQM3-TH
20585 XST2=SQM4-TH
20586 IF(ILR.EQ.1) THEN
20587 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
20588 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
20589 FACQQB=0.0D0
20590 ELSE
20591 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
20592 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
20593 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
20594 & XMT/XMU )
20595 ENDIF
20596 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20597 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20598 DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI
20599 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830
20600 IA=IABS(I)
20601 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830
20602 KCHQ=2
20603 IF(I.LT.0) KCHQ=3
20604 DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20605 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820
20606 JA=IABS(J)
20607 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820
20608 IF(I*J.LT.0) GOTO 1820
20609 NCHN=NCHN+1
20610 ISIG(NCHN,1)=I
20611 ISIG(NCHN,2)=J
20612 ISIG(NCHN,3)=1
20613 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20614 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20615 IF(I.EQ.J) THEN
20616 IF(ISUBSV.LE.272) THEN
20617 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20618 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20619 ELSE
20620 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20621 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20622 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20623 ENDIF
20624 NCHN=NCHN+1
20625 ISIG(NCHN,1)=I
20626 ISIG(NCHN,2)=J
20627 ISIG(NCHN,3)=2
20628 IF(ISUBSV.LE.272) THEN
20629 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20630 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20631 ELSE
20632 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20633 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20634 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20635 ENDIF
20636 ENDIF
20637 1820 CONTINUE
20638 1830 CONTINUE
20639
20640 ELSEIF(ISUB.EQ.274) THEN
20641C...q + qbar -> ~q' + ~qbar'
20642 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20643 XMT=XMG2-TH
20644 XMU=XMG2-UH
20645 IF(ILR.EQ.0) THEN
20646 FACQQ1=COMFAC*AS**2*4D0/9D0*(
20647 & (UH*TH-SQM3*SQM4)/XMT**2 )
20648 FACQQB=COMFAC*AS**2*4D0/9D0*(
20649 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2))
20650 FACQQB=FACQQB+FACQQ1
20651 ELSE
20652 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
20653 FACQQB=FACQQ1
20654 ENDIF
20655 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20656 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20657 DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI
20658 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850
20659 IA=IABS(I)
20660 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850
20661 KCHQ=2
20662 IF(I.LT.0) KCHQ=3
20663 DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20664 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840
20665 JA=IABS(J)
20666 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840
20667 IF(I*J.GT.0) GOTO 1840
20668 NCHN=NCHN+1
20669 ISIG(NCHN,1)=I
20670 ISIG(NCHN,2)=J
20671 ISIG(NCHN,3)=1
20672 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20673 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
20674 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
20675 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20676 1840 CONTINUE
20677 1850 CONTINUE
20678
20679 ELSEIF(ISUB.EQ.277) THEN
20680C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
20681C...if i .eq. j covered in 274
20682 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
20683 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20684 FAC0=0D0
20685 DO 1860 I=MMIN1,MMAX1
20686 IA=IABS(I)
20687 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
20688 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
20689 IF(IA.EQ.KFNSQ) GOTO 1860
20690 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
20691 EI=KCHG(IA,1)/3D0
20692 EJ=KCHG(KFNSQ,1)/3D0
20693 T3J=SIGN(0.5D0,EJ)
20694 T3I=SIGN(1D0,EI)/2D0
20695 IF(ILR.EQ.0) THEN
20696 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
20697 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
20698 ELSE
20699 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
20700 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
20701 ENDIF
20702 XLF=2D0*(T3I-EI*XW)
20703 XRF=2D0*(-EI*XW)
20704 IF(ILR.EQ.0) THEN
20705 XRQ=0D0
20706 ELSE
20707 XLQ=0D0
20708 ENDIF
20709 TAA=0.5D0*(EI*EJ)**2
20710 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20711 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20712 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20713 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20714 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20715 ELSEIF(IA.LE.6) THEN
20716 FAC0=AS**2*8D0/9D0/2D0
20717 ENDIF
20718 NCHN=NCHN+1
20719 ISIG(NCHN,1)=I
20720 ISIG(NCHN,2)=-I
20721 ISIG(NCHN,3)=1
20722 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20723 1860 CONTINUE
20724
20725 ELSEIF(ISUB.EQ.279) THEN
20726C...g + g -> ~q_j + ~q_jbar
20727 XSU=SQM3-UH
20728 XST=SQM3-TH
20729C...5=RKF because ~t ~tbar treated separately
20730 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
20731 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20732 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20733 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
20734 NCHN=NCHN+1
20735 ISIG(NCHN,1)=21
20736 ISIG(NCHN,2)=21
20737 ISIG(NCHN,3)=1
20738 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20739 NCHN=NCHN+1
20740 ISIG(NCHN,1)=21
20741 ISIG(NCHN,2)=21
20742 ISIG(NCHN,3)=2
20743 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20744 1870 CONTINUE
20745
20746 ENDIF
20747CMRENNA--
20748 ENDIF
20749
20750C...Multiply with parton distributions
20751 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20752 DO 1880 ICHN=1,NCHN
20753 IF(MINT(45).GE.2) THEN
20754 KFL1=ISIG(ICHN,1)
20755 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20756 ENDIF
20757 IF(MINT(46).GE.2) THEN
20758 KFL2=ISIG(ICHN,2)
20759 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20760 ENDIF
20761 SIGS=SIGS+SIGH(ICHN)
20762 1880 CONTINUE
20763 ENDIF
20764
20765 RETURN
20766 END
20767
20768C*********************************************************************
20769
20770C...PYPDFU
20771C...Gives electron, photon, pi+, neutron, proton and hyperon
20772C...parton distributions according to a few different parametrizations.
20773C...Note that what is coded is x times the probability distribution,
20774C...i.e. xq(x,Q2) etc.
20775
20776 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
20777
20778C...Double precision and integer declarations.
20779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20780 INTEGER PYK,PYCHGE,PYCOMP
20781C...Commonblocks.
20782 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20783 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20784 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20785 COMMON/PYINT1/MINT(400),VINT(400)
20786 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
20787 &XPDIR(-6:6)
20788 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
20789C...Local arrays.
20790 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
20791 &XPPI(-6:6),XPPR(-6:6)
20792
20793C...Interface to PDFLIB.
20794 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
20795 SAVE /W50513/
20796 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
20797 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
20798 CHARACTER*20 PARM(20)
20799 DATA VALUE/20*0D0/,PARM/20*' '/
20800
20801C...Data related to Schuler-Sjostrand photon distributions.
20802 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
20803
20804C...Reset parton distributions.
20805 MINT(92)=0
20806 DO 100 KFL=-25,25
20807 XPQ(KFL)=0D0
20808 100 CONTINUE
20809
20810C...Check x and particle species.
20811 IF(X.LE.0D0.OR.X.GE.1D0) THEN
20812 WRITE(MSTU(11),5000) X
20813 RETURN
20814 ENDIF
20815 KFA=IABS(KF)
20816 IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND.
20817 &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212
20818 &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND.
20819 &KFA.NE.3334.AND.KFA.NE.111) THEN
20820 WRITE(MSTU(11),5100) KF
20821 RETURN
20822 ENDIF
20823
20824C...Electron parton distribution call.
20825 IF(KFA.EQ.11) THEN
20826 CALL PYPDEL(X,Q2,XPEL)
20827 DO 110 KFL=-25,25
20828 XPQ(KFL)=XPEL(KFL)
20829 110 CONTINUE
20830
20831C...Photon parton distribution call (VDM+anomalous).
20832 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
20833 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
20834 CALL PYPDGA(X,Q2,XPGA)
20835 DO 120 KFL=-6,6
20836 XPQ(KFL)=XPGA(KFL)
20837 120 CONTINUE
20838 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
20839 Q2MX=Q2
20840 P2MX=0.36D0
20841 IF(MSTP(55).GE.7) P2MX=4.0D0
20842 IF(MSTP(57).EQ.0) Q2MX=P2MX
20843 CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20844 DO 130 KFL=-6,6
20845 XPQ(KFL)=XPGA(KFL)
20846 130 CONTINUE
20847 VINT(231)=P2MX
20848 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
20849 Q2MX=Q2
20850 P2MX=0.36D0
20851 IF(MSTP(55).GE.11) P2MX=4.0D0
20852 IF(MSTP(57).EQ.0) Q2MX=P2MX
20853 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20854 DO 140 KFL=-6,6
20855 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
20856 140 CONTINUE
20857 VINT(231)=P2MX
20858 ELSEIF(MSTP(56).EQ.2) THEN
20859C...Call PDFLIB parton distributions.
20860 PARM(1)='NPTYPE'
20861 VALUE(1)=3
20862 PARM(2)='NGROUP'
20863 VALUE(2)=MSTP(55)/1000
20864 PARM(3)='NSET'
20865 VALUE(3)=MOD(MSTP(55),1000)
20866 IF(MINT(93).NE.3000000+MSTP(55)) THEN
20867 CALL PDFSET(PARM,VALUE)
20868 MINT(93)=3000000+MSTP(55)
20869 ENDIF
20870 XX=X
20871 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20872 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20873 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20874 VINT(231)=Q2MIN
20875 XPQ(0)=GLU
20876 XPQ(1)=DNV
20877 XPQ(-1)=DNV
20878 XPQ(2)=UPV
20879 XPQ(-2)=UPV
20880 XPQ(3)=STR
20881 XPQ(-3)=STR
20882 XPQ(4)=CHM
20883 XPQ(-4)=CHM
20884 XPQ(5)=BOT
20885 XPQ(-5)=BOT
20886 XPQ(6)=TOP
20887 XPQ(-6)=TOP
20888 ELSE
20889 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
20890 ENDIF
20891
20892C...Pion/gammaVDM parton distribution call.
20893 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
20894 & MINT(109).EQ.2)) THEN
20895 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
20896 & MSTP(55).LE.12) THEN
20897 ISET=1+MOD(MSTP(55)-1,4)
20898 Q2MX=Q2
20899 P2MX=0.36D0
20900 IF(ISET.GE.3) P2MX=4.0D0
20901 IF(MSTP(57).EQ.0) Q2MX=P2MX
20902 CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20903 DO 150 KFL=-6,6
20904 XPQ(KFL)=XPGA(KFL)
20905 150 CONTINUE
20906 VINT(231)=P2MX
20907 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
20908 CALL PYPDPI(X,Q2,XPPI)
20909 DO 160 KFL=-6,6
20910 XPQ(KFL)=XPPI(KFL)
20911 160 CONTINUE
20912 ELSEIF(MSTP(54).EQ.2) THEN
20913C...Call PDFLIB parton distributions.
20914 PARM(1)='NPTYPE'
20915 VALUE(1)=2
20916 PARM(2)='NGROUP'
20917 VALUE(2)=MSTP(53)/1000
20918 PARM(3)='NSET'
20919 VALUE(3)=MOD(MSTP(53),1000)
20920 IF(MINT(93).NE.2000000+MSTP(53)) THEN
20921 CALL PDFSET(PARM,VALUE)
20922 MINT(93)=2000000+MSTP(53)
20923 ENDIF
20924 XX=X
20925 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20926 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20927 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20928 VINT(231)=Q2MIN
20929 XPQ(0)=GLU
20930 XPQ(1)=DSEA
20931 XPQ(-1)=UPV+DSEA
20932 XPQ(2)=UPV+USEA
20933 XPQ(-2)=USEA
20934 XPQ(3)=STR
20935 XPQ(-3)=STR
20936 XPQ(4)=CHM
20937 XPQ(-4)=CHM
20938 XPQ(5)=BOT
20939 XPQ(-5)=BOT
20940 XPQ(6)=TOP
20941 XPQ(-6)=TOP
20942 ELSE
20943 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
20944 ENDIF
20945
20946C...Anomalous photon parton distribution call.
20947 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
20948 Q2MX=Q2
20949 P2MX=PARP(15)**2
20950 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
20951 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
20952 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
20953 IF(MSTP(57).EQ.0) Q2MX=P2MX
20954 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20955 DO 170 KFL=-6,6
20956 XPQ(KFL)=XPGA(KFL)
20957 170 CONTINUE
20958 VINT(231)=P2MX
20959 ELSEIF(MSTP(56).EQ.1) THEN
20960 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
20961 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
20962 IF(MSTP(57).EQ.0) Q2MX=P2MX
20963 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA)
20964 DO 180 KFL=-6,6
20965 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
20966 180 CONTINUE
20967 VINT(231)=P2MX
20968 ELSEIF(MSTP(56).EQ.2) THEN
20969 IF(MSTP(57).EQ.0) Q2MX=P2MX
20970 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20971 DO 190 KFL=-6,6
20972 XPQ(KFL)=XPGA(KFL)
20973 190 CONTINUE
20974 VINT(231)=P2MX
20975 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
20976 IF(MSTP(57).EQ.0) Q2MX=P2MX
20977 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
20978 DO 200 KFL=-6,6
20979 XPQ(KFL)=XPGA(KFL)
20980 200 CONTINUE
20981 VINT(231)=P2MX
20982 ELSE
20983 210 RKF=11D0*PYR(0)
20984 KFR=1
20985 IF(RKF.GT.1D0) KFR=2
20986 IF(RKF.GT.5D0) KFR=3
20987 IF(RKF.GT.6D0) KFR=4
20988 IF(RKF.GT.10D0) KFR=5
20989 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
20990 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
20991 IF(MSTP(57).EQ.0) Q2MX=P2MX
20992 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
20993 DO 220 KFL=-6,6
20994 XPQ(KFL)=XPGA(KFL)
20995 220 CONTINUE
20996 VINT(231)=P2MX
20997 ENDIF
20998
20999C...Proton parton distribution call.
21000 ELSE
21001 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN
21002 CALL PYPDPR(X,Q2,XPPR)
21003 DO 230 KFL=-6,6
21004 XPQ(KFL)=XPPR(KFL)
21005 230 CONTINUE
21006 ELSEIF(MSTP(52).EQ.2) THEN
21007C...Call PDFLIB parton distributions.
21008 PARM(1)='NPTYPE'
21009 VALUE(1)=1
21010 PARM(2)='NGROUP'
21011 VALUE(2)=MSTP(51)/1000
21012 PARM(3)='NSET'
21013 VALUE(3)=MOD(MSTP(51),1000)
21014 IF(MINT(93).NE.1000000+MSTP(51)) THEN
21015 CALL PDFSET(PARM,VALUE)
21016 MINT(93)=1000000+MSTP(51)
21017 ENDIF
21018 XX=X
21019 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21020 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21021 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21022 VINT(231)=Q2MIN
21023 XPQ(0)=GLU
21024 XPQ(1)=DNV+DSEA
21025 XPQ(-1)=DSEA
21026 XPQ(2)=UPV+USEA
21027 XPQ(-2)=USEA
21028 XPQ(3)=STR
21029 XPQ(-3)=STR
21030 XPQ(4)=CHM
21031 XPQ(-4)=CHM
21032 XPQ(5)=BOT
21033 XPQ(-5)=BOT
21034 XPQ(6)=TOP
21035 XPQ(-6)=TOP
21036 ELSE
21037 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
21038 ENDIF
21039 ENDIF
21040
21041C...Isospin average for pi0/gammaVDM.
21042 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
21043 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
21044 XPV=XPQ(2)-XPQ(1)
21045 XPQ(2)=XPQ(1)
21046 XPQ(-2)=XPQ(-1)
21047 ELSE
21048 XPS=0.5D0*(XPQ(1)+XPQ(-2))
21049 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
21050 XPQ(2)=XPS
21051 XPQ(-1)=XPS
21052 ENDIF
21053 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
21054 XPQ(1)=XPQ(1)+0.2D0*XPV
21055 XPQ(-1)=XPQ(-1)+0.2D0*XPV
21056 XPQ(2)=XPQ(2)+0.8D0*XPV
21057 XPQ(-2)=XPQ(-2)+0.8D0*XPV
21058 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
21059 XPQ(3)=XPQ(3)+XPV
21060 XPQ(-3)=XPQ(-3)+XPV
21061 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
21062 XPQ(4)=XPQ(4)+XPV
21063 XPQ(-4)=XPQ(-4)+XPV
21064 IF(MSTP(55).GE.9) THEN
21065 DO 240 KFL=-6,6
21066 XPQ(KFL)=0D0
21067 240 CONTINUE
21068 ENDIF
21069 ELSE
21070 XPQ(1)=XPQ(1)+0.5D0*XPV
21071 XPQ(-1)=XPQ(-1)+0.5D0*XPV
21072 XPQ(2)=XPQ(2)+0.5D0*XPV
21073 XPQ(-2)=XPQ(-2)+0.5D0*XPV
21074 ENDIF
21075
21076C...Rescale for gammaVDM by effective gamma -> rho coupling.
21077 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
21078 DO 250 KFL=-6,6
21079 XPQ(KFL)=VINT(281)*XPQ(KFL)
21080 250 CONTINUE
21081 VINT(232)=VINT(281)*XPV
21082 ENDIF
21083
21084C...Isospin conjugation for neutron.
21085 ELSEIF(KFA.EQ.2112) THEN
21086 XPS=XPQ(1)
21087 XPQ(1)=XPQ(2)
21088 XPQ(2)=XPS
21089 XPS=XPQ(-1)
21090 XPQ(-1)=XPQ(-2)
21091 XPQ(-2)=XPS
21092
21093C...Simple recipes for hyperon (average valence parton distribution).
21094 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
21095 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
21096 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
21097 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
21098 XPQ(1)=XPSEA
21099 XPQ(2)=XPSEA
21100 XPQ(-1)=XPSEA
21101 XPQ(-2)=XPSEA
21102 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
21103 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
21104 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
21105 ENDIF
21106
21107C...Charge conjugation for antiparticle.
21108 IF(KF.LT.0) THEN
21109 DO 260 KFL=1,25
21110 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
21111 XPS=XPQ(KFL)
21112 XPQ(KFL)=XPQ(-KFL)
21113 XPQ(-KFL)=XPS
21114 260 CONTINUE
21115 ENDIF
21116
21117C...Allow gluon also in position 21.
21118 XPQ(21)=XPQ(0)
21119
21120C...Check positivity and reset above maximum allowed flavour.
21121 DO 270 KFL=-25,25
21122 XPQ(KFL)=MAX(0D0,XPQ(KFL))
21123 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
21124 270 CONTINUE
21125
21126C...Formats for error printouts.
21127 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21128 5100 FORMAT(' Error: illegal particle code for parton distribution;',
21129 &' KF =',I5)
21130 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
21131 &3I5)
21132
21133 RETURN
21134 END
21135
21136C*********************************************************************
21137
21138C...PYPDFL
21139C...Gives proton parton distribution at small x and/or Q^2 according to
21140C...correct limiting behaviour.
21141
21142 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
21143
21144C...Double precision and integer declarations.
21145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21146 INTEGER PYK,PYCHGE,PYCOMP
21147C...Commonblocks.
21148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21149 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21150 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21151 COMMON/PYINT1/MINT(400),VINT(400)
21152 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21153C...Local arrays.
21154 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
21155 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
21156
21157C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
21158 MINT(92)=0
21159 KFA=IABS(KF)
21160 IACC=0
21161 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
21162 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
21163 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
21164 IF(IACC.EQ.0) THEN
21165 CALL PYPDFU(KF,X,Q2,XPQ)
21166 RETURN
21167 ENDIF
21168
21169C...Reset. Check x.
21170 DO 100 KFL=-25,25
21171 XPQ(KFL)=0D0
21172 100 CONTINUE
21173 IF(X.LE.0D0.OR.X.GE.1D0) THEN
21174 WRITE(MSTU(11),5000) X
21175 RETURN
21176 ENDIF
21177
21178C...Define valence content.
21179 KFC=KF
21180 NV1=2
21181 NV2=1
21182 IF(KF.EQ.2212) THEN
21183 KFV1=2
21184 KFV2=1
21185 ELSEIF(KF.EQ.-2212) THEN
21186 KFV1=-2
21187 KFV2=-1
21188 ELSEIF(KF.EQ.2112) THEN
21189 KFV1=1
21190 KFV2=2
21191 ELSEIF(KF.EQ.-2112) THEN
21192 KFV1=-1
21193 KFV2=-2
21194 ELSEIF(KF.EQ.211) THEN
21195 NV1=1
21196 KFV1=2
21197 KFV2=-1
21198 ELSEIF(KF.EQ.-211) THEN
21199 NV1=1
21200 KFV1=-2
21201 KFV2=1
21202 ELSEIF(MINT(105).LE.223) THEN
21203 KFV1=1
21204 WTV1=0.2D0
21205 KFV2=2
21206 WTV2=0.8D0
21207 ELSEIF(MINT(105).EQ.333) THEN
21208 KFV1=3
21209 WTV1=1.0D0
21210 KFV2=1
21211 WTV2=0.0D0
21212 ELSEIF(MINT(105).EQ.443) THEN
21213 KFV1=4
21214 WTV1=1.0D0
21215 KFV2=1
21216 WTV2=0.0D0
21217 ENDIF
21218
21219C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
21220 CALL PYPDFU(KFC,X,Q2,XPA)
21221 Q2MN=MAX(3D0,VINT(231))
21222 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
21223 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
21224
21225C...Large Q2 and large x: naive call is enough.
21226 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
21227 DO 110 KFL=-25,25
21228 XPQ(KFL)=XPA(KFL)
21229 110 CONTINUE
21230 MINT(92)=1
21231
21232C...Small Q2 and large x: dampen boundary value.
21233 ELSEIF(X.GT.XMN) THEN
21234
21235C...Evaluate at boundary and define dampening factors.
21236 CALL PYPDFU(KFC,X,Q2MN,XPA)
21237 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
21238 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
21239
21240C...Separate valence and sea parts of parton distribution.
21241 IF(KFA.NE.22) THEN
21242 XFV1=XPA(KFV1)-XPA(-KFV1)
21243 XPA(KFV1)=XPA(-KFV1)
21244 XFV2=XPA(KFV2)-XPA(-KFV2)
21245 XPA(KFV2)=XPA(-KFV2)
21246 ELSE
21247 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21248 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21249 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21250 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21251 ENDIF
21252
21253C...Dampen valence and sea separately. Put back together.
21254 DO 120 KFL=-25,25
21255 XPQ(KFL)=FS*XPA(KFL)
21256 120 CONTINUE
21257 IF(KFA.NE.22) THEN
21258 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
21259 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
21260 ELSE
21261 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
21262 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
21263 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
21264 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
21265 ENDIF
21266 MINT(92)=2
21267
21268C...Large Q2 and small x: interpolate behaviour.
21269 ELSEIF(Q2.GT.Q2MN) THEN
21270
21271C...Evaluate at extremes and define coefficients for interpolation.
21272 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21273 VI232A=VINT(232)
21274 CALL PYPDFU(KFC,X,Q2B,XPB)
21275 VI232B=VINT(232)
21276 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
21277 FVA=(X/XMN)**0.45D0*FLA
21278 FSA=(X/XMN)**(-0.08D0)*FLA
21279 FB=1D0-FLA
21280
21281C...Separate valence and sea parts of parton distribution.
21282 IF(KFA.NE.22) THEN
21283 XFVA1=XPA(KFV1)-XPA(-KFV1)
21284 XPA(KFV1)=XPA(-KFV1)
21285 XFVA2=XPA(KFV2)-XPA(-KFV2)
21286 XPA(KFV2)=XPA(-KFV2)
21287 XFVB1=XPB(KFV1)-XPB(-KFV1)
21288 XPB(KFV1)=XPB(-KFV1)
21289 XFVB2=XPB(KFV2)-XPB(-KFV2)
21290 XPB(KFV2)=XPB(-KFV2)
21291 ELSE
21292 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
21293 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
21294 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
21295 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
21296 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
21297 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
21298 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
21299 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
21300 ENDIF
21301
21302C...Interpolate for valence and sea. Put back together.
21303 DO 130 KFL=-25,25
21304 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
21305 130 CONTINUE
21306 IF(KFA.NE.22) THEN
21307 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
21308 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
21309 ELSE
21310 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21311 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21312 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21313 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21314 ENDIF
21315 MINT(92)=3
21316
21317C...Small Q2 and small x: dampen boundary value and add term.
21318 ELSE
21319
21320C...Evaluate at boundary and define dampening factors.
21321 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21322 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
21323 FA=1D0-FB
21324 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
21325 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
21326 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
21327 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
21328 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
21329 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
21330
21331C...Separate valence and sea parts of parton distribution.
21332 IF(KFA.NE.22) THEN
21333 XFV1=XPA(KFV1)-XPA(-KFV1)
21334 XPA(KFV1)=XPA(-KFV1)
21335 XFV2=XPA(KFV2)-XPA(-KFV2)
21336 XPA(KFV2)=XPA(-KFV2)
21337 ELSE
21338 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21339 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21340 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21341 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21342 ENDIF
21343
21344C...Dampen valence and sea separately. Add constant terms.
21345C...Put back together.
21346 DO 140 KFL=-25,25
21347 XPQ(KFL)=FSA*XPA(KFL)
21348 140 CONTINUE
21349 IF(KFA.NE.22) THEN
21350 DO 150 KFL=-3,3
21351 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
21352 150 CONTINUE
21353 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
21354 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
21355 ELSE
21356 DO 160 KFL=-3,3
21357 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
21358 160 CONTINUE
21359 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21360 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21361 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21362 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21363 ENDIF
21364 XPQ(21)=XPQ(0)
21365 MINT(92)=4
21366 ENDIF
21367
21368C...Format for error printout.
21369 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21370
21371 RETURN
21372 END
21373
21374C*********************************************************************
21375
21376C...PYPDEL
21377C...Gives electron parton distribution.
21378
21379 SUBROUTINE PYPDEL(X,Q2,XPEL)
21380
21381C...Double precision and integer declarations.
21382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21383 INTEGER PYK,PYCHGE,PYCOMP
21384C...Commonblocks.
21385 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21386 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21387 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21388 COMMON/PYINT1/MINT(400),VINT(400)
21389 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21390C...Local arrays.
21391 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
21392
21393C...Interface to PDFLIB.
21394 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
21395 SAVE /W50513/
21396 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
21397 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
21398 CHARACTER*20 PARM(20)
21399 DATA VALUE/20*0D0/,PARM/20*' '/
21400
21401C...Some common constants.
21402 DO 100 KFL=-25,25
21403 XPEL(KFL)=0D0
21404 100 CONTINUE
21405 AEM=PARU(101)
21406 PME=PMAS(11,1)
21407 XL=LOG(MAX(1D-10,X))
21408 X1L=LOG(MAX(1D-10,1D0-X))
21409 HLE=LOG(MAX(3D0,Q2/PME**2))
21410 HBE2=(AEM/PARU(1))*(HLE-1D0)
21411
21412C...Electron inside electron, see R. Kleiss et al., in Z physics at
21413C...LEP 1, CERN 89-08, p. 34
21414 IF(MSTP(59).LE.1) THEN
21415 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
21416 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
21417 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
21418 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
21419 & 4D0*XL/(1D0-X)-5D0-X)
21420 ELSE
21421 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
21422 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
21423 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
21424 ENDIF
21425 IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN
21426 HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0)
21427 ELSEIF(X.GT.0.999999D0) THEN
21428 HEE=0D0
21429 ENDIF
21430 XPEL(11)=X*HEE
21431
21432C...Photon and (transverse) W- inside electron.
21433 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
21434 IF(MSTP(13).LE.1) THEN
21435 HLG=HLE
21436 ELSE
21437 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
21438 ENDIF
21439 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
21440 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
21441 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
21442
21443C...Electron or positron inside photon inside electron.
21444 IF(MSTP(12).EQ.1) THEN
21445 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
21446 & 2D0*X*(1D0+X)*XL)
21447 XPEL(11)=XPEL(11)+XFSEA
21448 XPEL(-11)=XFSEA
21449
21450C...Initialize PDFLIB photon parton distributions.
21451 IF(MSTP(56).EQ.2) THEN
21452 PARM(1)='NPTYPE'
21453 VALUE(1)=3
21454 PARM(2)='NGROUP'
21455 VALUE(2)=MSTP(55)/1000
21456 PARM(3)='NSET'
21457 VALUE(3)=MOD(MSTP(55),1000)
21458 IF(MINT(93).NE.3000000+MSTP(55)) THEN
21459 CALL PDFSET(PARM,VALUE)
21460 MINT(93)=3000000+MSTP(55)
21461 ENDIF
21462 ENDIF
21463
21464C...Quarks and gluons inside photon inside electron:
21465C...numerical convolution required.
21466 DO 110 KFL=0,6
21467 SXP(KFL)=0D0
21468 110 CONTINUE
21469 SUMXPP=0D0
21470 ITER=-1
21471 120 ITER=ITER+1
21472 SUMXP=SUMXPP
21473 NSTP=2**(ITER-1)
21474 IF(ITER.EQ.0) NSTP=2
21475 DO 130 KFL=0,6
21476 SXP(KFL)=0.5D0*SXP(KFL)
21477 130 CONTINUE
21478 WTSTP=0.5D0/NSTP
21479 IF(ITER.EQ.0) WTSTP=0.5D0
21480C...Pick grid of x_{gamma} values logarithmically even.
21481 DO 150 ISTP=1,NSTP
21482 IF(ITER.EQ.0) THEN
21483 XLE=XL*(ISTP-1)
21484 ELSE
21485 XLE=XL*(ISTP-0.5D0)/NSTP
21486 ENDIF
21487 XE=MIN(0.999999D0,EXP(XLE))
21488 XG=MIN(0.999999D0,X/XE)
21489C...Evaluate photon inside electron parton distribution for convolution.
21490 XPGP=1D0+(1D0-XE)**2
21491 IF(MSTP(13).LE.1) THEN
21492 XPGP=XPGP*HLE
21493 ELSE
21494 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
21495 ENDIF
21496C...Evaluate photon parton distributions for convolution.
21497 IF(MSTP(56).EQ.1) THEN
21498 CALL PYPDGA(XG,Q2,XPGA)
21499 DO 140 KFL=0,5
21500 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
21501 140 CONTINUE
21502 ELSEIF(MSTP(56).EQ.2) THEN
21503C...Call PDFLIB parton distributions.
21504 XX=XG
21505 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21506 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21507 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21508 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
21509 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
21510 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
21511 SXP(3)=SXP(3)+WTSTP*XPGP*STR
21512 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
21513 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
21514 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
21515 ENDIF
21516 150 CONTINUE
21517 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
21518 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
21519 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
21520
21521C...Put convolution into output arrays.
21522 FCONV=AEMP*(-XL)
21523 XPEL(0)=FCONV*SXP(0)
21524 DO 160 KFL=1,6
21525 XPEL(KFL)=FCONV*SXP(KFL)
21526 XPEL(-KFL)=XPEL(KFL)
21527 160 CONTINUE
21528 ENDIF
21529
21530 RETURN
21531 END
21532
21533C*********************************************************************
21534
21535C...PYPDGA
21536C...Gives photon parton distribution.
21537
21538 SUBROUTINE PYPDGA(X,Q2,XPGA)
21539
21540C...Double precision and integer declarations.
21541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21542 INTEGER PYK,PYCHGE,PYCOMP
21543C...Commonblocks.
21544 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21545 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21546 COMMON/PYINT1/MINT(400),VINT(400)
21547 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
21548C...Local arrays.
21549 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
21550 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
21551 &DGCS(4,3),DGDS(4,3),DGES(4,3)
21552
21553C...The following data lines are coefficients needed in the
21554C...Drees and Grassie photon parton distribution parametrization.
21555 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
21556 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
21557 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
21558 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
21559 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
21560 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
21561 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
21562 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
21563 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
21564 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
21565 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
21566 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
21567 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
21568 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
21569 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
21570 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
21571 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
21572 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
21573 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
21574 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
21575 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
21576 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
21577 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
21578 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
21579 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
21580 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
21581
21582C...Photon parton distribution from Drees and Grassie.
21583C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
21584 DO 100 KFL=-6,6
21585 XPGA(KFL)=0D0
21586 100 CONTINUE
21587 VINT(231)=1D0
21588 IF(MSTP(57).LE.0) THEN
21589 T=LOG(1D0/0.16D0)
21590 ELSE
21591 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
21592 ENDIF
21593 X1=1D0-X
21594 NF=3
21595 IF(Q2.GT.25D0) NF=4
21596 IF(Q2.GT.300D0) NF=5
21597 NFE=NF-2
21598 AEM=PARU(101)
21599
21600C...Evaluate gluon content.
21601 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
21602 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
21603 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
21604 XPGL=DGA*X**DGB*X1**DGC
21605
21606C...Evaluate up- and down-type quark content.
21607 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
21608 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
21609 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
21610 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
21611 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
21612 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21613 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
21614 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
21615 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
21616 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
21617 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
21618 DGF=9D0
21619 IF(NF.EQ.4) DGF=10D0
21620 IF(NF.EQ.5) DGF=55D0/6D0
21621 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21622 IF(NF.LE.3) THEN
21623 XPQU=(XPQS+9D0*XPQN)/6D0
21624 XPQD=(XPQS-4.5D0*XPQN)/6D0
21625 ELSEIF(NF.EQ.4) THEN
21626 XPQU=(XPQS+6D0*XPQN)/8D0
21627 XPQD=(XPQS-6D0*XPQN)/8D0
21628 ELSE
21629 XPQU=(XPQS+7.5D0*XPQN)/10D0
21630 XPQD=(XPQS-5D0*XPQN)/10D0
21631 ENDIF
21632
21633C...Put into output arrays.
21634 XPGA(0)=AEM*XPGL
21635 XPGA(1)=AEM*XPQD
21636 XPGA(2)=AEM*XPQU
21637 XPGA(3)=AEM*XPQD
21638 IF(NF.GE.4) XPGA(4)=AEM*XPQU
21639 IF(NF.GE.5) XPGA(5)=AEM*XPQD
21640 DO 110 KFL=1,6
21641 XPGA(-KFL)=XPGA(KFL)
21642 110 CONTINUE
21643
21644 RETURN
21645 END
21646
21647C*********************************************************************
21648
21649C...PYGGAM
21650C...Constructs the F2 and parton distributions of the photon
21651C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
21652C...For F2, c and b are included by the Bethe-Heitler formula;
21653C...in the 'MSbar' scheme additionally a Cgamma term is added.
21654C...Contains the SaS sets 1D, 1M, 2D and 2M.
21655C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21656
21657 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
21658
21659C...Double precision and integer declarations.
21660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21661 INTEGER PYK,PYCHGE,PYCOMP
21662C...Commonblocks.
21663 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
21664 &XPDIR(-6:6)
21665 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
21666 SAVE /PYINT8/,/PYINT9/
21667C...Local arrays.
21668 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
21669C...Charm and bottom masses (low to compensate for J/psi etc.).
21670 DATA PMC/1.3D0/, PMB/4.6D0/
21671C...alpha_em and alpha_em/(2*pi).
21672 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
21673C...Lambda value for 4 flavours.
21674 DATA ALAM/0.20D0/
21675C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
21676 DATA FRACU/0.8D0/
21677C...VMD couplings f_V**2/(4*pi).
21678 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
21679C...Masses for rho (=omega) and phi.
21680 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
21681C...Number of points in integration for IP2=1.
21682 DATA NSTEP/100/
21683
21684C...Reset output.
21685 F2GM=0D0
21686 DO 100 KFL=-6,6
21687 XPDFGM(KFL)=0D0
21688 XPVMD(KFL)=0D0
21689 XPANL(KFL)=0D0
21690 XPANH(KFL)=0D0
21691 XPBEH(KFL)=0D0
21692 XPDIR(KFL)=0D0
21693 VXPVMD(KFL)=0D0
21694 VXPANL(KFL)=0D0
21695 VXPANH(KFL)=0D0
21696 VXPDGM(KFL)=0D0
21697 100 CONTINUE
21698
21699C...Set Q0 cut-off parameter as function of set used.
21700 IF(ISET.LE.2) THEN
21701 Q0=0.6D0
21702 ELSE
21703 Q0=2D0
21704 ENDIF
21705 Q02=Q0**2
21706
21707C...Scale choice for off-shell photon; common factors.
21708 Q2A=Q2
21709 FACNOR=1D0
21710 IF(IP2.EQ.1) THEN
21711 P2MX=P2+Q02
21712 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21713 FACNOR=LOG(Q2/Q02)/NSTEP
21714 ELSEIF(IP2.EQ.2) THEN
21715 P2MX=MAX(P2,Q02)
21716 ELSEIF(IP2.EQ.3) THEN
21717 P2MX=P2+Q02
21718 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21719 ELSEIF(IP2.EQ.4) THEN
21720 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21721 & ((Q2+P2)*(Q02+P2)))
21722 ELSEIF(IP2.EQ.5) THEN
21723 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21724 & ((Q2+P2)*(Q02+P2)))
21725 P2MX=Q0*SQRT(P2MXA)
21726 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
21727 ELSEIF(IP2.EQ.6) THEN
21728 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21729 & ((Q2+P2)*(Q02+P2)))
21730 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21731 ELSE
21732 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21733 & ((Q2+P2)*(Q02+P2)))
21734 P2MX=Q0*SQRT(P2MXA)
21735 P2MXB=P2MX
21736 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21737 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
21738 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
21739 ENDIF
21740
21741C...Call VMD parametrization for d quark and use to give rho, omega,
21742C...phi. Note dipole dampening for off-shell photon.
21743 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21744 XFVAL=VXPGA(1)
21745 XPGA(1)=XPGA(2)
21746 XPGA(-1)=XPGA(-2)
21747 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
21748 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
21749 DO 110 KFL=-5,5
21750 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
21751 110 CONTINUE
21752 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
21753 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
21754 XPVMD(3)=XPVMD(3)+FACS*XFVAL
21755 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
21756 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
21757 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
21758 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
21759 VXPVMD(2)=FRACU*FACUD*XFVAL
21760 VXPVMD(3)=FACS*XFVAL
21761 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
21762 VXPVMD(-2)=FRACU*FACUD*XFVAL
21763 VXPVMD(-3)=FACS*XFVAL
21764
21765 IF(IP2.NE.1) THEN
21766C...Anomalous parametrizations for different strategies
21767C...for off-shell photons; except full integration.
21768
21769C...Call anomalous parametrization for d + u + s.
21770 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21771 DO 120 KFL=-5,5
21772 XPANL(KFL)=FACNOR*XPGA(KFL)
21773 VXPANL(KFL)=FACNOR*VXPGA(KFL)
21774 120 CONTINUE
21775
21776C...Call anomalous parametrization for c and b.
21777 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21778 DO 130 KFL=-5,5
21779 XPANH(KFL)=FACNOR*XPGA(KFL)
21780 VXPANH(KFL)=FACNOR*VXPGA(KFL)
21781 130 CONTINUE
21782 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21783 DO 140 KFL=-5,5
21784 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
21785 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
21786 140 CONTINUE
21787
21788 ELSE
21789C...Special option: loop over flavours and integrate over k2.
21790 DO 170 KF=1,5
21791 DO 160 ISTEP=1,NSTEP
21792 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
21793 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
21794 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
21795 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
21796 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
21797 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
21798 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
21799 DO 150 KFL=-5,5
21800 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
21801 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
21802 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
21803 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
21804 150 CONTINUE
21805 160 CONTINUE
21806 170 CONTINUE
21807 ENDIF
21808
21809C...Call Bethe-Heitler term expression for charm and bottom.
21810 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
21811 XPBEH(4)=XPBH
21812 XPBEH(-4)=XPBH
21813 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
21814 XPBEH(5)=XPBH
21815 XPBEH(-5)=XPBH
21816
21817C...For MSbar subtraction call C^gamma term expression for d, u, s.
21818 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
21819 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
21820 DO 180 KFL=-5,5
21821 XPDIR(KFL)=XPGA(KFL)
21822 180 CONTINUE
21823 ENDIF
21824
21825C...Store result in output array.
21826 DO 190 KFL=-5,5
21827 CHSQ=1D0/9D0
21828 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
21829 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
21830 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
21831 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
21832 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
21833 190 CONTINUE
21834
21835 RETURN
21836 END
21837
21838C*********************************************************************
21839
21840C...PYGVMD
21841C...Evaluates the VMD parton distributions of a photon,
21842C...evolved homogeneously from an initial scale P2 to Q2.
21843C...Does not include dipole suppression factor.
21844C...ISET is parton distribution set, see above;
21845C...additionally ISET=0 is used for the evolution of an anomalous photon
21846C...which branched at a scale P2 and then evolved homogeneously to Q2.
21847C...ALAM is the 4-flavour Lambda, which is automatically converted
21848C...to 3- and 5-flavour equivalents as needed.
21849C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21850
21851 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21852
21853C...Double precision and integer declarations.
21854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21855 INTEGER PYK,PYCHGE,PYCOMP
21856C...Local arrays and data.
21857 DIMENSION XPGA(-6:6), VXPGA(-6:6)
21858 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
21859
21860C...Reset output.
21861 DO 100 KFL=-6,6
21862 XPGA(KFL)=0D0
21863 VXPGA(KFL)=0D0
21864 100 CONTINUE
21865 KFA=IABS(KF)
21866
21867C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21868 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
21869 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
21870 P2EFF=MAX(P2,1.2D0*ALAM3**2)
21871 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
21872 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
21873 Q2EFF=MAX(Q2,P2EFF)
21874
21875C...Find number of flavours at lower and upper scale.
21876 NFP=4
21877 IF(P2EFF.LT.PMC**2) NFP=3
21878 IF(P2EFF.GT.PMB**2) NFP=5
21879 NFQ=4
21880 IF(Q2EFF.LT.PMC**2) NFQ=3
21881 IF(Q2EFF.GT.PMB**2) NFQ=5
21882
21883C...Find s as sum of 3-, 4- and 5-flavour parts.
21884 S=0D0
21885 IF(NFP.EQ.3) THEN
21886 Q2DIV=PMC**2
21887 IF(NFQ.EQ.3) Q2DIV=Q2EFF
21888 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
21889 ENDIF
21890 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
21891 P2DIV=P2EFF
21892 IF(NFP.EQ.3) P2DIV=PMC**2
21893 Q2DIV=Q2EFF
21894 IF(NFQ.EQ.5) Q2DIV=PMB**2
21895 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
21896 ENDIF
21897 IF(NFQ.EQ.5) THEN
21898 P2DIV=PMB**2
21899 IF(NFP.EQ.5) P2DIV=P2EFF
21900 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
21901 ENDIF
21902
21903C...Calculate frequent combinations of x and s.
21904 X1=1D0-X
21905 XL=-LOG(X)
21906 S2=S**2
21907 S3=S**3
21908 S4=S**4
21909
21910C...Evaluate homogeneous anomalous parton distributions below or
21911C...above threshold.
21912 IF(ISET.EQ.0) THEN
21913 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21914 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21915 XVAL = X * 1.5D0 * (X**2+X1**2)
21916 XGLU = 0D0
21917 XSEA = 0D0
21918 ELSE
21919 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
21920 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
21921 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
21922 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
21923 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
21924 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
21925 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
21926 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
21927 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
21928 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
21929 & (2D0*X-1D0)*X*XL**2)
21930 ENDIF
21931
21932C...Evaluate set 1D parton distributions below or above threshold.
21933 ELSEIF(ISET.EQ.1) THEN
21934 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21935 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21936 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
21937 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
21938 XSEA = 0.100D0 * X1**3.76D0
21939 ELSE
21940 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
21941 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
21942 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
21943 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
21944 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
21945 & X**0.40D0 * X1**(1.76D0+3D0*S)
21946 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
21947 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
21948 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
21949 XSEA0 = 0.100D0 * X1**3.76D0
21950 ENDIF
21951
21952C...Evaluate set 1M parton distributions below or above threshold.
21953 ELSEIF(ISET.EQ.2) THEN
21954 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21955 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21956 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
21957 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
21958 XSEA = 0D0
21959 ELSE
21960 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
21961 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
21962 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
21963 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
21964 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
21965 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
21966 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
21967 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
21968 & XL**(2.8D0*S)
21969 XSEA0 = 0D0
21970 ENDIF
21971
21972C...Evaluate set 2D parton distributions below or above threshold.
21973 ELSEIF(ISET.EQ.3) THEN
21974 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21975 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21976 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
21977 XGLU = 1.925D0 * X1**2
21978 XSEA = 0.242D0 * X1**4
21979 ELSE
21980 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
21981 & X**(0.46D0+0.25D0*S) *
21982 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
21983 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
21984 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
21985 & EXP(-18.67D0*S) *
21986 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
21987 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
21988 & XL**(9.3D0*S/(1D0+1.7D0*S))
21989 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
21990 & (1D0-0.607D0*S+21.95D0*S2) *
21991 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
21992 XSEA0 = 0.242D0 * X1**4
21993 ENDIF
21994
21995C...Evaluate set 2M parton distributions below or above threshold.
21996 ELSEIF(ISET.EQ.4) THEN
21997 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21998 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21999 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
22000 XGLU = 1.808D0 * X1**2
22001 XSEA = 0.209D0 * X1**4
22002 ELSE
22003 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
22004 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
22005 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
22006 & XL**(5.15D0*S/(1D0+2D0*S)) +
22007 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
22008 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
22009 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
22010 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
22011 & XL**(10.9D0*S/(1D0+2.5D0*S))
22012 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
22013 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
22014 & X1**(4D0+S) * XL**(0.45D0*S)
22015 XSEA0 = 0.209D0 * X1**4
22016 ENDIF
22017 ENDIF
22018
22019C...Threshold factors for c and b sea.
22020 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22021 XCHM=0D0
22022 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22023 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22024 IF(ISET.EQ.0) THEN
22025 XCHM=XSEA*(1D0-(SCH/SLL)**2)
22026 ELSE
22027 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
22028 ENDIF
22029 ENDIF
22030 XBOT=0D0
22031 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22032 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22033 IF(ISET.EQ.0) THEN
22034 XBOT=XSEA*(1D0-(SBT/SLL)**2)
22035 ELSE
22036 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
22037 ENDIF
22038 ENDIF
22039
22040C...Fill parton distributions.
22041 XPGA(0)=XGLU
22042 XPGA(1)=XSEA
22043 XPGA(2)=XSEA
22044 XPGA(3)=XSEA
22045 XPGA(4)=XCHM
22046 XPGA(5)=XBOT
22047 XPGA(KFA)=XPGA(KFA)+XVAL
22048 DO 110 KFL=1,5
22049 XPGA(-KFL)=XPGA(KFL)
22050 110 CONTINUE
22051 VXPGA(KFA)=XVAL
22052 VXPGA(-KFA)=XVAL
22053
22054 RETURN
22055 END
22056
22057C*********************************************************************
22058
22059C...PYGANO
22060C...Evaluates the parton distributions of the anomalous photon,
22061C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
22062C...KF=0 gives the sum over (up to) 5 flavours,
22063C...KF<0 limits to flavours up to abs(KF),
22064C...KF>0 is for flavour KF only.
22065C...ALAM is the 4-flavour Lambda, which is automatically converted
22066C...to 3- and 5-flavour equivalents as needed.
22067C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22068
22069 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
22070
22071C...Double precision and integer declarations.
22072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22073 INTEGER PYK,PYCHGE,PYCOMP
22074C...Local arrays and data.
22075 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
22076 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
22077
22078C...Reset output.
22079 DO 100 KFL=-6,6
22080 XPGA(KFL)=0D0
22081 VXPGA(KFL)=0D0
22082 100 CONTINUE
22083 IF(Q2.LE.P2) RETURN
22084 KFA=IABS(KF)
22085
22086C...Calculate Lambda; protect against unphysical Q2 and P2 input.
22087 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
22088 ALAMSQ(4)=ALAM**2
22089 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
22090 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
22091 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
22092 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
22093 Q2EFF=MAX(Q2,P2EFF)
22094 XL=-LOG(X)
22095
22096C...Find number of flavours at lower and upper scale.
22097 NFP=4
22098 IF(P2EFF.LT.PMC**2) NFP=3
22099 IF(P2EFF.GT.PMB**2) NFP=5
22100 NFQ=4
22101 IF(Q2EFF.LT.PMC**2) NFQ=3
22102 IF(Q2EFF.GT.PMB**2) NFQ=5
22103
22104C...Define range of flavour loop.
22105 IF(KF.EQ.0) THEN
22106 KFLMN=1
22107 KFLMX=5
22108 ELSEIF(KF.LT.0) THEN
22109 KFLMN=1
22110 KFLMX=KFA
22111 ELSE
22112 KFLMN=KFA
22113 KFLMX=KFA
22114 ENDIF
22115
22116C...Loop over flavours the photon can branch into.
22117 DO 110 KFL=KFLMN,KFLMX
22118
22119C...Light flavours: calculate t range and (approximate) s range.
22120 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
22121 TDIFF=LOG(Q2EFF/P2EFF)
22122 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22123 & LOG(P2EFF/ALAMSQ(NFQ)))
22124 IF(NFQ.GT.NFP) THEN
22125 Q2DIV=PMB**2
22126 IF(NFQ.EQ.4) Q2DIV=PMC**2
22127 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22128 & LOG(P2EFF/ALAMSQ(NFQ)))
22129 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22130 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22131 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22132 ENDIF
22133 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
22134 Q2DIV=PMC**2
22135 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
22136 & LOG(P2EFF/ALAMSQ(4)))
22137 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
22138 & LOG(P2EFF/ALAMSQ(3)))
22139 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
22140 ENDIF
22141
22142C...u and s quark do not need a separate treatment when d has been done.
22143 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
22144
22145C...Charm: as above, but only include range above c threshold.
22146 ELSEIF(KFL.EQ.4) THEN
22147 IF(Q2.LE.PMC**2) GOTO 110
22148 P2EFF=MAX(P2EFF,PMC**2)
22149 Q2EFF=MAX(Q2EFF,P2EFF)
22150 TDIFF=LOG(Q2EFF/P2EFF)
22151 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22152 & LOG(P2EFF/ALAMSQ(NFQ)))
22153 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
22154 Q2DIV=PMB**2
22155 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22156 & LOG(P2EFF/ALAMSQ(NFQ)))
22157 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22158 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22159 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22160 ENDIF
22161
22162C...Bottom: as above, but only include range above b threshold.
22163 ELSEIF(KFL.EQ.5) THEN
22164 IF(Q2.LE.PMB**2) GOTO 110
22165 P2EFF=MAX(P2EFF,PMB**2)
22166 Q2EFF=MAX(Q2,P2EFF)
22167 TDIFF=LOG(Q2EFF/P2EFF)
22168 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22169 & LOG(P2EFF/ALAMSQ(NFQ)))
22170 ENDIF
22171
22172C...Evaluate flavour-dependent prefactor (charge^2 etc.).
22173 CHSQ=1D0/9D0
22174 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
22175 FAC=AEM2PI*2D0*CHSQ*TDIFF
22176
22177C...Evaluate parton distributions (normalized to unit momentum sum).
22178 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
22179 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
22180 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
22181 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
22182 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
22183 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
22184 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
22185 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
22186 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
22187 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
22188 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
22189 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
22190
22191C...Threshold factors for c and b sea.
22192 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22193 XCHM=0D0
22194 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22195 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22196 XCHM=XSEA*(1D0-(SCH/SLL)**3)
22197 ENDIF
22198 XBOT=0D0
22199 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22200 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22201 XBOT=XSEA*(1D0-(SBT/SLL)**3)
22202 ENDIF
22203 ENDIF
22204
22205C...Add contribution of each valence flavour.
22206 XPGA(0)=XPGA(0)+FAC*XGLU
22207 XPGA(1)=XPGA(1)+FAC*XSEA
22208 XPGA(2)=XPGA(2)+FAC*XSEA
22209 XPGA(3)=XPGA(3)+FAC*XSEA
22210 XPGA(4)=XPGA(4)+FAC*XCHM
22211 XPGA(5)=XPGA(5)+FAC*XBOT
22212 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
22213 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
22214 110 CONTINUE
22215 DO 120 KFL=1,5
22216 XPGA(-KFL)=XPGA(KFL)
22217 VXPGA(-KFL)=VXPGA(KFL)
22218 120 CONTINUE
22219
22220 RETURN
22221 END
22222
22223C*********************************************************************
22224
22225C...PYGBEH
22226C...Evaluates the Bethe-Heitler cross section for heavy flavour
22227C...production.
22228C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22229
22230 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
22231C...Double precision and integer declarations.
22232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22233 INTEGER PYK,PYCHGE,PYCOMP
22234
22235C...Local data.
22236 DATA AEM2PI/0.0011614D0/
22237
22238C...Reset output.
22239 XPBH=0D0
22240 SIGBH=0D0
22241
22242C...Check kinematics limits.
22243 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
22244 W2=Q2*(1D0-X)/X-P2
22245 BETA2=1D0-4D0*PM2/W2
22246 IF(BETA2.LT.1D-10) RETURN
22247 BETA=SQRT(BETA2)
22248 RMQ=4D0*PM2/Q2
22249
22250C...Simple case: P2 = 0.
22251 IF(P2.LT.1D-4) THEN
22252 IF(BETA.LT.0.99D0) THEN
22253 XBL=LOG((1D0+BETA)/(1D0-BETA))
22254 ELSE
22255 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
22256 ENDIF
22257 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
22258 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
22259
22260C...Complicated case: P2 > 0, based on approximation of
22261C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
22262 ELSE
22263 RPQ=1D0-4D0*X**2*P2/Q2
22264 IF(RPQ.GT.1D-10) THEN
22265 RPBE=SQRT(RPQ*BETA2)
22266 IF(RPBE.LT.0.99D0) THEN
22267 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
22268 XBI=2D0*RPBE/(1D0-RPBE**2)
22269 ELSE
22270 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
22271 XBL=LOG((1D0+RPBE)**2/RPBESN)
22272 XBI=2D0*RPBE/RPBESN
22273 ENDIF
22274 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
22275 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
22276 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
22277 ENDIF
22278 ENDIF
22279
22280C...Multiply by charge-squared etc. to get parton distribution.
22281 CHSQ=1D0/9D0
22282 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
22283 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
22284
22285 RETURN
22286 END
22287
22288C*********************************************************************
22289
22290C...PYGDIR
22291C...Evaluates the direct contribution, i.e. the C^gamma term,
22292C...as needed in MSbar parametrizations.
22293C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22294
22295 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
22296
22297C...Double precision and integer declarations.
22298 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22299 INTEGER PYK,PYCHGE,PYCOMP
22300C...Local array and data.
22301 DIMENSION XPGA(-6:6)
22302 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
22303
22304C...Reset output.
22305 DO 100 KFL=-6,6
22306 XPGA(KFL)=0D0
22307 100 CONTINUE
22308
22309C...Evaluate common x-dependent expression.
22310 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
22311 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
22312
22313C...d, u, s part by simple charge factor.
22314 XPGA(1)=(1D0/9D0)*CGAM
22315 XPGA(2)=(4D0/9D0)*CGAM
22316 XPGA(3)=(1D0/9D0)*CGAM
22317
22318C...Also fill for antiquarks.
22319 DO 110 KF=1,5
22320 XPGA(-KF)=XPGA(KF)
22321 110 CONTINUE
22322
22323 RETURN
22324 END
22325
22326C*********************************************************************
22327
22328C...PYPDPI
22329C...Gives pi+ parton distribution according to two different
22330C...parametrizations.
22331
22332 SUBROUTINE PYPDPI(X,Q2,XPPI)
22333
22334C...Double precision and integer declarations.
22335 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22336 INTEGER PYK,PYCHGE,PYCOMP
22337C...Commonblocks.
22338 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22339 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22340 COMMON/PYINT1/MINT(400),VINT(400)
22341 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
22342C...Local arrays.
22343 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
22344
22345C...The following data lines are coefficients needed in the
22346C...Owens pion parton distribution parametrizations, see below.
22347C...Expansion coefficients for up and down valence quark distributions.
22348 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
22349 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22350 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22351 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22352 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
22353 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22354 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22355 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22356C...Expansion coefficients for gluon distribution.
22357 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
22358 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
22359 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
22360 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
22361 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
22362 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
22363 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
22364 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
22365C...Expansion coefficients for (up+down+strange) quark sea distribution.
22366 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
22367 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22368 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
22369 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
22370 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
22371 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22372 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
22373 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
22374C...Expansion coefficients for charm quark sea distribution.
22375 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
22376 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
22377 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
22378 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
22379 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
22380 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
22381 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
22382 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
22383
22384C...Euler's beta function, requires ordinary Gamma function
22385 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
22386
22387C...Reset output array.
22388 DO 100 KFL=-6,6
22389 XPPI(KFL)=0D0
22390 100 CONTINUE
22391
22392 IF(MSTP(53).LE.2) THEN
22393C...Pion parton distributions from Owens.
22394C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
22395
22396C...Determine set, Lambda and s expansion variable.
22397 NSET=MSTP(53)
22398 IF(NSET.EQ.1) ALAM=0.2D0
22399 IF(NSET.EQ.2) ALAM=0.4D0
22400 VINT(231)=4D0
22401 IF(MSTP(57).LE.0) THEN
22402 SD=0D0
22403 ELSE
22404 Q2IN=MIN(2D3,MAX(4D0,Q2))
22405 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
22406 ENDIF
22407
22408C...Calculate parton distributions.
22409 DO 120 KFL=1,4
22410 DO 110 IS=1,5
22411 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
22412 & COW(3,IS,KFL,NSET)*SD**2
22413 110 CONTINUE
22414 IF(KFL.EQ.1) THEN
22415 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
22416 ELSE
22417 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
22418 & TS(5)*X**2)
22419 ENDIF
22420 120 CONTINUE
22421
22422C...Put into output array.
22423 XPPI(0)=XQ(2)
22424 XPPI(1)=XQ(3)/6D0
22425 XPPI(2)=XQ(1)+XQ(3)/6D0
22426 XPPI(3)=XQ(3)/6D0
22427 XPPI(4)=XQ(4)
22428 XPPI(-1)=XQ(1)+XQ(3)/6D0
22429 XPPI(-2)=XQ(3)/6D0
22430 XPPI(-3)=XQ(3)/6D0
22431 XPPI(-4)=XQ(4)
22432
22433C...Leading order pion parton distributions from Gluck, Reya and Vogt.
22434C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
22435C...10^-5 < x < 1.
22436 ELSE
22437
22438C...Determine s expansion variable and some x expressions.
22439 VINT(231)=0.25D0
22440 IF(MSTP(57).LE.0) THEN
22441 SD=0D0
22442 ELSE
22443 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
22444 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
22445 ENDIF
22446 SD2=SD**2
22447 XL=-LOG(X)
22448 XS=SQRT(X)
22449
22450C...Evaluate valence, gluon and sea distributions.
22451 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
22452 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
22453 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
22454 & SD-0.175D0*SD2)+
22455 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
22456 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
22457 & XL)))*
22458 & (1D0-X)**(0.390D0+1.053D0*SD)
22459 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
22460 & X)**3.359D0*
22461 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
22462 & XL))/
22463 & XL**(2.538D0-0.763D0*SD)
22464 IF(SD.LE.0.888D0) THEN
22465 XFCHM=0D0
22466 ELSE
22467 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
22468 & 0.771D0*SD)*
22469 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
22470 & XL))
22471 ENDIF
22472 IF(SD.LE.1.351D0) THEN
22473 XFBOT=0D0
22474 ELSE
22475 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
22476 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
22477 & XL))
22478 ENDIF
22479
22480C...Put into output array.
22481 XPPI(0)=XFGLU
22482 XPPI(1)=XFSEA
22483 XPPI(2)=XFSEA
22484 XPPI(3)=XFSEA
22485 XPPI(4)=XFCHM
22486 XPPI(5)=XFBOT
22487 DO 130 KFL=1,5
22488 XPPI(-KFL)=XPPI(KFL)
22489 130 CONTINUE
22490 XPPI(2)=XPPI(2)+XFVAL
22491 XPPI(-1)=XPPI(-1)+XFVAL
22492 ENDIF
22493
22494 RETURN
22495 END
22496
22497C*********************************************************************
22498
22499C...PYPDPR
22500C...Gives proton parton distributions according to a few different
22501C...parametrizations.
22502
22503 SUBROUTINE PYPDPR(X,Q2,XPPR)
22504
22505C...Double precision and integer declarations.
22506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22507 INTEGER PYK,PYCHGE,PYCOMP
22508C...Commonblocks.
22509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22512 COMMON/PYINT1/MINT(400),VINT(400)
22513 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
22514C...Arrays and data.
22515 DIMENSION XPPR(-6:6),Q2MIN(6)
22516 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/
22517
22518C...Reset output array.
22519 DO 100 KFL=-6,6
22520 XPPR(KFL)=0D0
22521 100 CONTINUE
22522
22523C...Common preliminaries.
22524 NSET=MAX(1,MIN(6,MSTP(51)))
22525 VINT(231)=Q2MIN(NSET)
22526 IF(MSTP(57).EQ.0) THEN
22527 Q2L=Q2MIN(NSET)
22528 ELSE
22529 Q2L=MAX(Q2MIN(NSET),Q2)
22530 ENDIF
22531
22532 IF(NSET.GE.1.AND.NSET.LE.3) THEN
22533C...Interface to the CTEQ 3 parton distributions.
22534 QRT=SQRT(MAX(1D0,Q2L))
22535
22536C...Loop over flavours.
22537 DO 110 I=-6,6
22538 IF(I.LE.0) THEN
22539 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
22540 ELSEIF(I.LE.2) THEN
22541 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
22542 ELSE
22543 XPPR(I)=XPPR(-I)
22544 ENDIF
22545 110 CONTINUE
22546
22547 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
22548C...Interface to the GRV 94 distributions.
22549 IF(NSET.EQ.4) THEN
22550 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22551 ELSEIF(NSET.EQ.5) THEN
22552 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22553 ELSE
22554 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22555 ENDIF
22556
22557C...Put into output array.
22558 XPPR(0)=GL
22559 XPPR(-1)=0.5D0*(UDB+DEL)
22560 XPPR(-2)=0.5D0*(UDB-DEL)
22561 XPPR(-3)=SB
22562 XPPR(-4)=CHM
22563 XPPR(-5)=BOT
22564 XPPR(1)=DV+XPPR(-1)
22565 XPPR(2)=UV+XPPR(-2)
22566 XPPR(3)=SB
22567 XPPR(4)=CHM
22568 XPPR(5)=BOT
22569
22570 ENDIF
22571
22572 RETURN
22573 END
22574
22575C*********************************************************************
22576
22577C...PYCTEQ
22578C...Gives the CTEQ 3 parton distribution function sets in
22579C...parametrized form, of October 24, 1994.
22580C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
22581C...J. Qiu, W.K. Tung and H. Weerts.
22582
22583 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
22584
22585C...Double precision declaration.
22586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22587
22588C...Data on Lambda values of fits, minimum Q and quark masses.
22589 DIMENSION ALM(3), QMS(4:6)
22590 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
22591 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
22592
22593C....Check flavour thresholds. Set up QI for SB.
22594 IP = IABS(IPRT)
22595 IF(IP .GE. 4) THEN
22596 IF(Q .LE. QMS(IP)) THEN
22597 PYCTEQ = 0D0
22598 RETURN
22599 ENDIF
22600 QI = QMS(IP)
22601 ELSE
22602 QI = QMN
22603 ENDIF
22604
22605C...Use "standard lambda" of parametrization program for expansion.
22606 ALAM = ALM (ISET)
22607 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
22608 SB = LOG (SBL)
22609 SB2 = SB*SB
22610 SB3 = SB2*SB
22611
22612C...Expansion for CTEQ3L.
22613 IF(ISET .EQ. 1) THEN
22614 IF(IPRT .EQ. 2) THEN
22615 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
22616 & 0.3171D+00*SB3)
22617 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
22618 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
22619 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
22620 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
22621 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
22622 ELSEIF(IPRT .EQ. 1) THEN
22623 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
22624 & 0.7728D+00*SB3)
22625 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
22626 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
22627 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
22628 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
22629 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
22630 ELSEIF(IPRT .EQ. 0) THEN
22631 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
22632 & 0.5343D+00*SB3)
22633 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
22634 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
22635 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
22636 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
22637 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
22638 ELSEIF(IPRT .EQ. -1) THEN
22639 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
22640 & 0.2031D+01*SB3)
22641 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
22642 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
22643 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
22644 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
22645 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
22646 ELSEIF(IPRT .EQ. -2) THEN
22647 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
22648 & 0.9872D-01*SB3)
22649 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
22650 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
22651 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
22652 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
22653 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
22654 ELSEIF(IPRT .EQ. -3) THEN
22655 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
22656 & 0.8390D+00*SB3)
22657 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
22658 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
22659 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
22660 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
22661 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
22662 ELSEIF(IPRT .EQ. -4) THEN
22663 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
22664 & 0.1651D-01*SB2)
22665 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
22666 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
22667 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
22668 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
22669 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
22670 ELSEIF(IPRT .EQ. -5) THEN
22671 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
22672 & 0.3702D+01*SB2)
22673 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
22674 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
22675 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
22676 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
22677 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
22678 ELSEIF(IPRT .EQ. -6) THEN
22679 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
22680 & 0.6943D+00*SB2)
22681 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
22682 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
22683 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
22684 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
22685 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
22686 ENDIF
22687
22688C...Expansion for CTEQ3M.
22689 ELSEIF(ISET .EQ. 2) THEN
22690 IF(IPRT .EQ. 2) THEN
22691 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
22692 & 0.2935D+00*SB3)
22693 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
22694 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
22695 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
22696 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
22697 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
22698 ELSEIF(IPRT .EQ. 1) THEN
22699 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
22700 & 0.4305D-01*SB3)
22701 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
22702 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
22703 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
22704 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
22705 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
22706 ELSEIF(IPRT .EQ. 0) THEN
22707 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
22708 & 0.1037D-01*SB3)
22709 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
22710 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
22711 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
22712 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
22713 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
22714 ELSEIF(IPRT .EQ. -1) THEN
22715 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
22716 & 0.1602D+01*SB3)
22717 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
22718 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
22719 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
22720 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
22721 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
22722 ELSEIF(IPRT .EQ. -2) THEN
22723 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
22724 & 0.2496D+00*SB3)
22725 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
22726 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
22727 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
22728 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
22729 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
22730 ELSEIF(IPRT .EQ. -3) THEN
22731 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
22732 & 0.1936D+01*SB3)
22733 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
22734 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
22735 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
22736 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
22737 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
22738 ELSEIF(IPRT .EQ. -4) THEN
22739 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
22740 & 0.5348D+00*SB2)
22741 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
22742 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
22743 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
22744 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
22745 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
22746 ELSEIF(IPRT .EQ. -5) THEN
22747 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
22748 & 0.1569D+01*SB2)
22749 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
22750 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
22751 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
22752 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
22753 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
22754 ELSEIF(IPRT .EQ. -6) THEN
22755 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
22756 & 0.8838D+01*SB2)
22757 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
22758 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
22759 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
22760 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
22761 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
22762 ENDIF
22763
22764C...Expansion for CTEQ3D.
22765 ELSEIF(ISET .EQ. 3) THEN
22766 IF(IPRT .EQ. 2) THEN
22767 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
22768 & 0.2902D+00*SB3)
22769 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
22770 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
22771 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
22772 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
22773 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
22774 ELSEIF(IPRT .EQ. 1) THEN
22775 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
22776 & 0.7257D+00*SB3)
22777 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
22778 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
22779 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
22780 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
22781 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
22782 ELSEIF(IPRT .EQ. 0) THEN
22783 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
22784 & 0.2734D-04*SB3)
22785 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
22786 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
22787 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
22788 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
22789 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
22790 ELSEIF(IPRT .EQ. -1) THEN
22791 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
22792 & 0.1671D+01*SB3)
22793 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
22794 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
22795 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
22796 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
22797 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
22798 ELSEIF(IPRT .EQ. -2) THEN
22799 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
22800 & 0.2223D+00*SB3)
22801 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
22802 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
22803 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
22804 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
22805 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
22806 ELSEIF(IPRT .EQ. -3) THEN
22807 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
22808 & 0.1937D+01*SB3)
22809 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
22810 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
22811 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
22812 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
22813 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
22814 ELSEIF(IPRT .EQ. -4) THEN
22815 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
22816 & 0.5137D+00*SB2)
22817 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
22818 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
22819 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
22820 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
22821 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
22822 ELSEIF(IPRT .EQ. -5) THEN
22823 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
22824 & 0.2143D+01*SB2)
22825 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
22826 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
22827 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
22828 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
22829 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
22830 ELSEIF(IPRT .EQ. -6) THEN
22831 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
22832 & 0.9998D+01*SB2)
22833 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
22834 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
22835 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
22836 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
22837 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
22838 ENDIF
22839 ENDIF
22840
22841C...Calculation of x * f(x, Q).
22842 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
22843 & *(LOG(1D0+1D0/X))**A5 )
22844
22845 RETURN
22846 END
22847
22848C*********************************************************************
22849
22850C...PYGRVL
22851C...Gives the GRV 94 L (leading order) parton distribution function set
22852C...in parametrized form.
22853C...Authors: M. Glueck, E. Reya and A. Vogt.
22854
22855 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22856
22857C...Double precision declaration.
22858 IMPLICIT DOUBLE PRECISION (A - Z)
22859
22860C...Common expressions.
22861 MU2 = 0.23D0
22862 LAM2 = 0.2322D0 * 0.2322D0
22863 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22864 DS = SQRT (S)
22865 S2 = S * S
22866 S3 = S2 * S
22867
22868C...uv :
22869 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
22870 AKU = 0.590D0 - 0.024D0 * S
22871 BKU = 0.131D0 + 0.063D0 * S
22872 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
22873 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
22874 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
22875 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
22876 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22877
22878C...dv :
22879 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
22880 AKD = 0.376D0
22881 BKD = 0.486D0 + 0.062D0 * S
22882 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
22883 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
22884 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
22885 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
22886 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
22887
22888C...del :
22889 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
22890 AKE = 0.409D0 - 0.005D0 * S
22891 BKE = 0.799D0 + 0.071D0 * S
22892 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
22893 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
22894 CE = 0.0D0
22895 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
22896 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
22897
22898C...udb :
22899 ALX = 1.451D0
22900 BEX = 0.271D0
22901 AKX = 0.410D0 - 0.232D0 * S
22902 BKX = 0.534D0 - 0.457D0 * S
22903 AGX = 0.890D0 - 0.140D0 * S
22904 BGX = -0.981D0
22905 CX = 0.320D0 + 0.683D0 * S
22906 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
22907 EX = 4.119D0 + 1.713D0 * S
22908 ESX = 0.682D0 + 2.978D0 * S
22909 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
22910 & DX, EX, ESX)
22911
22912C...sb :
22913 STS = 0D0
22914 ALS = 0.914D0
22915 BES = 0.577D0
22916 AKS = 1.798D0 - 0.596D0 * S
22917 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
22918 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
22919 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
22920 EST = 3.981D0 + 1.638D0 * S
22921 ESS = 6.402D0
22922 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
22923
22924C...cb :
22925 STC = 0.888D0
22926 ALC = 1.01D0
22927 BEC = 0.37D0
22928 AKC = 0D0
22929 AC = 0D0
22930 BC = 4.24D0 - 0.804D0 * S
22931 DCT = 3.46D0 - 1.076D0 * S
22932 ECT = 4.61D0 + 1.49D0 * S
22933 ESC = 2.555D0 + 1.961D0 * S
22934 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
22935
22936C...bb :
22937 STB = 1.351D0
22938 ALB = 1.00D0
22939 BEB = 0.51D0
22940 AKB = 0D0
22941 AB = 0D0
22942 BB = 1.848D0
22943 DBT = 2.929D0 + 1.396D0 * S
22944 EBT = 4.71D0 + 1.514D0 * S
22945 ESB = 4.02D0 + 1.239D0 * S
22946 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
22947
22948C...gl :
22949 ALG = 0.524D0
22950 BEG = 1.088D0
22951 AKG = 1.742D0 - 0.930D0 * S
22952 BKG = - 0.399D0 * S2
22953 AG = 7.486D0 - 2.185D0 * S
22954 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
22955 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
22956 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
22957 EG = 0.807D0 + 2.005D0 * S
22958 ESG = 3.841D0 + 0.316D0 * S
22959 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
22960 & DG, EG, ESG)
22961
22962 RETURN
22963 END
22964
22965C*********************************************************************
22966
22967C...PYGRVM
22968C...Gives the GRV 94 M (MSbar) parton distribution function set
22969C...in parametrized form.
22970C...Authors: M. Glueck, E. Reya and A. Vogt.
22971
22972 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22973
22974C...Double precision declaration.
22975 IMPLICIT DOUBLE PRECISION (A - Z)
22976
22977C...Common expressions.
22978 MU2 = 0.34D0
22979 LAM2 = 0.248D0 * 0.248D0
22980 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22981 DS = SQRT (S)
22982 S2 = S * S
22983 S3 = S2 * S
22984
22985C...uv :
22986 NU = 1.304D0 + 0.863D0 * S
22987 AKU = 0.558D0 - 0.020D0 * S
22988 BKU = 0.183D0 * S
22989 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
22990 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
22991 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
22992 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
22993 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22994
22995C...dv :
22996 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
22997 AKD = 0.270D0 - 0.019D0 * S
22998 BKD = 0.260D0
22999 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
23000 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
23001 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
23002 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
23003 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23004
23005C...del :
23006 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
23007 AKE = 0.409D0 - 0.007D0 * S
23008 BKE = 0.782D0 + 0.082D0 * S
23009 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
23010 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
23011 CE = 0.0D0
23012 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
23013 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23014
23015C...udb :
23016 ALX = 0.877D0
23017 BEX = 0.561D0
23018 AKX = 0.275D0
23019 BKX = 0.0D0
23020 AGX = 0.997D0
23021 BGX = 3.210D0 - 1.866D0 * S
23022 CX = 7.300D0
23023 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
23024 EX = 3.077D0 + 1.446D0 * S
23025 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
23026 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23027 & DX, EX, ESX)
23028
23029C...sb :
23030 STS = 0D0
23031 ALS = 0.756D0
23032 BES = 0.216D0
23033 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
23034 AS = -4.329D0 + 1.131D0 * S
23035 BS = 9.568D0 - 1.744D0 * S
23036 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
23037 EST = 3.031D0 + 1.639D0 * S
23038 ESS = 5.837D0 + 0.815D0 * S
23039 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23040
23041C...cb :
23042 STC = 0.820D0
23043 ALC = 0.98D0
23044 BEC = 0D0
23045 AKC = -0.625D0 - 0.523D0 * S
23046 AC = 0D0
23047 BC = 1.896D0 + 1.616D0 * S
23048 DCT = 4.12D0 + 0.683D0 * S
23049 ECT = 4.36D0 + 1.328D0 * S
23050 ESC = 0.677D0 + 0.679D0 * S
23051 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23052
23053C...bb :
23054 STB = 1.297D0
23055 ALB = 0.99D0
23056 BEB = 0D0
23057 AKB = - 0.193D0 * S
23058 AB = 0D0
23059 BB = 0D0
23060 DBT = 3.447D0 + 0.927D0 * S
23061 EBT = 4.68D0 + 1.259D0 * S
23062 ESB = 1.892D0 + 2.199D0 * S
23063 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23064
23065C...gl :
23066 ALG = 1.014D0
23067 BEG = 1.738D0
23068 AKG = 1.724D0 + 0.157D0 * S
23069 BKG = 0.800D0 + 1.016D0 * S
23070 AG = 7.517D0 - 2.547D0 * S
23071 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
23072 CG = 4.039D0 + 1.491D0 * S
23073 DG = 3.404D0 + 0.830D0 * S
23074 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
23075 ESG = 3.256D0 - 0.436D0 * S
23076 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23077
23078 RETURN
23079 END
23080
23081C*********************************************************************
23082
23083C...PYGRVD
23084C...Gives the GRV 94 D (DIS) parton distribution function set
23085C...in parametrized form.
23086C...Authors: M. Glueck, E. Reya and A. Vogt.
23087
23088 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23089
23090C...Double precision declaration.
23091 IMPLICIT DOUBLE PRECISION (A - Z)
23092
23093C...Common expressions.
23094 MU2 = 0.34D0
23095 LAM2 = 0.248D0 * 0.248D0
23096 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23097 DS = SQRT (S)
23098 S2 = S * S
23099 S3 = S2 * S
23100
23101C...uv :
23102 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
23103 AKU = 0.563D0 - 0.025D0 * S
23104 BKU = 0.054D0 + 0.154D0 * S
23105 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
23106 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
23107 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
23108 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
23109 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23110
23111C...dv :
23112 ND = 0.156D0 - 0.017D0 * S
23113 AKD = 0.299D0 - 0.022D0 * S
23114 BKD = 0.259D0 - 0.015D0 * S
23115 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
23116 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
23117 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
23118 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
23119 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23120
23121C...del :
23122 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
23123 AKE = 0.419D0 - 0.013D0 * S
23124 BKE = 1.064D0 - 0.038D0 * S
23125 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
23126 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
23127 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
23128 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
23129 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23130
23131C...udb :
23132 ALX = 1.215D0
23133 BEX = 0.466D0
23134 AKX = 0.326D0 + 0.150D0 * S
23135 BKX = 0.956D0 + 0.405D0 * S
23136 AGX = 0.272D0
23137 BGX = 3.794D0 - 2.359D0 * DS
23138 CX = 2.014D0
23139 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
23140 EX = 3.049D0 + 1.597D0 * S
23141 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
23142 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23143 & DX, EX, ESX)
23144
23145C...sb :
23146 STS = 0D0
23147 ALS = 0.175D0
23148 BES = 0.344D0
23149 AKS = 1.415D0 - 0.641D0 * DS
23150 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
23151 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
23152 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
23153 EST = 4.546D0 + 0.372D0 * S2
23154 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
23155 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23156
23157C...cb :
23158 STC = 0.820D0
23159 ALC = 0.98D0
23160 BEC = 0D0
23161 AKC = -0.625D0 - 0.523D0 * S
23162 AC = 0D0
23163 BC = 1.896D0 + 1.616D0 * S
23164 DCT = 4.12D0 + 0.683D0 * S
23165 ECT = 4.36D0 + 1.328D0 * S
23166 ESC = 0.677D0 + 0.679D0 * S
23167 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23168
23169C...bb :
23170 STB = 1.297D0
23171 ALB = 0.99D0
23172 BEB = 0D0
23173 AKB = - 0.193D0 * S
23174 AB = 0D0
23175 BB = 0D0
23176 DBT = 3.447D0 + 0.927D0 * S
23177 EBT = 4.68D0 + 1.259D0 * S
23178 ESB = 1.892D0 + 2.199D0 * S
23179 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23180
23181C...gl :
23182 ALG = 1.258D0
23183 BEG = 1.846D0
23184 AKG = 2.423D0
23185 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
23186 AG = 25.09D0 - 7.935D0 * S
23187 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
23188 CG = 590.3D0 - 173.8D0 * S
23189 DG = 5.196D0 + 1.857D0 * S
23190 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
23191 ESG = 3.232D0 - 0.542D0 * S
23192 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23193
23194 RETURN
23195 END
23196
23197C*********************************************************************
23198
23199C...PYGRVV
23200C...Auxiliary for the GRV 94 parton distribution functions
23201C...for u and d valence and d-u sea.
23202C...Authors: M. Glueck, E. Reya and A. Vogt.
23203
23204 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
23205
23206C...Double precision declaration.
23207 IMPLICIT DOUBLE PRECISION (A - Z)
23208
23209C...Evaluation.
23210 DX = SQRT (X)
23211 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
23212 & (1D0- X)**D
23213
23214 RETURN
23215 END
23216
23217C*********************************************************************
23218
23219C...PYGRVW
23220C...Auxiliary for the GRV 94 parton distribution functions
23221C...for d+u sea and gluon.
23222C...Authors: M. Glueck, E. Reya and A. Vogt.
23223
23224 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
23225
23226C...Double precision declaration.
23227 IMPLICIT DOUBLE PRECISION (A - Z)
23228
23229C...Evaluation.
23230 LX = LOG (1D0/X)
23231 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
23232 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
23233
23234 RETURN
23235 END
23236
23237C*********************************************************************
23238
23239C...PYGRVS
23240C...Auxiliary for the GRV 94 parton distribution functions
23241C...for s, c and b sea.
23242C...Authors: M. Glueck, E. Reya and A. Vogt.
23243
23244 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
23245
23246C...Double precision declaration.
23247 IMPLICIT DOUBLE PRECISION (A - Z)
23248
23249C...Evaluation.
23250 IF(S.LE.STH) THEN
23251 PYGRVS = 0D0
23252 ELSE
23253 DX = SQRT (X)
23254 LX = LOG (1D0/X)
23255 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
23256 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
23257 ENDIF
23258
23259 RETURN
23260 END
23261
23262C*********************************************************************
23263
23264C...PYHFTH
23265C...Gives threshold attractive/repulsive factor for heavy flavour
23266C...production.
23267
23268 FUNCTION PYHFTH(SH,SQM,FRATT)
23269
23270C...Double precision and integer declarations.
23271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23272 INTEGER PYK,PYCHGE,PYCOMP
23273C...Commonblocks.
23274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23275 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23276 COMMON/PYINT1/MINT(400),VINT(400)
23277 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23278
23279C...Value for alpha_strong.
23280 IF(MSTP(35).LE.1) THEN
23281 ALSSG=PARP(35)
23282 ELSE
23283 MST115=MSTU(115)
23284 MSTU(115)=MSTP(36)
23285 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
23286 & PARP(36)**2)))
23287 ALSSG=PYALPS(Q2BN)
23288 MSTU(115)=MST115
23289 ENDIF
23290
23291C...Evaluate attractive and repulsive factors.
23292 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23293 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
23294 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23295 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
23296 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
23297 VINT(138)=PYHFTH
23298
23299 RETURN
23300 END
23301
23302C*********************************************************************
23303
23304C...PYSPLI
23305C...Splits a hadron remnant into two (partons or hadron + parton)
23306C...in case it is more complicated than just a quark or a diquark.
23307
23308 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
23309
23310C...Double precision and integer declarations.
23311 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23312 INTEGER PYK,PYCHGE,PYCOMP
23313C...Commonblocks.
23314 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23315 COMMON/PYINT1/MINT(400),VINT(400)
23316 SAVE /PYPARS/,/PYINT1/
23317C...Local array.
23318 DIMENSION KFL(3)
23319
23320C...Preliminaries. Parton composition.
23321 KFA=IABS(KF)
23322 KFS=ISIGN(1,KF)
23323 KFL(1)=MOD(KFA/1000,10)
23324 KFL(2)=MOD(KFA/100,10)
23325 KFL(3)=MOD(KFA/10,10)
23326 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
23327 KFL(2)=INT(1.5D0+PYR(0))
23328 IF(MINT(105).EQ.333) KFL(2)=3
23329 IF(MINT(105).EQ.443) KFL(2)=4
23330 KFL(3)=KFL(2)
23331 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
23332 KFL(2)=2
23333 KFL(3)=2
23334 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
23335 KFL(2)=1
23336 KFL(3)=1
23337 ENDIF
23338 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
23339 KFLR=KFLIN*KFS
23340 ELSE
23341 KFLR=KFLIN
23342 ENDIF
23343 KFLCH=0
23344
23345C...Subdivide lepton.
23346 IF(KFA.GE.11.AND.KFA.LE.18) THEN
23347 IF(KFLR.EQ.KFA) THEN
23348 KFLSP=KFS*22
23349 ELSEIF(KFLR.EQ.22) THEN
23350 KFLSP=KFA
23351 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
23352 KFLSP=KFA+1
23353 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
23354 KFLSP=KFA-1
23355 ELSEIF(KFLR.EQ.21) THEN
23356 KFLSP=KFA
23357 KFLCH=KFS*21
23358 ELSE
23359 KFLSP=KFA
23360 KFLCH=-KFLR
23361 ENDIF
23362
23363C...Subdivide photon.
23364 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
23365 IF(KFLR.NE.21) THEN
23366 KFLSP=-KFLR
23367 ELSE
23368 RAGR=0.75D0*PYR(0)
23369 KFLSP=1
23370 IF(RAGR.GT.0.125D0) KFLSP=2
23371 IF(RAGR.GT.0.625D0) KFLSP=3
23372 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
23373 KFLCH=-KFLSP
23374 ENDIF
23375
23376C...Subdivide Reggeon or Pomeron.
23377 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
23378 IF(KFLIN.EQ.21) THEN
23379 KFLSP=KFS*21
23380 ELSE
23381 KFLSP=-KFLIN
23382 ENDIF
23383
23384C...Subdivide meson.
23385 ELSEIF(KFL(1).EQ.0) THEN
23386 KFL(2)=KFL(2)*(-1)**KFL(2)
23387 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
23388 IF(KFLR.EQ.KFL(2)) THEN
23389 KFLSP=KFL(3)
23390 ELSEIF(KFLR.EQ.KFL(3)) THEN
23391 KFLSP=KFL(2)
23392 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
23393 KFLSP=KFL(2)
23394 KFLCH=KFL(3)
23395 ELSEIF(KFLR.EQ.21) THEN
23396 KFLSP=KFL(3)
23397 KFLCH=KFL(2)
23398 ELSEIF(KFLR*KFL(2).GT.0) THEN
23399 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
23400 KFLSP=KFL(3)
23401 ELSE
23402 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
23403 KFLSP=KFL(2)
23404 ENDIF
23405
23406C...Subdivide baryon.
23407 ELSE
23408 NAGR=0
23409 DO 100 J=1,3
23410 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
23411 100 CONTINUE
23412 IF(NAGR.GE.1) THEN
23413 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
23414 IAGR=0
23415 DO 110 J=1,3
23416 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
23417 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
23418 110 CONTINUE
23419 ELSE
23420 IAGR=1.00001D0+2.99998D0*PYR(0)
23421 ENDIF
23422 ID1=1
23423 IF(IAGR.EQ.1) ID1=2
23424 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
23425 ID2=6-IAGR-ID1
23426 KSP=3
23427 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
23428 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
23429 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
23430 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
23431 ELSEIF(MOD(KFA,10).EQ.2) THEN
23432 IF(IAGR.EQ.1) KSP=1
23433 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
23434 ENDIF
23435 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
23436 IF(KFLR.EQ.21) THEN
23437 KFLCH=KFL(IAGR)
23438 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
23439 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
23440 ELSEIF(NAGR.EQ.0) THEN
23441 CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
23442 KFLSP=KFL(IAGR)
23443 ENDIF
23444 ENDIF
23445
23446C...Add on correct sign for result.
23447 KFLCH=KFLCH*KFS
23448 KFLSP=KFLSP*KFS
23449
23450 RETURN
23451 END
23452
23453C*********************************************************************
23454
23455C...PYGAMM
23456C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
23457C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
23458C...(Dover, 1965) 6.1.36.
23459
23460 FUNCTION PYGAMM(X)
23461
23462C...Double precision and integer declarations.
23463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23464 INTEGER PYK,PYCHGE,PYCOMP
23465C...Local array and data.
23466 DIMENSION B(8)
23467 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
23468 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
23469
23470 NX=INT(X)
23471 DX=X-NX
23472
23473 PYGAMM=1D0
23474 DXP=1D0
23475 DO 100 I=1,8
23476 DXP=DXP*DX
23477 PYGAMM=PYGAMM+B(I)*DXP
23478 100 CONTINUE
23479 IF(X.LT.1D0) THEN
23480 PYGAMM=PYGAMM/X
23481 ELSE
23482 DO 110 IX=1,NX-1
23483 PYGAMM=(X-IX)*PYGAMM
23484 110 CONTINUE
23485 ENDIF
23486
23487 RETURN
23488 END
23489
23490C***********************************************************************
23491
23492C...PYWAUX
23493C...Calculates real and imaginary parts of the auxiliary functions W1
23494C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
23495C...der Bij, Nucl. Phys. B297 (1988) 221.
23496
23497 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
23498
23499C...Double precision and integer declarations.
23500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23501 INTEGER PYK,PYCHGE,PYCOMP
23502C...Commonblocks.
23503 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23504 SAVE /PYDAT1/
23505
23506 ASINH(X)=LOG(X+SQRT(X**2+1D0))
23507 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
23508
23509 IF(EPS.LT.0D0) THEN
23510 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
23511 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
23512 WIM=0D0
23513 ELSEIF(EPS.LT.1D0) THEN
23514 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
23515 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
23516 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
23517 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
23518 ELSE
23519 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
23520 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
23521 WIM=0D0
23522 ENDIF
23523
23524 RETURN
23525 END
23526
23527C***********************************************************************
23528
23529C...PYI3AU
23530C...Calculates real and imaginary parts of the auxiliary function I3;
23531C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
23532C...Nucl. Phys. B297 (1988) 221.
23533
23534 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
23535
23536C...Double precision and integer declarations.
23537 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23538 INTEGER PYK,PYCHGE,PYCOMP
23539C...Commonblocks.
23540 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23541 SAVE /PYDAT1/
23542
23543 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
23544 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
23545
23546 IF(EPS.LT.0D0) THEN
23547 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23548 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23549 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23550 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
23551 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
23552 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
23553 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
23554 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
23555 & EPS))
23556 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23557 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23558 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23559 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
23560 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
23561 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
23562 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
23563 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
23564 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23565 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23566 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23567 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
23568 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
23569 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
23570 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
23571 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
23572 ELSE
23573 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23574 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
23575 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
23576 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
23577 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
23578 ENDIF
23579 F3IM=0D0
23580 ELSEIF(EPS.LT.1D0) THEN
23581 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23582 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23583 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23584 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
23585 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
23586 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23587 & (0.25D0*(RAT+1D0)*EPS))
23588 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23589 & (0.25D0*(RAT+1D0)*EPS))
23590 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23591 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23592 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23593 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
23594 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
23595 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
23596 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23597 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23598 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23599 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23600 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23601 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
23602 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
23603 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
23604 & (1D0+0.25D0*RAT*EPS-GA))
23605 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
23606 & (1D0+0.25D0*RAT*EPS-GA))
23607 ELSE
23608 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23609 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
23610 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
23611 & LOG((GA+BE-1D0)/(BE-GA))
23612 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
23613 ENDIF
23614 ELSE
23615 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
23616 RCTHE=RSQ*(1D0-2D0*BE/EPS)
23617 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
23618 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
23619 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
23620 R=SQRT(RSQ)
23621 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
23622 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
23623 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
23624 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
23625 & (PHI-THE)*(PHI+THE-PARU(1))
23626 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
23627 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
23628 ENDIF
23629
23630 Y3RE=2D0/(2D0*BE-1D0)*F3RE
23631 Y3IM=2D0/(2D0*BE-1D0)*F3IM
23632
23633 RETURN
23634 END
23635
23636C***********************************************************************
23637
23638C...PYSPEN
23639C...Calculates real and imaginary part of Spence function; see
23640C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
23641
23642 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
23643
23644C...Double precision and integer declarations.
23645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23646 INTEGER PYK,PYCHGE,PYCOMP
23647C...Commonblocks.
23648 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23649 SAVE /PYDAT1/
23650C...Local array and data.
23651 DIMENSION B(0:14)
23652 DATA B/
23653 &1.000000D+00, -5.000000D-01, 1.666667D-01,
23654 &0.000000D+00, -3.333333D-02, 0.000000D+00,
23655 &2.380952D-02, 0.000000D+00, -3.333333D-02,
23656 &0.000000D+00, 7.575757D-02, 0.000000D+00,
23657 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
23658
23659 XRE=XREIN
23660 XIM=XIMIN
23661 IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN
23662 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
23663 IF(IREIM.EQ.2) PYSPEN=0D0
23664 RETURN
23665 ENDIF
23666
23667 XMOD=SQRT(XRE**2+XIM**2)
23668 IF(XMOD.LT.1.D-6) THEN
23669 IF(IREIM.EQ.1) PYSPEN=0D0
23670 IF(IREIM.EQ.2) PYSPEN=0D0
23671 RETURN
23672 ENDIF
23673
23674 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23675 SP0RE=0D0
23676 SP0IM=0D0
23677 SGN=1D0
23678 IF(XMOD.GT.1D0) THEN
23679 ALGXRE=LOG(XMOD)
23680 ALGXIM=XARG-SIGN(PARU(1),XARG)
23681 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
23682 SP0IM=-ALGXRE*ALGXIM
23683 SGN=-1D0
23684 XMOD=1D0/XMOD
23685 XARG=-XARG
23686 XRE=XMOD*COS(XARG)
23687 XIM=XMOD*SIN(XARG)
23688 ENDIF
23689 IF(XRE.GT.0.5D0) THEN
23690 ALGXRE=LOG(XMOD)
23691 ALGXIM=XARG
23692 XRE=1D0-XRE
23693 XIM=-XIM
23694 XMOD=SQRT(XRE**2+XIM**2)
23695 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23696 ALGYRE=LOG(XMOD)
23697 ALGYIM=XARG
23698 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
23699 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
23700 SGN=-SGN
23701 ENDIF
23702
23703 XRE=1D0-XRE
23704 XIM=-XIM
23705 XMOD=SQRT(XRE**2+XIM**2)
23706 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23707 ZRE=-LOG(XMOD)
23708 ZIM=-XARG
23709
23710 SPRE=0D0
23711 SPIM=0D0
23712 SAVERE=1D0
23713 SAVEIM=0D0
23714 DO 100 I=0,14
23715 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
23716 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
23717 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
23718 SAVERE=TERMRE
23719 SAVEIM=TERMIM
23720 SPRE=SPRE+B(I)*TERMRE
23721 SPIM=SPIM+B(I)*TERMIM
23722 100 CONTINUE
23723
23724 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
23725 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
23726
23727 RETURN
23728 END
23729
23730C***********************************************************************
23731
23732C...PYQQBH
23733C...Calculates the matrix element for the processes
23734C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
23735C...REDUCE output and part of the rest courtesy Z. Kunszt, see
23736C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
23737
23738 SUBROUTINE PYQQBH(WTQQBH)
23739
23740C...Double precision and integer declarations.
23741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23742 INTEGER PYK,PYCHGE,PYCOMP
23743C...Commonblocks.
23744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23747 COMMON/PYINT1/MINT(400),VINT(400)
23748 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23749 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
23750C...Local arrays and function.
23751 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
23752 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
23753 &PP(I,3)*PP(J,3)
23754
23755C...Mass parameters.
23756 WTQQBH=0D0
23757 ISUB=MINT(1)
23758 SHPR=SQRT(VINT(26))*VINT(1)
23759 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
23760 PH=SQRT(VINT(21))*VINT(1)
23761 SPQ=PQ**2
23762 SPH=PH**2
23763
23764C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
23765 DO 100 I=1,2
23766 PT=SQRT(MAX(0D0,VINT(197+5*I)))
23767 PP(I,1)=PT*COS(VINT(198+5*I))
23768 PP(I,2)=PT*SIN(VINT(198+5*I))
23769 100 CONTINUE
23770 PP(3,1)=-PP(1,1)-PP(2,1)
23771 PP(3,2)=-PP(1,2)-PP(2,2)
23772 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
23773 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
23774 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
23775 PMT3=SQRT(PMS3)
23776 PP(3,3)=PMT3*SINH(VINT(211))
23777 PP(3,4)=PMT3*COSH(VINT(211))
23778 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
23779 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
23780 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
23781 PP(2,3)=-PP(1,3)-PP(3,3)
23782 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
23783 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
23784
23785C...Set up incoming kinematics and derived momentum combinations.
23786 DO 110 I=4,5
23787 PP(I,1)=0D0
23788 PP(I,2)=0D0
23789 PP(I,3)=-0.5D0*SHPR*(-1)**I
23790 PP(I,4)=-0.5D0*SHPR
23791 110 CONTINUE
23792 DO 120 J=1,4
23793 PP(6,J)=PP(1,J)+PP(2,J)
23794 PP(7,J)=PP(1,J)+PP(3,J)
23795 PP(8,J)=PP(1,J)+PP(4,J)
23796 PP(9,J)=PP(1,J)+PP(5,J)
23797 PP(10,J)=-PP(2,J)-PP(3,J)
23798 PP(11,J)=-PP(2,J)-PP(4,J)
23799 PP(12,J)=-PP(2,J)-PP(5,J)
23800 PP(13,J)=-PP(4,J)-PP(5,J)
23801 120 CONTINUE
23802
23803C...Derived kinematics invariants.
23804 X1=DOT(1,2)
23805 X2=DOT(1,3)
23806 X3=DOT(1,4)
23807 X4=DOT(1,5)
23808 X5=DOT(2,3)
23809 X6=DOT(2,4)
23810 X7=DOT(2,5)
23811 X8=DOT(3,4)
23812 X9=DOT(3,5)
23813 X10=DOT(4,5)
23814
23815C...Propagators.
23816 SS1=DOT(7,7)-SPQ
23817 SS2=DOT(8,8)-SPQ
23818 SS3=DOT(9,9)-SPQ
23819 SS4=DOT(10,10)-SPQ
23820 SS5=DOT(11,11)-SPQ
23821 SS6=DOT(12,12)-SPQ
23822 SS7=DOT(13,13)
23823 DX(1)=SS1*SS6
23824 DX(2)=SS2*SS6
23825 DX(3)=SS2*SS4
23826 DX(4)=SS1*SS5
23827 DX(5)=SS3*SS5
23828 DX(6)=SS3*SS4
23829 DX(7)=SS7*SS1
23830 DX(8)=SS7*SS4
23831
23832C...Define colour coefficients for g + g -> Q + Qbar + H.
23833 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
23834 DO 140 I=1,3
23835 DO 130 J=1,3
23836 CLR(I,J)=16D0/3D0
23837 CLR(I+3,J+3)=16D0/3D0
23838 CLR(I,J+3)=-2D0/3D0
23839 CLR(I+3,J)=-2D0/3D0
23840 130 CONTINUE
23841 140 CONTINUE
23842 DO 160 L=1,2
23843 DO 150 I=1,3
23844 CLR(I,6+L)=-6D0
23845 CLR(I+3,6+L)=6D0
23846 CLR(6+L,I)=-6D0
23847 CLR(6+L,I+3)=6D0
23848 150 CONTINUE
23849 160 CONTINUE
23850 DO 180 K1=1,2
23851 DO 170 K2=1,2
23852 CLR(6+K1,6+K2)=12D0
23853 170 CONTINUE
23854 180 CONTINUE
23855
23856C...Evaluate matrix elements for g + g -> Q + Qbar + H.
23857 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
23858 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
23859 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
23860 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
23861 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
23862 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
23863 & X10)
23864 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
23865 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
23866 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
23867 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
23868 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
23869 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
23870 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
23871 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
23872 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
23873 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
23874 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
23875 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
23876 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23877 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
23878 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
23879 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
23880 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
23881 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
23882 & X4*X6*X5)
23883 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
23884 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
23885 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
23886 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
23887 & +X4*X9*X5+X4*X5**2)
23888 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
23889 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
23890 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
23891 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
23892 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
23893 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
23894 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
23895 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
23896 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
23897 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
23898 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
23899 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
23900 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
23901 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
23902 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
23903 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
23904 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
23905 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
23906 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
23907 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
23908 & X6)
23909 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
23910 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23911 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
23912 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
23913 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
23914 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
23915 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
23916 & X5+X4*X6*X5)
23917 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
23918 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
23919 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
23920 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
23921 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
23922 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
23923 & X6**2)
23924 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
23925 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
23926 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
23927 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
23928 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
23929 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
23930 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
23931 & X4*X6*X5)
23932 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
23933 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
23934 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
23935 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
23936 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
23937 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
23938 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
23939 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
23940 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
23941 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
23942 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
23943 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
23944 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
23945 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
23946 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
23947 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
23948 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
23949 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
23950 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
23951 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
23952 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
23953 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
23954 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
23955 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
23956 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
23957 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
23958 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
23959 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
23960 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
23961 & +X3*X8*X5+X3*X5**2)
23962 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
23963 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
23964 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
23965 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
23966 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
23967 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
23968 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
23969 & X5+X4*X6*X5)
23970 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
23971 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
23972 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
23973 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
23974 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
23975 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
23976 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
23977 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
23978 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
23979 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
23980 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
23981 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
23982 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
23983 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
23984 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
23985 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
23986 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
23987 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
23988 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
23989 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
23990 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
23991 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
23992 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
23993 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
23994 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
23995 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
23996 & X10)
23997 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
23998 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
23999 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
24000 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
24001 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
24002 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
24003 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
24004 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
24005 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
24006 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
24007 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
24008 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
24009 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
24010 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
24011 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
24012 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
24013 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
24014 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
24015 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
24016 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
24017 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
24018 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
24019 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
24020 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
24021 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
24022 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
24023 & X7)
24024 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24025 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24026 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
24027 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
24028 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
24029 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
24030 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
24031 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
24032 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
24033 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
24034 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
24035 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24036 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24037 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
24038 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
24039 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
24040 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
24041 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
24042 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
24043 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
24044 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
24045 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
24046 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
24047 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
24048 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
24049 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
24050 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
24051 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
24052 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
24053 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
24054 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
24055 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
24056 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
24057 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
24058 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
24059 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
24060 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
24061 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
24062 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
24063 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
24064 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
24065 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
24066 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
24067 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
24068 & *X6)
24069 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
24070 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
24071 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
24072 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
24073 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
24074 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
24075 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
24076 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
24077 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
24078 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
24079 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
24080 & X8)
24081 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24082 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
24083 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
24084 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24085 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
24086 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
24087 & X9*X5)
24088 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24089 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
24090 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
24091 & X8*X5)
24092 FM(9,10)=0.5D0*(FMXX+FM(9,10))
24093 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24094 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
24095 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
24096
24097C...Repackage matrix elements.
24098 DO 200 I=1,8
24099 DO 190 J=1,8
24100 RM(I,J)=FM(I,J)
24101 190 CONTINUE
24102 200 CONTINUE
24103 RM(7,7)=FM(7,7)-2D0*FM(9,9)
24104 RM(7,8)=FM(7,8)-2D0*FM(9,10)
24105 RM(8,8)=FM(8,8)-2D0*FM(10,10)
24106
24107C...Produce final result: matrix elements * colours * propagators.
24108 DO 220 I=1,8
24109 DO 210 J=I,8
24110 FAC=8D0
24111 IF(I.EQ.J)FAC=4D0
24112 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
24113 210 CONTINUE
24114 220 CONTINUE
24115 WTQQBH=-WTQQBH/256D0
24116
24117 ELSE
24118C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
24119 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
24120 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
24121 & *X6+X8*X7)
24122 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
24123 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
24124 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
24125 & X5)
24126 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
24127 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
24128 & *X9+X4*X8)
24129
24130C...Produce final result: matrix elements * propagators.
24131 A11=A11/DX(7)**2
24132 A12=A12/(DX(7)*DX(8))
24133 A22=A22/DX(8)**2
24134 WTQQBH=-(A11+A22+2D0*A12)/8D0
24135 ENDIF
24136
24137 RETURN
24138 END
24139
24140C*********************************************************************
24141
24142C...PYMSIN
24143C...Initializes supersymmetry: finds sparticle masses and
24144C...branching ratios and stores this information.
24145C...AUTHOR: STEPHEN MRENNA
24146
24147 SUBROUTINE PYMSIN
24148
24149C...Double precision and integer declarations.
24150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24151 INTEGER PYK,PYCHGE,PYCOMP
24152C...Parameter statement to help give large particle numbers.
24153 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24154C...Commonblocks.
24155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24156 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24157 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
24158 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24159 COMMON/PYINT4/MWID(500),WIDS(500,5)
24160 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24161 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24162 &SFMIX(16,4)
24163 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
24164 &/PYSSMT/
24165
24166C...Local variables.
24167 INTEGER NSTR
24168 DOUBLE PRECISION ALFA,BETA
24169 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
24170 DOUBLE PRECISION PYALEM
24171 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
24172 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
24173 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
24174 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
24175 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
24176 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
24177 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
24178 DOUBLE PRECISION DELM,XMDIF,BRLIM
24179 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
24180 DOUBLE PRECISION ARG,SGNMU,R,GAM
24181 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
24182 INTEGER IMSSM,KFHIGG
24183 INTEGER IRPRTY
24184 INTEGER KFSUSY(36)
24185 DATA KFSUSY/
24186 &1000001,2000001,1000002,2000002,1000003,2000003,
24187 &1000004,2000004,1000005,2000005,1000006,2000006,
24188 &1000011,2000011,1000012,2000012,1000013,2000013,
24189 &1000014,2000014,1000015,2000015,1000016,2000016,
24190 &1000021,1000022,1000023,1000025,1000035,1000024,
24191 &1000037,1000039, 25, 35, 36, 37/
24192
24193C...Do nothing if SUSY not requested.
24194 IMSSM=IMSS(1)
24195 IF(IMSSM.EQ.0) RETURN
24196
24197C...First part of routine: set masses and couplings.
24198
24199C...Reset mixing values in sfermion sector to pure left/right.
24200 DO 100 I=1,16
24201 SFMIX(I,1)=1D0
24202 SFMIX(I,4)=1D0
24203 SFMIX(I,2)=0D0
24204 SFMIX(I,3)=0D0
24205 100 CONTINUE
24206
24207C...Common couplings.
24208 TANB=RMSS(5)
24209 BETA=ATAN(TANB)
24210 COSB=COS(BETA)
24211 SINB=TANB*COSB
24212 COS2B=COS(2D0*BETA)
24213 ALFA=RMSS(18)
24214 XMW2=PMAS(24,1)**2
24215 XMZ2=PMAS(23,1)**2
24216 XW=PARU(102)
24217
24218C...Define sparticle masses for a general MSSM simulation.
24219 IF(IMSSM.EQ.1) THEN
24220 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
24221 DO 110 I=1,5,2
24222 KC=PYCOMP(KSUSY1+I)
24223 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
24224 KC=PYCOMP(KSUSY2+I)
24225 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
24226 KC=PYCOMP(KSUSY1+I+1)
24227 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
24228 KC=PYCOMP(KSUSY2+I+1)
24229 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
24230 110 CONTINUE
24231 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
24232 IF(XARG.LT.0D0) THEN
24233 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24234 & ' FROM THE SUM RULE. '
24235 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24236 RETURN
24237 ELSE
24238 XARG=SQRT(XARG)
24239 ENDIF
24240 DO 120 I=11,15,2
24241 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
24242 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
24243 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24244 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24245 120 CONTINUE
24246 IF(IMSS(8).EQ.1) THEN
24247 RMSS(13)=RMSS(6)
24248 RMSS(14)=RMSS(7)
24249 ENDIF
24250
24251C...Alternatively derive masses from SUGRA relations.
24252 ELSEIF(IMSSM.EQ.2) THEN
24253 CALL PYAPPS
24254 ENDIF
24255
24256C...Add in extra D-term contributions.
24257 IF(IMSS(7).EQ.1) THEN
24258 R=0.43D0
24259 DX=RMSS(23)
24260 DY=RMSS(24)
24261 DS=RMSS(25)
24262 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24263 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
24264 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
24265 WRITE(MSTU(11),*) 'C DX = ',DX
24266 WRITE(MSTU(11),*) 'C DY = ',DY
24267 WRITE(MSTU(11),*) 'C DS = ',DS
24268 WRITE(MSTU(11),*) 'C '
24269 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
24270 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
24271 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24272 DQ2=DY/6D0-DX/3D0-DS/3D0
24273 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
24274 DD2=DY/3D0+DX-2D0*DS/3D0
24275 DL2=-DY/2D0+DX-2D0*DS/3D0
24276 DE2=DY-DX/3D0-DS/3D0
24277 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
24278 DHD2=-DY/2D0-2D0*DX/3D0+DS
24279 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
24280 & /ABS(COS2B)
24281 DMA2 = 2D0*DMU2+DHU2+DHD2
24282 DO 130 I=1,5,2
24283 KC=PYCOMP(KSUSY1+I)
24284 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24285 KC=PYCOMP(KSUSY2+I)
24286 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
24287 KC=PYCOMP(KSUSY1+I+1)
24288 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24289 KC=PYCOMP(KSUSY2+I+1)
24290 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
24291 130 CONTINUE
24292 DO 140 I=11,15,2
24293 KC=PYCOMP(KSUSY1+I)
24294 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24295 KC=PYCOMP(KSUSY2+I)
24296 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
24297 KC=PYCOMP(KSUSY1+I+1)
24298 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24299 140 CONTINUE
24300 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
24301 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
24302 STOP
24303 ENDIF
24304 SGNMU=SIGN(1D0,RMSS(4))
24305 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
24306 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
24307 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
24308 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
24309 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
24310 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
24311 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
24312 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
24313 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
24314 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
24315 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
24316 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
24317 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
24318 STOP
24319 ENDIF
24320 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
24321 RMSS(6)=SQRT(RMSS(6)**2+DL2)
24322 RMSS(7)=SQRT(RMSS(7)**2+DE2)
24323 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
24324 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
24325 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
24326 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
24327 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
24328 ENDIF
24329
24330C...Fix the third generation sfermions.
24331 CALL PYTHRG
24332 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
24333 IF(XARG.LT.0D0) THEN
24334 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
24335 & ' THE SUM RULE. '
24336 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24337 RETURN
24338 ELSE
24339 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
24340 ENDIF
24341
24342C...Fix the neutralino--chargino--gluino sector.
24343 CALL PYINOM
24344
24345C...Fix the Higgs sector.
24346 CALL PYHGGM(ALFA)
24347
24348C...Choose the Gunion-Haber convention.
24349 ALFA=-ALFA
24350 RMSS(18)=ALFA
24351
24352C...Print information on mass parameters.
24353 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
24354 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24355 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
24356 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
24357 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
24358 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
24359 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
24360 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
24361 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
24362 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
24363 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24364 ENDIF
24365 IF(IMSS(20).EQ.1) THEN
24366 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24367 WRITE(MSTU(11),*) ' DEBUG MODE '
24368 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
24369 & UMIX(2,1),UMIX(2,2)
24370 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
24371 & VMIX(2,1),VMIX(2,2)
24372 WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
24373 WRITE(MSTU(11),*) ' ALFA = ',ALFA
24374 WRITE(MSTU(11),*) ' BETA = ',BETA
24375 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
24376 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
24377 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24378 ENDIF
24379
24380C...Set up the Higgs couplings - needed here since initialization
24381C...in PYINRE did not yet occur when PYWIDT is called below.
24382 AL=ALFA
24383 BE=BETA
24384 SINA=SIN(AL)
24385 COSA=COS(AL)
24386 COSB=COS(BE)
24387 SINB=TANB*COSB
24388C...tanb (used for H+)
24389 PARU(141)=TANB
24390
24391C...Firstly: h
24392C...Coupling to d-type quarks
24393 PARU(161)=SINA/COSB
24394C...Coupling to u-type quarks
24395 PARU(162)=-COSA/SINB
24396C...Coupling to leptons
24397 PARU(163)=PARU(161)
24398C...Coupling to Z
24399 PARU(164)=SIN(BE-AL)
24400C...Coupling to W
24401 PARU(165)=PARU(164)
24402C...Coupling to H+
24403 PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW)
24404
24405C...Secondly: H
24406C...Coupling to d-type quarks
24407 PARU(171)=-COSA/COSB
24408C...Coupling to u-type quarks
24409 PARU(172)=-SINA/SINB
24410C...Coupling to leptons
24411 PARU(173)=PARU(171)
24412C...Coupling to Z
24413 PARU(174)=COS(BE-AL)
24414C...Coupling to W
24415 PARU(175)=PARU(174)
24416C...Coupling to h
24417 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
24418C...Coupling to A
24419 PARU(177)=COS(2D0*BE)*COS(BE+AL)
24420C...Coupling to H+
24421 PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW)
24422
24423C...Thirdly, A
24424C...Coupling to d-type quarks
24425 PARU(181)=TANB
24426C...Coupling to u-type quarks
24427 PARU(182)=1D0/PARU(181)
24428C...Coupling to leptons
24429 PARU(183)=PARU(181)
24430 PARU(184)=0D0
24431 PARU(185)=0D0
24432C...Coupling to Z h
24433 PARU(186)=COS(BE-AL)
24434C...Coupling to Z H
24435 PARU(187)=SIN(BE-AL)
24436 PARU(188)=0D0
24437 PARU(189)=0D0
24438 PARU(190)=0D0
24439
24440C...Finally: H+
24441C...Coupling to W h
24442 PARU(195)=COS(BE-AL)
24443
24444C...Tell that all Higgs couplings have been set.
24445 MSTP(4)=1
24446
24447C...Second part of routine: set decay modes and branching ratios.
24448
24449C...Allow chi10 -> gravitino + gamma or not.
24450 KC=PYCOMP(KSUSY1+39)
24451 IF( IMSS(11) .NE. 0 ) THEN
24452 PMAS(KC,1)=RMSS(21)/1000000000D0
24453 PMAS(KC,2)=0.0001D0
24454 IRPRTY=0
24455 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
24456 ELSE
24457 PMAS(KC,1)=9999D0
24458 IRPRTY=1
24459 ENDIF
24460
24461C...Loop over sparticle and Higgs species.
24462 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
24463 DO 200 I=1,36
24464 KF=KFSUSY(I)
24465 KC=PYCOMP(KF)
24466 LKNT=0
24467
24468C...Sfermion decays.
24469 IF(I.LE.24) THEN
24470C...First check to see if sneutrino is lighter than chi10.
24471 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
24472 & PMAS(KC,1).LT.PMCHI1) THEN
24473 ELSE
24474 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
24475 ENDIF
24476
24477C...Gluino decays.
24478 ELSEIF(I.EQ.25) THEN
24479 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
24480
24481C...Neutralino decays.
24482 ELSEIF(I.GE.26.AND.I.LE.29) THEN
24483 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
24484C...chi10 stable or chi10 -> gravitino + gamma.
24485 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
24486 PMAS(KC,2)=1D-6
24487 MDCY(KC,1)=0
24488 MWID(KC)=0
24489 ENDIF
24490
24491C...Chargino decays.
24492 ELSEIF(I.GE.30.AND.I.LE.31) THEN
24493 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
24494
24495C...Gravitino is stable.
24496 ELSEIF(I.EQ.32) THEN
24497 MDCY(KC,1)=0
24498 MWID(KC)=0
24499
24500C...Higgs decays.
24501 ELSEIF(I.GE.33.AND.I.LE.36) THEN
24502C...Calculate decays to non-SUSY particles.
24503 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
24504 LKNT=0
24505 DO 150 I1=0,100
24506 XLAM(I1)=0D0
24507 150 CONTINUE
24508 DO 170 I1=1,MDCY(KC,3)
24509 K1=MDCY(KC,2)+I1-1
24510 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
24511 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170
24512 XLAM(I1)=WDTP(I1)
24513 XLAM(0)=XLAM(0)+XLAM(I1)
24514 DO 160 J1=1,3
24515 IDLAM(I1,J1)=KFDP(K1,J1)
24516 160 CONTINUE
24517 LKNT=LKNT+1
24518 170 CONTINUE
24519C...Add the decays to SUSY particles.
24520 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
24521 ENDIF
24522
24523C...Set stable particles.
24524 IF(LKNT.EQ.0) THEN
24525 MDCY(KC,1)=0
24526 MWID(KC)=0
24527 PMAS(KC,2)=1D-6
24528 PMAS(KC,3)=1D-5
24529 PMAS(KC,4)=0D0
24530
24531C...Store branching ratios in the standard tables.
24532 ELSE
24533 IDC=MDCY(KC,2)+MDCY(KC,3)-1
24534 DELM=1D6
24535 DO 190 IL=1,LKNT
24536 IDCSV=IDC
24537 180 IDC=IDC+1
24538 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
24539 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
24540 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
24541 BRAT(IDC)=XLAM(IL)/XLAM(0)
24542 XMDIF=PMAS(KC,1)
24543 IF(MDME(IDC,1).GE.1) THEN
24544 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
24545 & PMAS(PYCOMP(KFDP(IDC,2)),1)
24546 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
24547 & PMAS(PYCOMP(KFDP(IDC,3)),1)
24548 ENDIF
24549 IF(I.LE.32) THEN
24550 IF(XMDIF.GE.0D0) THEN
24551 DELM=MIN(DELM,XMDIF)
24552 ELSE
24553 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
24554 WRITE(MSTU(11),*) ' KF = ',KF
24555 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
24556 ENDIF
24557 ENDIF
24558 GOTO 190
24559 ELSEIF(IDC.EQ.IDCSV) THEN
24560 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
24561 & 'channel not recognized:'
24562 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
24563 GOTO 190
24564 ELSE
24565 GOTO 180
24566 ENDIF
24567 190 CONTINUE
24568
24569C...Store width, cutoff and lifetime.
24570 PMAS(KC,2)=XLAM(0)
24571 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
24572 PMAS(KC,3)=PMAS(KC,2)*10D0
24573 ELSE
24574 PMAS(KC,3)=0.95D0*DELM
24575 ENDIF
24576 IF(PMAS(KC,2).NE.0D0) THEN
24577 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
24578 ENDIF
24579 ENDIF
24580 200 CONTINUE
24581
24582 RETURN
24583 END
24584
24585C*********************************************************************
24586
24587C...PYAPPS
24588C...Uses approximate analytical formulae to determine the full set of
24589C...MSSM parameters from SUGRA input.
24590C...See M. Drees and S.P. Martin, hep-ph/9504124
24591
24592 SUBROUTINE PYAPPS
24593
24594C...Double precision and integer declarations.
24595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24596 INTEGER PYK,PYCHGE,PYCOMP
24597C...Parameter statement to help give large particle numbers.
24598 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24599C...Commonblocks.
24600 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24601 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24602 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24603 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
24604
24605 XMT=PMAS(6,1)
24606 XMZ2=PMAS(23,1)**2
24607 XMW2=PMAS(24,1)**2
24608 TANB=RMSS(5)
24609 BETA=ATAN(TANB)
24610 XW=PARU(102)
24611 XMG=RMSS(1)
24612 XMG2=XMG*XMG
24613 XM0=RMSS(8)
24614 XM02=XM0*XM0
24615 AT=-RMSS(16)
24616 RMSS(15)=AT
24617 RMSS(17)=AT
24618 COSB=COS(BETA)
24619 SINB=TANB*COSB
24620
24621 DTERM=XMZ2*COS(2D0*BETA)
24622 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
24623 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
24624 RMSS(6)=XMEL
24625 RMSS(7)=XMER
24626 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
24627 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
24628 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
24629 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
24630 DO 100 I=1,5,2
24631 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
24632 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
24633 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
24634 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
24635 100 CONTINUE
24636 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
24637 IF(XARG.LT.0D0) THEN
24638 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24639 & ' FROM THE SUM RULE. '
24640 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24641 RETURN
24642 ELSE
24643 XARG=SQRT(XARG)
24644 ENDIF
24645 DO 110 I=11,15,2
24646 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
24647 PMAS(PYCOMP(KSUSY2+I),1)=XMER
24648 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24649 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24650 110 CONTINUE
24651 XMNU=XARG
24652
24653 RMT=PYRNMT(XMT)
24654 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
24655 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
24656 RMB=3D0
24657 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
24658 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
24659 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
24660 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
24661 &SINB)**2)
24662 RMSS(16)=-ATP
24663 XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
24664 XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
24665 XMU=SIGN(SQRT(XMU2),RMSS(4))
24666 RMSS(4)=XMU
24667 RMSS(19)=SQRT(XMA2)
24668 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
24669 IF(ARG.GT.0D0) THEN
24670 RMSS(14)=SQRT(ARG)
24671 ELSE
24672 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
24673 STOP
24674 ENDIF
24675 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
24676 IF(ARG.GT.0D0) THEN
24677 RMSS(13)=SQRT(ARG)
24678 ELSE
24679 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
24680 STOP
24681 ENDIF
24682 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
24683 IF(ARG.GT.0D0) THEN
24684 RMSS(10)=SQRT(ARG)
24685 ELSE
24686 RMSS(10)=-SQRT(-ARG)
24687 ENDIF
24688 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
24689 IF(ARG.GT.0D0) THEN
24690 RMSS(12)=SQRT(ARG)
24691 ELSE
24692 RMSS(12)=-SQRT(-ARG)
24693 ENDIF
24694 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
24695 IF(ARG.GT.0D0) THEN
24696 RMSS(11)=SQRT(ARG)
24697 ELSE
24698 RMSS(11)=-SQRT(-ARG)
24699 ENDIF
24700
24701 RETURN
24702 END
24703
24704C*********************************************************************
24705
24706C...PYRNMQ
24707C...Determines the running mass of quarks.
24708
24709 FUNCTION PYRNMQ(ID,DTERM)
24710
24711C...Double precision and integer declarations.
24712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24713 INTEGER PYK,PYCHGE,PYCOMP
24714C...Commonblock.
24715 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24716 SAVE /PYMSSM/
24717
24718C...Local variables.
24719 DOUBLE PRECISION PI,R
24720 DOUBLE PRECISION TOL
24721 DOUBLE PRECISION CI(3)
24722 EXTERNAL PYALPS
24723 DATA TOL/0.001D0/
24724 DATA PI,R/3.141592654D0,.61803399D0/
24725 DATA CI/0.47D0,0.07D0,0.02D0/
24726
24727 C=1D0-R
24728 CA=CI(ID)
24729 AG=(0.71D0)**2/4D0/PI
24730 AG=RMSS(20)
24731 XM0=RMSS(8)
24732 XMG=RMSS(1)
24733 XM02=XM0*XM0
24734 XMG2=XMG*XMG
24735
24736 AS=PYALPS(XM02+6D0*XMG2)
24737 CG=8D0/9D0*((AS/AG)**2-1D0)
24738 BX=XM02+(CA+CG)*XMG2+DTERM
24739 AX=MIN(50D0**2,0.5D0*BX)
24740 CX=MAX(2000D0**2,2D0*BX)
24741
24742 X0=AX
24743 X3=CX
24744 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24745 X1=BX
24746 X2=BX+C*(CX-BX)
24747 ELSE
24748 X2=BX
24749 X1=BX-C*(BX-AX)
24750 ENDIF
24751 AS1=PYALPS(X1)
24752 CG=8D0/9D0*((AS1/AG)**2-1D0)
24753 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24754 AS2=PYALPS(X2)
24755 CG=8D0/9D0*((AS2/AG)**2-1D0)
24756 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24757 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24758 IF(F2.LT.F1) THEN
24759 X0=X1
24760 X1=X2
24761 X2=R*X1+C*X3
24762 F1=F2
24763 AS2=PYALPS(X2)
24764 CG=8D0/9D0*((AS2/AG)**2-1D0)
24765 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24766 ELSE
24767 X3=X2
24768 X2=X1
24769 X1=R*X2+C*X0
24770 F2=F1
24771 AS1=PYALPS(X1)
24772 CG=8D0/9D0*((AS1/AG)**2-1D0)
24773 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24774 ENDIF
24775 GOTO 100
24776 ENDIF
24777 IF(F1.LT.F2) THEN
24778 PYRNMQ=X1
24779 XMIN=X1
24780 ELSE
24781 PYRNMQ=X2
24782 XMIN=X2
24783 ENDIF
24784
24785 RETURN
24786 END
24787
24788C*********************************************************************
24789
24790C...PYRNMT
24791C...Determines the running mass of the top quark.
24792
24793 FUNCTION PYRNMT(XMT)
24794
24795C...Double precision and integer declarations.
24796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24797 INTEGER PYK,PYCHGE,PYCOMP
24798C...Commonblock.
24799 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24800 SAVE /PYMSSM/
24801
24802C...Local variables.
24803 DOUBLE PRECISION XMT
24804 DOUBLE PRECISION PI,R
24805 DOUBLE PRECISION TOL
24806 EXTERNAL PYALPS
24807 DATA TOL/0.001D0/
24808 DATA PI,R/3.141592654D0,0.61803399D0/
24809
24810 C=1D0-R
24811
24812 BX=XMT
24813 AX=MIN(50D0,BX*0.5D0)
24814 CX=MAX(300D0,2D0*BX)
24815
24816 X0=AX
24817 X3=CX
24818 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24819 X1=BX
24820 X2=BX+C*(CX-BX)
24821 ELSE
24822 X2=BX
24823 X1=BX-C*(BX-AX)
24824 ENDIF
24825 AS1=PYALPS(X1**2)/PI
24826 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24827 AS2=PYALPS(X2**2)/PI
24828 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24829 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24830 IF(F2.LT.F1) THEN
24831 X0=X1
24832 X1=X2
24833 X2=R*X1+C*X3
24834 F1=F2
24835 AS2=PYALPS(X2**2)/PI
24836 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24837 ELSE
24838 X3=X2
24839 X2=X1
24840 X1=R*X2+C*X0
24841 F2=F1
24842 AS1=PYALPS(X1**2)/PI
24843 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24844 ENDIF
24845 GOTO 100
24846 ENDIF
24847 IF(F1.LT.F2) THEN
24848 PYRNMT=X1
24849 XMIN=X1
24850 ELSE
24851 PYRNMT=X2
24852 XMIN=X2
24853 ENDIF
24854
24855 RETURN
24856 END
24857
24858C*********************************************************************
24859
24860C...PYTHRG
24861C...Calculates the mass eigenstates of the third generation sfermions.
24862C...Created: 5-31-96
24863
24864 SUBROUTINE PYTHRG
24865
24866C...Double precision and integer declarations.
24867 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24868 INTEGER PYK,PYCHGE,PYCOMP
24869C...Parameter statement to help give large particle numbers.
24870 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24871C...Commonblocks.
24872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24874 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24875 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24876 &SFMIX(16,4)
24877 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
24878
24879C...Local variables.
24880 DOUBLE PRECISION BETA
24881 DOUBLE PRECISION PYRNMT
24882 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
24883 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
24884 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
24885 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
24886 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
24887 INTEGER IF,I,J,II,JJ,IT,L
24888 LOGICAL DTERM
24889 DATA SMALL/1D-3/
24890 DATA ID1/10,10,13/
24891 DATA ID2/5,6,15/
24892 DATA ID3/15,16,17/
24893 DATA ID4/11,12,14/
24894 DATA DTERM/.TRUE./
24895
24896 XMZ2=PMAS(23,1)**2
24897 XMW2=PMAS(24,1)**2
24898 TANB=RMSS(5)
24899 XMU=-RMSS(4)
24900 BETA=ATAN(TANB)
24901 COS2B=COS(2D0*BETA)
24902
24903C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
24904
24905 IOPT=IMSS(5)
24906 IF(IOPT.EQ.1) THEN
24907 CTT=RMSS(27)
24908 CTT2=CTT**2
24909 STT2=1D0-CTT2
24910 STT=SQRT(STT2)
24911 XM12=RMSS(12)**2
24912 XM22=RMSS(10)**2
24913 XMQL2=CTT2*XM12+STT2*XM22
24914 XMQR2=STT2*XM12+CTT2*XM22
24915 XMFR=PMAS(6,1)
24916 XMF2=PYRNMT(XMFR)**2
24917 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24918 ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
24919 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
24920 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
24921 STT=-STT
24922 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24923 ENDIF
24924 RMSS(16)=ATOP
24925C......SUBTRACT OUT D-TERM AND FERMION MASS
24926 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
24927 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
24928 IF(XMQL2.GE.0D0) THEN
24929 RMSS(10)=SQRT(XMQL2)
24930 ELSE
24931 RMSS(10)=-SQRT(-XMQL2)
24932 ENDIF
24933 IF(XMQR2.GE.0D0) THEN
24934 RMSS(12)=SQRT(XMQR2)
24935 ELSE
24936 RMSS(12)=-SQRT(-XMQR2)
24937 ENDIF
24938C SAME FOR SBOTTOM SQUARK
24939 CTT=RMSS(26)
24940 CTT2=CTT**2
24941 STT2=1D0-CTT2
24942 STT=MAX(SQRT(STT2),1D-6)
24943 XMF=3D00
24944 XMF2=XMF**2
24945 XM12=RMSS(11)**2
24946 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
24947 IF(ABS(CTT).EQ.1D0) THEN
24948 XM22=XM12
24949 XM12=XMQL2
24950 XMQR2=XM22
24951 ELSEIF(CTT.EQ.0D0) THEN
24952 XM22=XMQL2
24953 XMQR2=XM12
24954 ELSE
24955 XM22=(XMQL2-CTT2*XM12)/STT2
24956 XMQR2=STT2*XM12+CTT2*XM22
24957 ENDIF
24958 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24959 ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
24960 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
24961 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
24962 STT=-STT
24963 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
24964 ENDIF
24965 RMSS(15)=ABOT
24966C......SUBTRACT OUT D-TERM AND FERMION MASS
24967 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
24968 IF(XMQR2.GE.0D0) THEN
24969 RMSS(11)=SQRT(XMQR2)
24970 ELSE
24971 RMSS(11)=-SQRT(-XMQR2)
24972 ENDIF
24973 ENDIF
24974
24975 DO 170 L=1,3
24976 AMQL=RMSS(ID1(L))
24977 IF(AMQL.LT.0D0) THEN
24978 XMQL2=-AMQL**2
24979 ELSE
24980 XMQL2=AMQL**2
24981 ENDIF
24982 IF=ID2(L)
24983 XMF=PMAS(IF,1)
24984 IF(L.EQ.1) XMF=3D0
24985 IF(L.EQ.2) XMF=PYRNMT(XMF)
24986 XMF2=XMF**2
24987 ATR=RMSS(ID3(L))
24988 AMQR=RMSS(ID4(L))
24989 IF(AMQR.LT.0D0) THEN
24990 XMQR2=-AMQR**2
24991 ELSE
24992 XMQR2=AMQR**2
24993 ENDIF
24994 AM2(1,1)=XMQL2+XMF2
24995 AM2(2,2)=XMQR2+XMF2
24996 IF(DTERM) THEN
24997 IF(L.EQ.1) THEN
24998 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
24999 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
25000 AM2(1,2)=XMF*(ATR+XMU*TANB)
25001 ELSEIF(L.EQ.2) THEN
25002 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
25003 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
25004 AM2(1,2)=XMF*(ATR+XMU/TANB)
25005 ELSEIF(L.EQ.3) THEN
25006 IF(IMSS(8).EQ.1) THEN
25007 AM2(1,1)=RMSS(6)**2
25008 AM2(2,2)=RMSS(7)**2
25009 AM2(1,2)=0D0
25010 RMSS(13)=RMSS(6)
25011 RMSS(14)=RMSS(7)
25012 ELSE
25013 AM2(1,2)=XMF*(ATR+XMU*TANB)
25014 ENDIF
25015 ENDIF
25016 ENDIF
25017 AM2(2,1)=AM2(1,2)
25018 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
25019 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
25020 XMF12=SAME-DIFF
25021 XMF22=SAME+DIFF
25022 IF(XMF12.LT.0D0) THEN
25023 WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
25024 STOP
25025 ENDIF
25026 IT=0
25027 IF(XMF22-XMF12.GT.0D0) THEN
25028 RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12))
25029 RT(2,2) = RT(1,1)
25030 RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12))
25031 RT(2,1) = -RT(1,2)
25032 ELSE
25033 RT(1,1) = 1D0
25034 RT(2,2) = RT(1,1)
25035 RT(1,2) = 0D0
25036 RT(2,1) = -RT(1,2)
25037 ENDIF
25038 100 CONTINUE
25039 IT=IT+1
25040
25041 DO 140 I=1,2
25042 DO 130 JJ=1,2
25043 DI(I,JJ)=0D0
25044 DO 120 II=1,2
25045 DO 110 J=1,2
25046 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
25047 110 CONTINUE
25048 120 CONTINUE
25049 130 CONTINUE
25050 140 CONTINUE
25051
25052 IF(DI(1,1).GT.DI(2,2)) THEN
25053 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
25054 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
25055 WRITE(MSTU(11),*) AM2
25056 WRITE(MSTU(11),*) DI
25057 WRITE(MSTU(11),*) RT
25058 DI(1,1)=-RT(2,1)
25059 DI(2,2)=RT(1,2)
25060 DI(1,2)=-RT(2,2)
25061 DI(2,1)=RT(1,1)
25062 DO 160 I=1,2
25063 DO 150 J=1,2
25064 RT(I,J)=DI(I,J)
25065 150 CONTINUE
25066 160 CONTINUE
25067 GOTO 100
25068 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
25069 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25070 & ' OFF DIAGONAL ELEMENTS '
25071 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
25072 WRITE(MSTU(11),*) DI
25073 WRITE(MSTU(11),*) ' ROTATION = ',RT
25074C...STOP
25075 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
25076 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25077 & ' NEGATIVE MASSES '
25078 STOP
25079 ENDIF
25080 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
25081 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
25082 SFMIX(IF,1)=RT(1,1)
25083 SFMIX(IF,2)=RT(1,2)
25084 SFMIX(IF,3)=RT(2,1)
25085 SFMIX(IF,4)=RT(2,2)
25086 170 CONTINUE
25087
25088 RETURN
25089 END
25090
25091C*********************************************************************
25092
25093C...PYINOM
25094C...Finds the mass eigenstates and mixing matrices for neutralinos
25095C...and charginos.
25096
25097 SUBROUTINE PYINOM
25098
25099C...Double precision and integer declarations.
25100 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25101 INTEGER PYK,PYCHGE,PYCOMP
25102C...Parameter statement to help give large particle numbers.
25103 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25104C...Commonblocks.
25105 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25106 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25107 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25108 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25109 &SFMIX(16,4)
25110 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
25111
25112C...Local variables.
25113 DOUBLE PRECISION XMW,XMZ
25114 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
25115 DOUBLE PRECISION ZP(4,4)
25116 DOUBLE PRECISION DETX,XI(2,2)
25117 DOUBLE PRECISION XXX,YYY,XMH,XML
25118 DOUBLE PRECISION COSW,SINW
25119 DOUBLE PRECISION XMU
25120 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
25121 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
25122 DOUBLE PRECISION XM1,XM2,XM3,BETA
25123 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
25124 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
25125 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
25126 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
25127 DOUBLE PRECISION PYALPS,PYALEM
25128 DOUBLE PRECISION PYRNM3
25129 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
25130 DATA KFNCHI/1000022,1000023,1000025,1000035/
25131
25132 IOPT=IMSS(2)
25133 IF(IMSS(1).EQ.2) THEN
25134 IOPT=1
25135 ENDIF
25136C...M1, M2, AND M3 ARE INDEPENDENT
25137 IF(IOPT.EQ.0) THEN
25138 XM1=RMSS(1)
25139 XM2=RMSS(2)
25140 XM3=RMSS(3)
25141 ELSEIF(IOPT.GE.1) THEN
25142 Q2=PMAS(23,1)**2
25143 AEM=PYALEM(Q2)
25144 A2=AEM/PARU(102)
25145 A1=AEM/(1D0-PARU(102))
25146 XM1=RMSS(1)
25147 XM2=RMSS(2)
25148 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
25149 IF(IOPT.EQ.1) THEN
25150 XM2=XM1*A2/A1*3D0/5D0
25151 ELSEIF(IOPT.EQ.3) THEN
25152 XM1=XM2*5D0/3D0*A1/A2
25153 ENDIF
25154 XM3=PYRNM3(XM2/A2)
25155 IF(XM3.LE.0D0) THEN
25156 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
25157 STOP
25158 ENDIF
25159 ENDIF
25160
25161C...GLUINO MASS
25162 IF(IMSS(3).EQ.1) THEN
25163 PMAS(PYCOMP(KSUSY1+21),1)=XM3
25164 ELSE
25165 AQ=0D0
25166 DO 110 I=1,4
25167 DO 100 ILR=1,2
25168 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25169 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
25170 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
25171 100 CONTINUE
25172 110 CONTINUE
25173
25174 DO 130 I=5,6
25175 DO 120 ILR=1,2
25176 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25177 RM2=PMAS(I,1)**2/XM3**2
25178 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
25179 IF(ARG.GE.0D0) THEN
25180 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
25181 AX0=ABS(X0)
25182 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
25183 AX1=ABS(X1)
25184 IF(X0.EQ.1D0) THEN
25185 AT=-1D0
25186 BT=0.25D0
25187 ELSEIF(X0.EQ.0D0) THEN
25188 AT=0D0
25189 BT=-0.25D0
25190 ELSE
25191 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
25192 & 0.5D0*X0**2*LOG(AX0)
25193 BT=(-1D0-2D0*X0)/4D0
25194 ENDIF
25195 IF(X1.EQ.1D0) THEN
25196 AT=-1D0+AT
25197 BT=0.25D0+BT
25198 ELSEIF(X1.EQ.0D0) THEN
25199 AT=0D0+AT
25200 BT=-0.25D0+BT
25201 ELSE
25202 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
25203 & X1**2*LOG(AX1)+AT
25204 BT=(-1D0-2D0*X1)/4D0+BT
25205 ENDIF
25206 AQ=AQ+AT+BT
25207 ELSE
25208 X0=0.5D0*(1D0+RM2-RM1)
25209 Y0=-0.5D0*SQRT(-ARG)
25210 AMGX0=SQRT(X0**2+Y0**2)
25211 AM1X0=SQRT((1D0-X0)**2+Y0**2)
25212 ARGX0=ATAN2(-X0,-Y0)
25213 AR1X0=ATAN2(1D0-X0,Y0)
25214 X1=X0
25215 Y1=-Y0
25216 AMGX1=AMGX0
25217 AM1X1=AM1X0
25218 ARGX1=ATAN2(-X1,-Y1)
25219 AR1X1=ATAN2(1D0-X1,Y1)
25220 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
25221 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
25222 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
25223 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
25224 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
25225 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
25226 AQ=AQ+AT+BT
25227 ENDIF
25228 120 CONTINUE
25229 130 CONTINUE
25230 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
25231 & (15D0+AQ))
25232 ENDIF
25233
25234C...NEUTRALINO MASSES
25235 XMZ=PMAS(23,1)
25236 XMW=PMAS(24,1)
25237 XMU=RMSS(4)
25238 SINW=SQRT(PARU(102))
25239 COSW=SQRT(1D0-PARU(102))
25240 TANB=RMSS(5)
25241 BETA=ATAN(TANB)
25242 COSB=COS(BETA)
25243 SINB=TANB*COSB
25244 AR(1,1) = XM1
25245 AR(2,2) = XM2
25246 AR(3,3) = 0D0
25247 AR(4,4) = 0D0
25248 AR(1,2) = 0D0
25249 AR(2,1) = 0D0
25250 AR(1,3) = -XMZ*SINW*COSB
25251 AR(3,1) = AR(1,3)
25252 AR(1,4) = XMZ*SINW*SINB
25253 AR(4,1) = AR(1,4)
25254 AR(2,3) = XMZ*COSW*COSB
25255 AR(3,2) = AR(2,3)
25256 AR(2,4) = -XMZ*COSW*SINB
25257 AR(4,2) = AR(2,4)
25258 AR(3,4) = -XMU
25259 AR(4,3) = -XMU
25260 CALL PYEIG4(AR,WR,ZR)
25261 DO 150 I=1,4
25262 SMZ(I)=WR(I)
25263 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
25264 DO 140 J=1,4
25265 ZMIX(I,J)=ZR(I,J)
25266 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
25267 140 CONTINUE
25268 150 CONTINUE
25269
25270C...CHARGINO MASSES
25271 AR(1,1) = XM2
25272 AR(2,2) = XMU
25273 AR(1,2) = SQRT(2D0)*XMW*SINB
25274 AR(2,1) = SQRT(2D0)*XMW*COSB
25275 TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
25276 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
25277 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
25278 &(AR(1,2)**2+AR(2,1)**2)+
25279 &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
25280 DISCR=TERMC
25281 IF(DISCR.LT.0D0) THEN
25282 WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
25283 ELSE
25284 DISCR=SQRT(DISCR)
25285 ENDIF
25286 XML2=0.5D0*(TERMB-DISCR)
25287 XMH2=0.5D0*(TERMB+DISCR)
25288 XML=SQRT(XML2)
25289 XMH=SQRT(XMH2)
25290 PMAS(PYCOMP(KSUSY1+24),1)=XML
25291 PMAS(PYCOMP(KSUSY1+37),1)=XMH
25292 SMW(1)=XML
25293 SMW(2)=XMH
25294 XXX=AR(1,1)**2+AR(2,1)**2
25295 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
25296 VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
25297 VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25298 VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
25299 VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25300 ZR(1,1) = XML
25301 ZR(1,2) = 0D0
25302 ZR(2,1) = 0D0
25303 ZR(2,2) = XMH
25304 DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
25305 XI(1,1) = AR(2,2)/DETX
25306 XI(2,2) = AR(1,1)/DETX
25307 XI(1,2) = -AR(1,2)/DETX
25308 XI(2,1) = -AR(2,1)/DETX
25309 DO 190 I=1,2
25310 DO 180 J=1,2
25311 UMIX(I,J)=0D0
25312 DO 170 K=1,2
25313 DO 160 L=1,2
25314 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
25315 160 CONTINUE
25316 170 CONTINUE
25317 180 CONTINUE
25318 190 CONTINUE
25319
25320 RETURN
25321 END
25322
25323C*********************************************************************
25324
25325C...PYRNM3
25326C...Calculates the running of M3, the SU(3) gluino mass parameter.
25327
25328 FUNCTION PYRNM3(RGUT)
25329
25330C...Double precision and integer declarations.
25331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25332 INTEGER PYK,PYCHGE,PYCOMP
25333
25334C...Local variables.
25335 DOUBLE PRECISION PI,R
25336 DOUBLE PRECISION TOL
25337 EXTERNAL PYALPS
25338 DATA TOL/0.001D0/
25339 DATA PI,R/3.141592654D0,0.61803399D0/
25340
25341 C=1D0-R
25342
25343 BX=RGUT*PYALPS(RGUT**2)
25344 AX=MIN(50D0,BX*0.5D0)
25345 CX=MAX(2000D0,2D0*BX)
25346
25347 X0=AX
25348 X3=CX
25349 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
25350 X1=BX
25351 X2=BX+C*(CX-BX)
25352 ELSE
25353 X2=BX
25354 X1=BX-C*(BX-AX)
25355 ENDIF
25356 AS1=PYALPS(X1**2)
25357 F1=ABS(X1-RGUT*AS1)
25358 AS2=PYALPS(X2**2)
25359 F2=ABS(X2-RGUT*AS2)
25360 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
25361 IF(F2.LT.F1) THEN
25362 X0=X1
25363 X1=X2
25364 X2=R*X1+C*X3
25365 F1=F2
25366 AS2=PYALPS(X2**2)
25367 F2=ABS(X2-RGUT*AS2)
25368 ELSE
25369 X3=X2
25370 X2=X1
25371 X1=R*X2+C*X0
25372 F2=F1
25373 AS1=PYALPS(X1**2)
25374 F1=ABS(X1-RGUT*AS1)
25375 ENDIF
25376 GOTO 100
25377 ENDIF
25378 IF(F1.LT.F2) THEN
25379 PYRNM3=X1
25380 XMIN=X1
25381 ELSE
25382 PYRNM3=X2
25383 XMIN=X2
25384 ENDIF
25385
25386 RETURN
25387 END
25388
25389C*********************************************************************
25390
25391C...PYEIG4
25392C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
25393C...Specific application: mixing in neutralino sector.
25394
25395 SUBROUTINE PYEIG4(A,W,Z)
25396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25397 INTEGER PYK,PYCHGE,PYCOMP
25398
25399C...Arrays: in call and local.
25400 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
25401
25402C...Coefficients of fourth-degree equation from matrix.
25403C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
25404 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
25405 B2=0D0
25406 DO 110 I=1,3
25407 DO 100 J=I+1,4
25408 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
25409 100 CONTINUE
25410 110 CONTINUE
25411 B1=0D0
25412 B0=0D0
25413 DO 120 I=1,4
25414 I1=MOD(I,4)+1
25415 I2=MOD(I+1,4)+1
25416 I3=MOD(I+2,4)+1
25417 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
25418 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
25419 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
25420 B0=B0+(-1D0)**(I+1)*A(1,I)*(
25421 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
25422 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
25423 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
25424 120 CONTINUE
25425
25426C...Coefficients of third-degree equation needed for
25427C...separation into two second-degree equations.
25428C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
25429 C2=-B2
25430 C1=B1*B3-4D0*B0
25431 C0=-B1**2-B0*B3**2+4D0*B0*B2
25432 CQ=C1/3D0-C2**2/9D0
25433 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
25434 CQR=CQ**3+CR**2
25435
25436C...Cases with one or three real roots.
25437 IF(CQR.GE.0D0) THEN
25438 S1=(CR+SQRT(CQR))**(1D0/3D0)
25439 S2=(CR-SQRT(CQR))**(1D0/3D0)
25440 U=S1+S2-C2/3D0
25441 ELSE
25442 SABS=SQRT(-CQ)
25443 THE=ACOS(CR/SABS**3)/3D0
25444 SRE=SABS*COS(THE)
25445 U=2D0*SRE-C2/3D0
25446 ENDIF
25447
25448C...Find and solve two second-degree equations.
25449 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
25450 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
25451 Q1=U/2D0+SQRT(U**2/4D0-B0)
25452 Q2=U/2D0-SQRT(U**2/4D0-B0)
25453 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
25454 QSAV=Q1
25455 Q1=Q2
25456 Q2=QSAV
25457 ENDIF
25458 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
25459 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
25460 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
25461 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
25462
25463C...Order eigenvalues in asceding mass.
25464 W(1)=X(1)
25465 DO 150 I1=2,4
25466 DO 130 I2=I1-1,1,-1
25467 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
25468 W(I2+1)=W(I2)
25469 130 CONTINUE
25470 140 W(I2+1)=X(I1)
25471 150 CONTINUE
25472
25473C...Find equation system for eigenvectors.
25474 DO 250 I=1,4
25475 DO 170 J1=1,4
25476 D(J1,J1)=A(J1,J1)-W(I)
25477 DO 160 J2=J1+1,4
25478 D(J1,J2)=A(J1,J2)
25479 D(J2,J1)=A(J2,J1)
25480 160 CONTINUE
25481 170 CONTINUE
25482
25483C...Find largest element in matrix.
25484 DAMAX=0D0
25485 DO 190 J1=1,4
25486 DO 180 J2=1,4
25487 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
25488 JA=J1
25489 JB=J2
25490 DAMAX=ABS(D(J1,J2))
25491 180 CONTINUE
25492 190 CONTINUE
25493
25494C...Subtract others by multiple of row selected above.
25495 DAMAX=0D0
25496 DO 210 J3=JA+1,JA+3
25497 J1=J3-4*((J3-1)/4)
25498 RL=D(J1,JB)/D(JA,JB)
25499 DO 200 J2=1,4
25500 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
25501 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
25502 JC=J1
25503 JD=J2
25504 DAMAX=ABS(D(J1,J2))
25505 200 CONTINUE
25506 210 CONTINUE
25507
25508C...Do one more subtraction of a row.
25509 DAMAX=0D0
25510 DO 230 J3=JC+1,JC+3
25511 J1=J3-4*((J3-1)/4)
25512 IF(J1.EQ.JA) GOTO 230
25513 RL=D(J1,JD)/D(JC,JD)
25514 DO 220 J2=1,4
25515 IF(J2.EQ.JB) GOTO 220
25516 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
25517 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
25518 JE=J1
25519 DAMAX=ABS(D(J1,J2))
25520 220 CONTINUE
25521 230 CONTINUE
25522
25523C...Construct unnormalized eigenvector.
25524 JF1=JD+1-4*(JD/4)
25525 JF2=JD+2-4*((JD+1)/4)
25526 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
25527 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
25528 E(JF1)=-D(JE,JF2)
25529 E(JF2)=D(JE,JF1)
25530 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
25531 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
25532 & D(JA,JB)
25533
25534C...Normalize and fill in final array.
25535 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
25536 SGN=(-1D0)**INT(PYR(0)+0.5D0)
25537 DO 240 J=1,4
25538 Z(I,J)=SGN*E(J)/EA
25539 240 CONTINUE
25540 250 CONTINUE
25541
25542 RETURN
25543 END
25544
25545C*********************************************************************
25546
25547C...PYHGGM
25548C...Determines the Higgs boson mass spectrum using several inputs.
25549
25550 SUBROUTINE PYHGGM(ALPHA)
25551
25552C...Double precision and integer declarations.
25553 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25554 INTEGER PYK,PYCHGE,PYCOMP
25555C...Parameter statement to help give large particle numbers.
25556 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25557C...Commonblocks.
25558 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25559 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25561 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25562 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
25563
25564C...Local variables.
25565 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
25566 DOUBLE PRECISION ALPHA
25567 INTEGER I,J,IHOPT,II,JJ,IT
25568 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
25569 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
25570 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
25571 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
25572
25573 IHOPT=IMSS(4)
25574 IF(IHOPT.EQ.2) THEN
25575 ALPHA=RMSS(18)
25576 RETURN
25577 ENDIF
25578 AT=RMSS(16)
25579 AB=RMSS(15)
25580 XMU=RMSS(4)
25581 TANB=RMSS(5)
25582
25583 DMA=RMSS(19)
25584 DTANB=TANB
25585 DMQ=RMSS(10)
25586 DMUR=RMSS(12)
25587 DMDR=RMSS(11)
25588 DMTOP=PMAS(6,1)
25589 DMC=PMAS(PYCOMP(KSUSY1+37),1)
25590 DAU=AT
25591 DAD=AB
25592 DMU=XMU
25593
25594 IF(IHOPT.EQ.0) THEN
25595 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25596 & DMHCH,DSA,DCA,DTANBA)
25597 ELSEIF(IHOPT.EQ.1) THEN
25598 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25599 & DMHCH,DSA,DCA,DTANBA)
25600 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
25601 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
25602 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
25603 DMH=DMHP
25604 DHM=DHMP
25605 DMA=DAMP
25606 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN
25607 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
25608 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
25609 & PMAS(PYCOMP(1000006),1),DSTOP2
25610 ENDIF
25611 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN
25612 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
25613 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
25614 & PMAS(PYCOMP(2000006),1),DSTOP1
25615 ENDIF
25616 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN
25617 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
25618 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
25619 & PMAS(PYCOMP(1000005),1),DSBOT2
25620 ENDIF
25621 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN
25622 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
25623 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
25624 & PMAS(PYCOMP(2000005),1),DSBOT1
25625 ENDIF
25626
25627 ENDIF
25628
25629 ALPHA=ACOS(DCA)
25630
25631 PMAS(25,1)=DMH
25632 PMAS(35,1)=DHM
25633 PMAS(36,1)=DMA
25634 PMAS(37,1)=DMHCH
25635
25636 RETURN
25637 END
25638
25639C*********************************************************************
25640
25641C...PYSUBH
25642C...This routine computes the renormalization group improved
25643C...values of Higgs masses and couplings in the MSSM.
25644
25645C...Program based on the work by M. Carena, J.R. Espinosa,
25646c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
25647
25648C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
25649C...All masses in GeV units. MA is the CP-odd Higgs mass,
25650C...MTOP is the physical top mass, MQ and MUR are the soft
25651C...supersymmetry breaking mass parameters of left handed
25652C...and right handed stops respectively, AU and AD are the
25653C...stop and sbottom trilinear soft breaking terms,
25654C...respectively, and MU is the supersymmetric
25655C...Higgs mass parameter. We use the conventions from
25656C...the physics report of Haber and Kane: left right
25657C...stop mixing term proportional to (AU - MU/TANB)
25658C...We use as input TANB defined at the scale MTOP
25659
25660C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
25661C...where MH and HM are the lightest and heaviest CP-even
25662C...Higgs masses, MHCH is the charged Higgs mass and
25663C...ALPHA is the Higgs mixing angle
25664C...TANBA is the angle TANB at the CP-odd Higgs mass scale
25665
25666C...Range of validity:
25667C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
25668C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
25669C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
25670C...are the sbottom mass eigenvalues, respectively. This
25671C...range automatically excludes the existence of tachyons.
25672C...For the charged Higgs mass computation, the method is
25673C...valid if
25674C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
25675C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
25676C...where M_SUSY**2 is the average of the squared stop mass
25677C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
25678C...masses have been assumed to be of order of the stop ones
25679C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
25680
25681 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
25682 &XMHCH,SA,CA,TANBA)
25683
25684C...Double precision and integer declarations.
25685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25686 INTEGER PYK,PYCHGE,PYCOMP
25687C...Parameter statement to help give large particle numbers.
25688 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25689C...Commonblocks.
25690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25691 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25692 SAVE /PYDAT1/,/PYDAT2/
25693
25694C...Local variables.
25695 DOUBLE PRECISION PYALEM,PYALPS
25696 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
25697 DOUBLE PRECISION XMHCH,SA,CA
25698 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
25699 DOUBLE PRECISION Q02
25700 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
25701 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
25702 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
25703 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
25704 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
25705 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
25706 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
25707 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
25708
25709 XMZ = PMAS(23,1)
25710 Q02=XMZ**2
25711 AEM=PYALEM(Q02)
25712 ALP1=AEM/(1D0-PARU(102))
25713 ALP2=AEM/PARU(102)
25714 ALPH3Z=PYALPS(Q02)
25715
25716 ALP1 = 0.0101D0
25717 ALP2 = 0.0337D0
25718 ALPH3Z = 0.12D0
25719
25720 V = 174.1D0
25721 PI = PARU(1)
25722 TANBA = TANB
25723 TANBT = TANB
25724
25725C...MBOTTOM(MTOP) = 3. GEV
25726 XMB = 3D0
25727 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
25728 &LOG(XMTOP**2/XMZ**2))
25729
25730C...RMTOP= RUNNING TOP QUARK MASS
25731 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
25732 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
25733 T = LOG(XMS**2/XMTOP**2)
25734 SINB = TANB/((1D0 + TANB**2)**0.5D0)
25735 COSB = SINB/TANB
25736C...IF(MA.LE.XMTOP) TANBA = TANBT
25737 IF(XMA.GT.XMTOP)
25738 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
25739 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
25740 &LOG(XMA**2/XMTOP**2))
25741
25742 SINBT = TANBT/SQRT(1D0 + TANBT**2)
25743 COSBT = 1D0/SQRT(1D0 + TANBT**2)
25744 COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
25745 G1 = SQRT(ALP1*4D0*PI)
25746 G2 = SQRT(ALP2*4D0*PI)
25747 G3 = SQRT(ALP3*4D0*PI)
25748 HU = RMTOP/V/SINBT
25749 HD = XMB/V/COSBT
25750 HU2=HU*HU
25751 HD2=HD*HD
25752 HU4=HU2*HU2
25753 HD4=HD2*HD2
25754 AU2=AU**2
25755 AD2=AD**2
25756 XMS2=XMS**2
25757 XMS3=XMS**3
25758 XMS4=XMS2*XMS2
25759 XMU2=XMU*XMU
25760 PI2=PI*PI
25761
25762 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
25763 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
25764 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
25765 &+ 3D0*(AU + AD)**2/XMS2)/6D0
25766 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
25767 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
25768 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
25769 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
25770 &- 16D0*G3**2) *T/16D0/PI2)
25771 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
25772 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
25773 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
25774 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
25775 &- 16D0*G3**2) *T/16D0/PI2)
25776 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
25777 &(HU2 + HD2)*T/16D0/PI2)
25778 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25779 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25780 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25781 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
25782 &- 16D0*G3**2) *T/16D0/PI2)
25783 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25784 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
25785 &- 16D0*G3**2) *T/16D0/PI2)
25786 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
25787 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25788 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25789 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25790 &XMS4)*
25791 &(1+ (6D0*HU2 -2D0* HD2
25792 &- 16D0*G3**2) *T/16D0/PI2)
25793 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25794 &XMS4)*
25795 &(1+ (6D0*HD2 -2D0* HU2/2D0
25796 &- 16D0*G3**2) *T/16D0/PI2)
25797 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
25798 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
25799 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
25800 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
25801 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
25802 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25803 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
25804 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25805 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
25806 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25807 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
25808 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25809 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
25810 &2D0* XLAM6*SINBT*COSBT
25811 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
25812 &+ XLAM5*COSBT**2)
25813 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
25814 &XLAM6*COSBT**2
25815 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
25816 &2D0* XLAM6* COSBT*SINBT
25817 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25818 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
25819 &((XLAM1* COSBT**2 +2D0*
25820 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
25821 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
25822 &*SINBT**2
25823 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
25824 &+ XLAM4) + XLAM6*COSBT**2
25825 &+ XLAM7* SINBT**2))
25826
25827 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
25828 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
25829 XHM = SQRT(XHM2)
25830 XMH = SQRT(XMH2)
25831 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
25832 XMHCH = SQRT(XMHCH2)
25833
25834 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25835 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25836 &XLAM6* COSBT*SINBT
25837 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25838 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25839 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
25840 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
25841
25842 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
25843 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
25844 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
25845 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
25846 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25847 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25848 &XLAM6* COSBT*SINBT
25849 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25850 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25851 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
25852
25853 SA = -SINALP
25854 CA = -COSALP
25855
25856 100 CONTINUE
25857
25858 RETURN
25859 END
25860
25861C*********************************************************************
25862
25863C...PYPOLE
25864C...This subroutine computes the CP-even higgs and CP-odd pole
25865c...Higgs masses and mixing angles.
25866
25867C...Program based on the work by M. Carena, M. Quiros
25868C...and C.E.M. Wagner, "Effective potential methods and
25869C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
25870
25871C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
25872C...AT,AB,MU
25873C...where MCHI is the largest chargino mass, MA is the running
25874C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
25875C...expectaion values at the scale MTOP, MQ is the third generation
25876C...left handed squark mass parameter, MUR is the third generation
25877C...right handed stop mass parameter, MDR is the third generation
25878C...right handed sbottom mass parameter, MTOP is the pole top quark
25879C...mass; AT,AB are the soft supersymmetry breaking trilinear
25880C...couplings of the stop and sbottoms, respectively, and MU is the
25881C...supersymmetric mass parameter
25882
25883C...The parameter IHIGGS=0,1,2,3 corresponds to the
25884c...number of Higgses whose pole mass is computed
25885c...by the subroutine PYVACU(...). If IHIGGS=0 only running
25886c...masses are given, what makes the running of the program
25887c...much faster and it is quite generally a good approximation
25888c...(for a theoretical discussion see ref. below).
25889c...If IHIGGS=1, only the pole
25890c...mass for H is computed. If IHIGGS=2, then h and H, and
25891c...if IHIGGS=3, then h,H,A polarizations are computed
25892
25893C...Output: MH and MHP which are the lightest CP-even Higgs running
25894C...and pole masses, respectively; HM and HMP are the heaviest CP-even
25895C...Higgs running and pole masses, repectively; SA and CA are the
25896C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
25897C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
25898C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
25899C...the value of TANB at the CP-odd Higgs mass scale
25900
25901C...This subroutine makes use of CERN library subroutine
25902C...integration package, which makes the computation of the
25903C...pole Higgs masses somewhat faster. We thank P. Janot for this
25904C...improvement. Those who are not able to call the CERN
25905C...libraries, please use the subroutine SUBHPOLE2.F, which
25906C...although somewhat slower, gives identical results
25907
25908 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
25909 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
25910
25911C...Double precision and integer declarations.
25912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25913 INTEGER PYK,PYCHGE,PYCOMP
25914
25915 CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
25916 &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2,
25917 &SA,CA,STOP1W,STOP2W,TANBA)
25918 SINB = TANB/(TANB**2+1D0)**0.5D0
25919 COSB = 1D0/(TANB**2+1D0)**0.5D0
25920 SINBMA = SINB*CA - COSB*SA
25921
25922 RETURN
25923 END
25924
25925C*********************************************************************
25926
25927C...PYVACU
25928C...Computes Higgs masses and mixing angles, see PYPOLE above.
25929
25930 SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
25931 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
25932 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
25933
25934C...Double precision and integer declarations.
25935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25936C...Parameters.
25937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25938 INTEGER PYK,PYCHGE,PYCOMP
25939
25940C...Local variables.
25941 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
25942 &SSBOT2(2),B(2,2),COUPB(2,2),
25943 &HCOUPT(2,2),HCOUPB(2,2),
25944 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
25945
25946 DELTA(1,1) = 1D0
25947 DELTA(2,2) = 1D0
25948 DELTA(1,2) = 0D0
25949 DELTA(2,1) = 0D0
25950 V = 174.1D0
25951 XMZ=91.18D0
25952 PI=3.14159D0
25953 ALP3Z=0.12D0
25954 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
25955
25956C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
25957 RXMT = PYRNMT(XMT)
25958
25959 HT = RXMT /V
25960 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
25961 &XMU,XMH,HM,SA,CA,TANBA)
25962 SINB = TANB/(TANB**2+1D0)**0.5D0
25963 COSB = 1D0/(TANB**2+1D0)**0.5D0
25964 COS2B = SINB**2 - COSB**2
25965 SINBPA = SINB*CA + COSB*SA
25966 COSBPA = COSB*CA - SINB*SA
25967 RMBOT = 3D0
25968 XMQ2 = XMQ**2
25969 XMUR2 = XMUR**2
25970 IF(XMUR.LT.0D0) XMUR2=-XMUR2
25971 XMDR2 = XMDR**2
25972 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
25973 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
25974 IF(XMST11.LT.0D0) GOTO 500
25975 IF(XMST22.LT.0D0) GOTO 500
25976 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
25977 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
25978 IF(XMSB11.LT.0D0) GOTO 500
25979 IF(XMSB22.LT.0D0) GOTO 500
25980 WMST11 = RXMT**2 + XMQ2
25981 WMST22 = RXMT**2 + XMUR2
25982 XMST12 = RXMT*(AT - XMU/TANB)
25983 XMSB12 = RMBOT*(AB - XMU*TANB)
25984
25985CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25986C...STOP EIGENVALUES CALCULATION
25987CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25988
25989 STOP12 = 0.5D0*(XMST11+XMST22) +
25990 &0.5D0*((XMST11+XMST22)**2 -
25991 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
25992 STOP22 = 0.5D0*(XMST11+XMST22) -
25993 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
25994 &XMST12**2))**0.5D0
25995
25996 IF(STOP22.LT.0D0) GOTO 500
25997 SSTOP2(1) = STOP12
25998 SSTOP2(2) = STOP22
25999 STOP1 = STOP12**0.5D0
26000 STOP2 = STOP22**0.5D0
26001 STOP1W = STOP1
26002 STOP2W = STOP2
26003
26004 IF(XMST12.EQ.0D0) XST11 = 1D0
26005 IF(XMST12.EQ.0D0) XST12 = 0D0
26006 IF(XMST12.EQ.0D0) XST21 = 0D0
26007 IF(XMST12.EQ.0D0) XST22 = 1D0
26008
26009 IF(XMST12.EQ.0D0) GOTO 110
26010
26011 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26012 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26013 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26014 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26015
26016 110 T(1,1) = XST11
26017 T(2,2) = XST22
26018 T(1,2) = XST12
26019 T(2,1) = XST21
26020
26021 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
26022 &0.5D0*((XMSB11+XMSB22)**2 -
26023 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
26024 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
26025 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
26026 &XMSB12**2))**0.5D0
26027 IF(SBOT22.LT.0D0) GOTO 500
26028 SBOT1 = SBOT12**0.5D0
26029 SBOT2 = SBOT22**0.5D0
26030
26031 SSBOT2(1) = SBOT12
26032 SSBOT2(2) = SBOT22
26033
26034 IF(XMSB12.EQ.0D0) XSB11 = 1D0
26035 IF(XMSB12.EQ.0D0) XSB12 = 0D0
26036 IF(XMSB12.EQ.0D0) XSB21 = 0D0
26037 IF(XMSB12.EQ.0D0) XSB22 = 1D0
26038
26039 IF(XMSB12.EQ.0D0) GOTO 130
26040
26041 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26042 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26043 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26044 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26045
26046 130 B(1,1) = XSB11
26047 B(2,2) = XSB22
26048 B(1,2) = XSB12
26049 B(2,1) = XSB21
26050
26051
26052 SINT = 0.2320D0
26053 SQR = 2D0**0.5D0
26054 VP = 174.1D0*SQR
26055
26056CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26057C...STARTING OF LIGHT HIGGS
26058CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26059
26060 IF(IHIGGS.EQ.0) GOTO 490
26061
26062 DO 150 I = 1,2
26063 DO 140 J = 1,2
26064 COUPT(I,J) =
26065 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
26066 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26067 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
26068 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
26069 & T(1,J)*T(2,I))
26070 140 CONTINUE
26071 150 CONTINUE
26072
26073
26074 DO 170 I = 1,2
26075 DO 160 J = 1,2
26076 COUPB(I,J) =
26077 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
26078 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26079 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
26080 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
26081 & B(1,J)*B(2,I))
26082 160 CONTINUE
26083 170 CONTINUE
26084
26085 PRUN = XMH
26086 EPS = 1D-4*PRUN
26087 ITER = 0
26088 180 ITER = ITER + 1
26089 DO 230 I3 = 1,3
26090
26091 PR(I3)=PRUN+(I3-2)*EPS/2
26092 P2=PR(I3)**2
26093 POLT = 0D0
26094 DO 200 I = 1,2
26095 DO 190 J = 1,2
26096 POLT = POLT + COUPT(I,J)**2*3D0*
26097 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26098 190 CONTINUE
26099 200 CONTINUE
26100 POLB = 0D0
26101 DO 220 I = 1,2
26102 DO 210 J = 1,2
26103 POLB = POLB + COUPB(I,J)**2*3D0*
26104 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26105 210 CONTINUE
26106 220 CONTINUE
26107 RXMT2 = RXMT**2
26108 XMT2=XMT**2
26109
26110 POLTT =
26111 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26112 & CA**2/SINB**2 *
26113 & (-2D0*XMT**2+0.5D0*P2)*
26114 & PYFINT(P2,XMT2,XMT2)
26115
26116 POL = POLT + POLB + POLTT
26117 POLAR(I3) = P2 - XMH**2 - POL
26118 230 CONTINUE
26119 DERIV = (POLAR(3)-POLAR(1))/EPS
26120 DRUN = - POLAR(2)/DERIV
26121 PRUN = PRUN + DRUN
26122 P2 = PRUN**2
26123 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
26124 GOTO 180
26125 240 CONTINUE
26126
26127 XMHP = P2**0.5D0
26128
26129CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26130C...END OF LIGHT HIGGS
26131CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26132
26133 250 IF(IHIGGS.EQ.1) GOTO 490
26134
26135CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26136C... STARTING OF HEAVY HIGGS
26137CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26138
26139 DO 270 I = 1,2
26140 DO 260 J = 1,2
26141 HCOUPT(I,J) =
26142 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
26143 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26144 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
26145 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
26146 & T(1,J)*T(2,I))
26147 260 CONTINUE
26148 270 CONTINUE
26149
26150 DO 290 I = 1,2
26151 DO 280 J = 1,2
26152 HCOUPB(I,J) =
26153 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
26154 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26155 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
26156 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
26157 & B(1,J)*B(2,I))
26158 HCOUPB(I,J)=0D0
26159 280 CONTINUE
26160 290 CONTINUE
26161
26162 PRUN = HM
26163 EPS = 1D-4*PRUN
26164 ITER = 0
26165 300 ITER = ITER + 1
26166 DO 350 I3 = 1,3
26167 PR(I3)=PRUN+(I3-2)*EPS/2
26168 HP2=PR(I3)**2
26169
26170 HPOLT = 0D0
26171 DO 320 I = 1,2
26172 DO 310 J = 1,2
26173 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
26174 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26175 310 CONTINUE
26176 320 CONTINUE
26177
26178 HPOLB = 0D0
26179 DO 340 I = 1,2
26180 DO 330 J = 1,2
26181 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
26182 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26183 330 CONTINUE
26184 340 CONTINUE
26185
26186 RXMT2 = RXMT**2
26187 XMT2 = XMT**2
26188
26189 HPOLTT =
26190 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26191 & SA**2/SINB**2 *
26192 & (-2D0*XMT**2+0.5D0*HP2)*
26193 & PYFINT(HP2,XMT2,XMT2)
26194
26195 HPOL = HPOLT + HPOLB + HPOLTT
26196 POLAR(I3) =HP2-HM**2-HPOL
26197 350 CONTINUE
26198 DERIV = (POLAR(3)-POLAR(1))/EPS
26199 DRUN = - POLAR(2)/DERIV
26200 PRUN = PRUN + DRUN
26201 HP2 = PRUN**2
26202 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
26203 GOTO 300
26204 360 CONTINUE
26205
26206
26207 370 CONTINUE
26208 HMP = HP2**0.5D0
26209
26210CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26211C... END OF HEAVY HIGGS
26212CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26213
26214 IF(IHIGGS.EQ.2) GOTO 490
26215
26216CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26217C...BEGINNING OF PSEUDOSCALAR HIGGS
26218CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26219
26220 DO 390 I = 1,2
26221 DO 380 J = 1,2
26222 ACOUPT(I,J) =
26223 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
26224 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
26225 380 CONTINUE
26226 390 CONTINUE
26227 DO 410 I = 1,2
26228 DO 400 J = 1,2
26229 ACOUPB(I,J) =
26230 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
26231 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
26232 400 CONTINUE
26233 410 CONTINUE
26234
26235 PRUN = XMA
26236 EPS = 1D-4*PRUN
26237 ITER = 0
26238 420 ITER = ITER + 1
26239 DO 470 I3 = 1,3
26240 PR(I3)=PRUN+(I3-2)*EPS/2
26241 AP2=PR(I3)**2
26242 APOLT = 0D0
26243 DO 440 I = 1,2
26244 DO 430 J = 1,2
26245 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
26246 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26247 430 CONTINUE
26248 440 CONTINUE
26249 APOLB = 0D0
26250 DO 460 I = 1,2
26251 DO 450 J = 1,2
26252 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
26253 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26254 450 CONTINUE
26255 460 CONTINUE
26256 RXMT2 = RXMT**2
26257 XMT2=XMT**2
26258 APOLTT =
26259 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26260 & COSB**2/SINB**2 *
26261 & (-0.5D0*AP2)*
26262 & PYFINT(AP2,XMT2,XMT2)
26263 APOL = APOLT + APOLB + APOLTT
26264 POLAR(I3) = AP2 - XMA**2 -APOL
26265 470 CONTINUE
26266 DERIV = (POLAR(3)-POLAR(1))/EPS
26267 DRUN = - POLAR(2)/DERIV
26268 PRUN = PRUN + DRUN
26269 AP2 = PRUN**2
26270 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
26271 GOTO 420
26272 480 CONTINUE
26273
26274 AMP = AP2**0.5D0
26275
26276CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26277C...END OF PSEUDOSCALAR HIGGS
26278CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26279
26280 IF(IHIGGS.EQ.3) GOTO 490
26281
26282 490 CONTINUE
26283 RETURN
26284 500 CONTINUE
26285 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
26286 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
26287 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
26288 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
26289 STOP
26290 END
26291
26292C*********************************************************************
26293
26294C...PYRGHM
26295C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26296
26297 SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
26298 &XMHP,HMP,SA,CA,TANBA)
26299
26300C...Double precision and integer declarations.
26301 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26302 INTEGER PYK,PYCHGE,PYCOMP
26303
26304C...Local variables.
26305 DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
26306
26307 XMZ = 91.18D0
26308 ALP1 = 0.0101D0
26309 ALP2 = 0.0337D0
26310 ALP3Z = 0.12D0
26311 V = 174.1D0
26312 PI = 3.14159D0
26313 TANBA = TANB
26314 TANBT = TANB
26315
26316C...MBOTTOM(XMT) = 3. GEV
26317 XMB = 3D0
26318 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
26319 &LOG(XMT**2/XMZ**2))
26320
26321C...RXMT= RUNNING TOP QUARK MASS
26322 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26323 TQ = LOG((XMQ**2+XMT**2)/XMT**2)
26324 TU = LOG((XMUR**2 + XMT**2)/XMT**2)
26325 TD = LOG((XMDL**2 + XMT**2)/XMT**2)
26326 SINB = TANB/((1D0 + TANB**2)**0.5D0)
26327 COSB = SINB/TANB
26328 IF(XMA.GT.XMT)
26329 &TANBA = TANB*(1D0-3D0/32D0/PI**2*
26330 &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
26331 &LOG(XMA**2/XMT**2))
26332 IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
26333 SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
26334 COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
26335 COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
26336 G1 = (ALP1*4D0*PI)**0.5D0
26337 G2 = (ALP2*4D0*PI)**0.5D0
26338 G3 = (ALP3*4D0*PI)**0.5D0
26339 HU = RXMT/V/SINB
26340 HD = XMB/V/COSB
26341
26342 CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
26343 &XMU,VH,STOP1,STOP2)
26344
26345 IF(XMQ.GT.XMUR) TP = TQ - TU
26346 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
26347 IF(XMQ.GT.XMUR) TDP = TU
26348 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
26349 IF(XMQ.GT.XMDL) TPD = TQ - TD
26350 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
26351 IF(XMQ.GT.XMDL) TDPD = TD
26352 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
26353
26354 IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
26355 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
26356 &HD**2*(G1**2/3D0+G2**2)*TPD
26357
26358 IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
26359 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
26360 &HU**2*(-G1**2/3D0+G2**2)*TP
26361
26362 DLAM3 = 0D0
26363 DLAM4 = 0D0
26364
26365 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
26366 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
26367 &(G2**2-G1**2/3D0)*TPD
26368
26369 IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
26370 &1D0/16D0/PI**2*G1**2*HU**2*TP
26371 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
26372 &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
26373
26374 IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
26375 IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
26376 &HD**2*TPD
26377
26378 XLAM1 = ((G1**2 + G2**2)/4D0)*
26379 &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
26380 &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
26381 &+ (3D0*HD**2/2D0 + HU**2/2D0
26382 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
26383 &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
26384 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
26385 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
26386 &(TP + TDP)/8D0/PI**2)
26387 &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
26388 &+ (3D0*HU**2/2D0 + HD**2/2D0
26389 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
26390 &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
26391 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
26392 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
26393 &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
26394 &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
26395 XLAM4 = (- G2**2/2D0)*(1D0
26396 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
26397 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
26398
26399 XLAM5 = 0D0
26400 XLAM6 = 0D0
26401 XLAM7 = 0D0
26402
26403 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
26404 &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
26405
26406 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
26407 &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
26408 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
26409 &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
26410
26411 XM2(2,1) = XM2(1,2)
26412
26413CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26414C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
26415CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26416
26417 XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
26418
26419 IF(XMC.GT.XMSSU) GOTO 100
26420 IF(XMC.LT.XMT) XMC=XMT
26421
26422 TCHAR=LOG(XMSSU**2/XMC**2)
26423
26424 DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
26425 DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
26426 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
26427
26428 DEM112=2D0*DEL12*V**2*COSB**2
26429 DEM222=2D0*DEL12*V**2*SINB**2
26430 DEM122=2D0*DEL3P4*V**2*SINB*COSB
26431
26432 XM2(1,1)=XM2(1,1)+DEM112
26433 XM2(2,2)=XM2(2,2)+DEM222
26434 XM2(1,2)=XM2(1,2)+DEM122
26435 XM2(2,1)=XM2(2,1)+DEM122
26436
26437 100 CONTINUE
26438
26439CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26440C...END OF CHARGINOS/NEUTRALINOS
26441CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26442
26443 DO 120 I = 1,2
26444 DO 110 J = 1,2
26445 XM2P(I,J) = XM2(I,J) + VH(I,J)
26446 110 CONTINUE
26447 120 CONTINUE
26448
26449 TRM2P = XM2P(1,1) + XM2P(2,2)
26450 DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
26451
26452 XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26453 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26454 HMP = HM2P**0.5D0
26455 IF(XMH2P.LT.0D0) GOTO 130
26456 XMHP = XMH2P**0.5D0
26457 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
26458 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
26459 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
26460 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
26461 SA = SIN(ALP)
26462 CA = COS(ALP)
26463 SQBMA = (SINB*CA - COSB*SA)**2
26464 130 XIN = 1D0
26465 140 CONTINUE
26466
26467 RETURN
26468 END
26469
26470C*********************************************************************
26471
26472C...PYGFXX
26473C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
26474
26475 SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
26476 &STOP1,STOP2)
26477
26478C...Double precision and integer declarations.
26479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26480 INTEGER PYK,PYCHGE,PYCOMP
26481
26482C...Local variables.
26483 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
26484 &VH3T(2,2),VH3B(2,2),
26485 &HMIX(2,2),AL(2,2),XM2(2,2)
26486
26487C...Statement function.
26488 G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
26489
26490 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
26491 XMQ2 = XMQ**2
26492 XMUR2 = XMUR**2
26493 XMDL2 = XMDL**2
26494 TANBA = TANB
26495 SINBA = TANBA/(TANBA**2+1D0)**0.5D0
26496 COSBA = SINBA/TANBA
26497
26498 SINB = TANB/(TANB**2+1D0)**0.5D0
26499 COSB = SINB/TANB
26500 PI = 3.14159D0
26501 G2 = (0.0336D0*4D0*PI)**0.5D0
26502 G12 = (0.0101D0*4D0*PI)
26503 G1 = G12**0.5D0
26504 XMZ = 91.18D0
26505 V = 174.1D0
26506 MW = (G2**2*V**2/2D0)**0.5D0
26507 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
26508
26509 XMB = 3D0
26510 IF(XMQ.GT.XMUR) XMST = XMQ
26511 IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
26512
26513 XMSUT = (XMST**2 + XMT**2)**0.5D0
26514
26515 IF(XMQ.GT.XMDL) XMSB = XMQ
26516 IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
26517
26518 XMSUB = (XMSB**2 + XMB**2)**0.5D0
26519
26520 TT = LOG(XMSUT**2/XMT**2)
26521 TB = LOG(XMSUB**2/XMT**2)
26522
26523 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26524 HT = RXMT/(174.1D0*SINB)
26525 HTST = RXMT/174.1D0
26526 HB = XMB/174.1D0/COSB
26527 G32 = ALP3*4D0*PI
26528 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
26529 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
26530 AL2 = 3D0/8D0/PI**2*HT**2
26531 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
26532 ALST = 3D0/8D0/PI**2*HTST**2
26533 AL1 = 3D0/8D0/PI**2*HB**2
26534
26535 AL(1,1) = AL1
26536 AL(1,2) = (AL2+AL1)/2D0
26537 AL(2,1) = (AL2+AL1)/2D0
26538 AL(2,2) = AL2
26539
26540 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
26541 XMT2 = SQRT(XMT4)
26542 XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
26543 XMBOT2 = SQRT(XMBOT4)
26544
26545 IF(XMA.GT.XMT) THEN
26546 VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
26547 & LOG(XMT**2/XMA**2))
26548 H1I = VI* COSBA
26549 H2I = VI*SINBA
26550 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
26551 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
26552 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
26553 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
26554 ELSE
26555 VI = 174.1D0
26556 H1I = VI*COSB
26557 H2I = VI*SINB
26558 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
26559 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
26560 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
26561 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
26562 ENDIF
26563
26564 TANBST = H2T/H1T
26565 SINBT = TANBST/(1D0+TANBST**2)**0.5D0
26566 COSBT = SINBT/TANBST
26567
26568 TANBSB = H2B/H1B
26569 SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
26570 COSBB = SINBB/TANBSB
26571
26572 STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26573 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26574 &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26575 &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
26576 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26577 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26578 &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26579 &XMQ2 - XMUR2)**2*0.25D0
26580 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
26581 IF(STOP22.LT.0D0) GOTO 120
26582 SBOT12 = (XMQ2 + XMDL2)*0.5D0
26583 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26584 &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26585 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26586 SBOT22 = (XMQ2 + XMDL2)*0.5D0
26587 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26588 &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26589 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26590 IF(SBOT22.LT.0D0) GOTO 120
26591
26592 STOP1 = STOP12**0.5D0
26593 STOP2 = STOP22**0.5D0
26594 SBOT1 = SBOT12**0.5D0
26595 SBOT2 = SBOT22**0.5D0
26596
26597 VH1(1,1) = 1D0/TANBST
26598 VH1(2,1) = -1D0
26599 VH1(1,2) = -1D0
26600 VH1(2,2) = TANBST
26601 VH2(1,1) = TANBST
26602 VH2(1,2) = -1D0
26603 VH2(2,1) = -1D0
26604 VH2(2,2) = 1D0/TANBST
26605
26606CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26607C...D-TERMS
26608CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26609 STW=0.2320D0
26610
26611 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
26612 &LOG(STOP1/STOP2)
26613 &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
26614 &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
26615
26616 F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
26617 &LOG(SBOT1/SBOT2)
26618 &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
26619 &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
26620
26621 F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
26622 &(-0.5D0*LOG(STOP12/STOP22)
26623 &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
26624 &G(STOP12,STOP22))
26625
26626 F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
26627 &(0.5D0*LOG(SBOT12/SBOT22)
26628 &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
26629 &G(SBOT12,SBOT22))
26630
26631 VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
26632 &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
26633 &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
26634 &LOG(SBOT1**2/SBOT2**2)) +
26635 &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
26636 &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
26637
26638 VH3T(1,1) =
26639 &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
26640 &-STOP2**2))**2*G(STOP12,STOP22)
26641
26642 VH3B(1,1)=VH3B(1,1)+
26643 &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
26644
26645 VH3T(1,1) = VH3T(1,1) +
26646 &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
26647
26648 VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
26649 &(XMQ2+XMT2)/(XMUR2+XMT2))
26650 &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
26651 &LOG(STOP1**2/STOP2**2)) +
26652 &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
26653 &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
26654
26655 VH3B(2,2) =
26656 &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
26657 &-SBOT2**2))**2*G(SBOT12,SBOT22)
26658
26659 VH3T(2,2)=VH3T(2,2)+
26660 &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
26661
26662 VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
26663
26664 VH3T(1,2) = -
26665 &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
26666 &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
26667 &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
26668
26669 VH3B(1,2) =
26670 &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
26671 &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
26672 &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
26673
26674 VH3T(1,2)=VH3T(1,2) +
26675 &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
26676
26677 VH3B(1,2)=VH3B(1,2)
26678 &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
26679
26680 VH3T(2,1) = VH3T(1,2)
26681 VH3B(2,1) = VH3B(1,2)
26682
26683 TQ = LOG((XMQ2 + XMT2)/XMT2)
26684 TU = LOG((XMUR2+XMT2)/XMT2)
26685 TQD = LOG((XMQ2 + XMB**2)/XMB**2)
26686 TD = LOG((XMDL2+XMB**2)/XMB**2)
26687
26688 DO 110 I = 1,2
26689 DO 100 J = 1,2
26690
26691 VH(I,J) =
26692 & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
26693 & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
26694 & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
26695 & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
26696
26697 100 CONTINUE
26698 110 CONTINUE
26699
26700 GOTO 150
26701 120 DO 140 I =1,2
26702 DO 130 J = 1,2
26703 VH(I,J) = -1D+15
26704 130 CONTINUE
26705 140 CONTINUE
26706
26707 150 CONTINUE
26708
26709 RETURN
26710 END
26711
26712C*********************************************************************
26713
26714C...PYFINT
26715C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26716
26717 FUNCTION PYFINT(A,B,C)
26718
26719C...Double precision and integer declarations.
26720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26721 INTEGER PYK,PYCHGE,PYCOMP
26722C...Commonblock.
26723 COMMON/PYINTS/XXM(20)
26724 SAVE/PYINTS/
26725
26726C...Local variables.
26727 EXTERNAL PYFISB
26728
26729 XXM(1)=A
26730 XXM(2)=B
26731 XXM(3)=C
26732 XLO=0D0
26733 XHI=1D0
26734 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
26735
26736 RETURN
26737 END
26738
26739C*********************************************************************
26740
26741C...PYFISB
26742C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
26743
26744 FUNCTION PYFISB(X)
26745
26746C...Double precision and integer declarations.
26747 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26748 INTEGER PYK,PYCHGE,PYCOMP
26749C...Commonblock.
26750 COMMON/PYINTS/XXM(20)
26751 SAVE/PYINTS/
26752
26753 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
26754 &(X*(XXM(2)-XXM(3))+XXM(3)))
26755
26756 RETURN
26757 END
26758
26759C*********************************************************************
26760
26761C...PYSFDC
26762C...Calculates decays of sfermions.
26763
26764 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
26765
26766C...Double precision and integer declarations.
26767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26768 INTEGER PYK,PYCHGE,PYCOMP
26769C...Parameter statement to help give large particle numbers.
26770 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
26771C...Commonblocks.
26772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26774 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
26775 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
26776 &SFMIX(16,4)
26777 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
26778
26779C...Local variables.
26780 INTEGER KFIN,KCIN
26781 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
26782 &XMZ2,AXMJ,AXMI
26783 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
26784 DOUBLE PRECISION PYLAMF,XL
26785 DOUBLE PRECISION TANW,XW,AEM,C1,AS
26786 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
26787 DOUBLE PRECISION CH1,CH2,CH3,CH4
26788 DOUBLE PRECISION XMBOT,XMTOP
26789 DOUBLE PRECISION XLAM(0:200)
26790 INTEGER IDLAM(200,3)
26791 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
26792 DOUBLE PRECISION SR2
26793 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
26794 DOUBLE PRECISION CW
26795 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
26796 DOUBLE PRECISION COSA,SINA,TANB
26797 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
26798 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
26799 INTEGER IG,KF1,KF2,ILR2,IDP
26800 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
26801 DATA IGG/23,25,35,36/
26802 DATA PI/3.141592654D0/
26803 DATA SR2/1.4142136D0/
26804 DATA KFNCHI/1000022,1000023,1000025,1000035/
26805 DATA KFCCHI/1000024,1000037/
26806
26807C...COUNT THE NUMBER OF DECAY MODES
26808 LKNT=0
26809
26810C...NO NU_R DECAYS
26811 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
26812 &KFIN.EQ.KSUSY2+16) RETURN
26813
26814 XMW=PMAS(24,1)
26815 XMW2=XMW**2
26816 XMZ=PMAS(23,1)
26817 XMZ2=XMZ**2
26818 XW=PARU(102)
26819 TANW = SQRT(XW/(1D0-XW))
26820 CW=SQRT(1D0-XW)
26821
26822C...KCIN
26823 KCIN=PYCOMP(KFIN)
26824C...ILR is 1 for left and 2 for right.
26825 ILR=KFIN/KSUSY1
26826C...IFL is matching non-SUSY flavour.
26827 IFL=MOD(KFIN,KSUSY1)
26828C...IDU is weak isospin, 1 for down and 2 for up.
26829 IDU=2-MOD(IFL,2)
26830
26831 XMI=PMAS(KCIN,1)
26832 XMI2=XMI**2
26833 AEM=PYALEM(XMI2)
26834 AS =PYALPS(XMI2)
26835 C1=AEM/XW
26836 XMI3=XMI**3
26837 EI=KCHG(IFL,1)/3D0
26838
26839 XMBOT=3D0
26840 XMTOP=PYRNMT(PMAS(6,1))
26841 XMBOT=0D0
26842
26843 TANB=RMSS(5)
26844 BETA=ATAN(TANB)
26845 ALFA=RMSS(18)
26846 CBETA=COS(BETA)
26847 SBETA=TANB*CBETA
26848 SINA=SIN(ALFA)
26849 COSA=COS(ALFA)
26850 XMU=-RMSS(4)
26851 ATRIT=RMSS(16)
26852 ATRIB=RMSS(15)
26853 ATRIL=RMSS(17)
26854
26855C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
26856
26857 IF(IMSS(11).EQ.1) THEN
26858 XMP=RMSS(28)
26859 IDG=39+KSUSY1
26860 XMGR=PMAS(PYCOMP(IDG),1)
26861 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
26862 IF(IFL.EQ.5) THEN
26863 XMF=XMBOT
26864 ELSEIF(IFL.EQ.6) THEN
26865 XMF=XMTOP
26866 ELSE
26867 XMF=PMAS(IFL,1)
26868 ENDIF
26869 IF(XMI.GT.XMGR+XMF) THEN
26870 LKNT=LKNT+1
26871 IDLAM(LKNT,1)=IDG
26872 IDLAM(LKNT,2)=IFL
26873 IDLAM(LKNT,3)=0
26874 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
26875 ENDIF
26876 ENDIF
26877
26878C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
26879
26880C...CHARGED DECAYS:
26881 DO 100 IX=1,2
26882C...DI -> U CHI1-,CHI2-
26883 IF(IDU.EQ.1) THEN
26884 XMFP=PMAS(IFL+1,1)
26885 XMF =PMAS(IFL,1)
26886C...UI -> D CHI1+,CHI2+
26887 ELSE
26888 XMFP=PMAS(IFL-1,1)
26889 XMF =PMAS(IFL,1)
26890 ENDIF
26891 XMJ=SMW(IX)
26892 AXMJ=ABS(XMJ)
26893 IF(XMI.GE.AXMJ+XMFP) THEN
26894 XMA2=XMJ**2
26895 XMB2=XMFP**2
26896 IF(IDU.EQ.2) THEN
26897 IF(IFL.EQ.6) THEN
26898 XMFP=XMBOT
26899 XMF =XMTOP
26900 ELSEIF(IFL.LT.6) THEN
26901 XMF=0D0
26902 XMFP=0D0
26903 ENDIF
26904 BL=VMIX(IX,1)
26905 AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
26906 BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
26907 AR=0D0
26908 ELSE
26909 IF(IFL.EQ.5) THEN
26910 XMF =XMBOT
26911 XMFP=XMTOP
26912 ELSEIF(IFL.LT.5) THEN
26913 XMF=0D0
26914 XMFP=0D0
26915 ENDIF
26916 BL=UMIX(IX,1)
26917 AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
26918 BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
26919 AR=0D0
26920 ENDIF
26921
26922 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
26923 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
26924 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
26925 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
26926 AL=ALP
26927 BL=BLP
26928 AR=ARP
26929 BR=BRP
26930
26931C...F1 -> F` CHI
26932 IF(ILR.EQ.1) THEN
26933 CA=AL
26934 CB=BL
26935C...F2 -> F` CHI
26936 ELSE
26937 CA=AR
26938 CB=BR
26939 ENDIF
26940 LKNT=LKNT+1
26941 XL=PYLAMF(XMI2,XMA2,XMB2)
26942C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
26943 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
26944 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
26945 IDLAM(LKNT,3)=0
26946 IF(IDU.EQ.1) THEN
26947 IDLAM(LKNT,1)=-KFCCHI(IX)
26948 IDLAM(LKNT,2)=IFL+1
26949 ELSE
26950 IDLAM(LKNT,1)=KFCCHI(IX)
26951 IDLAM(LKNT,2)=IFL-1
26952 ENDIF
26953 ENDIF
26954 100 CONTINUE
26955
26956C...NEUTRAL DECAYS
26957 DO 110 IX=1,4
26958C...DI -> D CHI10
26959 XMF=PMAS(IFL,1)
26960 XMJ=SMZ(IX)
26961 AXMJ=ABS(XMJ)
26962 IF(XMI.GE.AXMJ+XMF) THEN
26963 XMA2=XMJ**2
26964 XMB2=XMF**2
26965 IF(IDU.EQ.1) THEN
26966 IF(IFL.EQ.5) THEN
26967 XMF=XMBOT
26968 ELSEIF(IFL.LT.5) THEN
26969 XMF=0D0
26970 ENDIF
26971 BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
26972 AL=XMF*ZMIX(IX,3)/XMW/CBETA
26973 AR=-2D0*EI*TANW*ZMIX(IX,1)
26974 BR=AL
26975 ELSE
26976 IF(IFL.EQ.6) THEN
26977 XMF=XMTOP
26978 ELSEIF(IFL.LT.5) THEN
26979 XMF=0D0
26980 ENDIF
26981 BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
26982 AL=XMF*ZMIX(IX,4)/XMW/SBETA
26983 AR=-2D0*EI*TANW*ZMIX(IX,1)
26984 BR=AL
26985 ENDIF
26986
26987 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
26988 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
26989 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
26990 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
26991 AL=ALP
26992 BL=BLP
26993 AR=ARP
26994 BR=BRP
26995
26996C...F1 -> F CHI
26997 IF(ILR.EQ.1) THEN
26998 CA=AL
26999 CB=BL
27000C...F2 -> F CHI
27001 ELSE
27002 CA=AR
27003 CB=BR
27004 ENDIF
27005 LKNT=LKNT+1
27006 XL=PYLAMF(XMI2,XMA2,XMB2)
27007C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27008 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27009 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27010 IDLAM(LKNT,1)=KFNCHI(IX)
27011 IDLAM(LKNT,2)=IFL
27012 IDLAM(LKNT,3)=0
27013 ENDIF
27014 110 CONTINUE
27015
27016C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
27017C...IG=23,25,35,36
27018 DO 120 II=1,4
27019 IG=IGG(II)
27020 IF(ILR.EQ.1) GOTO 120
27021 XMB=PMAS(IG,1)
27022 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
27023 IF(XMI.LT.XMSF1+XMB) GOTO 120
27024 IF(IG.EQ.23) THEN
27025 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
27026 BR=EI*XW/CW
27027 BLR=0D0
27028 ELSEIF(IG.EQ.25) THEN
27029 IF(IFL.EQ.5) THEN
27030 XMF=XMBOT
27031 ELSEIF(IFL.EQ.6) THEN
27032 XMF=XMTOP
27033 ELSEIF(IFL.LT.5) THEN
27034 XMF=0D0
27035 ELSE
27036 XMF=PMAS(IFL,1)
27037 ENDIF
27038 IF(IDU.EQ.2) THEN
27039 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27040 & XMF**2/XMW*COSA/SBETA
27041 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27042 & XMF**2/XMW*COSA/SBETA
27043 ELSE
27044 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27045 & XMF**2/XMW*(-SINA)/CBETA
27046 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27047 & XMF**2/XMW*(-SINA)/CBETA
27048 ENDIF
27049 IF(IFL.EQ.5) THEN
27050 AT=ATRIB
27051 ELSEIF(IFL.EQ.6) THEN
27052 AT=ATRIT
27053 ELSEIF(IFL.EQ.15) THEN
27054 AT=ATRIL
27055 ELSE
27056 AT=0D0
27057 ENDIF
27058 IF(IDU.EQ.2) THEN
27059 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
27060 & AT*COSA)
27061 ELSE
27062 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
27063 & AT*SINA)
27064 ENDIF
27065 BL=GHLL
27066 BR=GHRR
27067 BLR=-GHLR
27068 ELSEIF(IG.EQ.35) THEN
27069 IF(IFL.EQ.5) THEN
27070 XMF=XMBOT
27071 ELSEIF(IFL.EQ.6) THEN
27072 XMF=XMTOP
27073 ELSEIF(IFL.LT.5) THEN
27074 XMF=0D0
27075 ELSE
27076 XMF=PMAS(IFL,1)
27077 ENDIF
27078 IF(IDU.EQ.2) THEN
27079 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27080 & XMF**2/XMW*SINA/SBETA
27081 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27082 & XMF**2/XMW*SINA/SBETA
27083 ELSE
27084 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27085 & XMF**2/XMW*COSA/CBETA
27086 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27087 & XMF**2/XMW*COSA/CBETA
27088 ENDIF
27089 IF(IFL.EQ.5) THEN
27090 AT=ATRIB
27091 ELSEIF(IFL.EQ.6) THEN
27092 AT=ATRIT
27093 ELSEIF(IFL.EQ.15) THEN
27094 AT=ATRIL
27095 ELSE
27096 AT=0D0
27097 ENDIF
27098 IF(IDU.EQ.2) THEN
27099 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
27100 & AT*SINA)
27101 ELSE
27102 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
27103 & AT*COSA)
27104 ENDIF
27105 BL=GHLL
27106 BR=GHRR
27107 BLR=GHLR
27108 ELSEIF(IG.EQ.36) THEN
27109 GHLL=0D0
27110 GHRR=0D0
27111 IF(IFL.EQ.5) THEN
27112 XMF=XMBOT
27113 ELSEIF(IFL.EQ.6) THEN
27114 XMF=XMTOP
27115 ELSEIF(IFL.LT.5) THEN
27116 XMF=0D0
27117 ELSE
27118 XMF=PMAS(IFL,1)
27119 ENDIF
27120 IF(IFL.EQ.5) THEN
27121 AT=ATRIB
27122 ELSEIF(IFL.EQ.6) THEN
27123 AT=ATRIT
27124 ELSEIF(IFL.EQ.15) THEN
27125 AT=ATRIL
27126 ELSE
27127 AT=0D0
27128 ENDIF
27129 IF(IDU.EQ.2) THEN
27130 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
27131 ELSE
27132 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
27133 ENDIF
27134 BL=GHLL
27135 BR=GHRR
27136 BLR=GHLR
27137 ENDIF
27138 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
27139 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
27140 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
27141 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27142 LKNT=LKNT+1
27143 IF(IG.EQ.23) THEN
27144 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27145 ELSE
27146 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
27147 ENDIF
27148 IDLAM(LKNT,3)=0
27149 IDLAM(LKNT,1)=KFIN-KSUSY1
27150 IDLAM(LKNT,2)=IG
27151 120 CONTINUE
27152
27153C...SF -> SF' + W
27154 XMB=PMAS(24,1)
27155 IF(MOD(IFL,2).EQ.0) THEN
27156 KF1=KSUSY1+IFL-1
27157 ELSE
27158 KF1=KSUSY1+IFL+1
27159 ENDIF
27160 KF2=KF1+KSUSY1
27161 XMSF1=PMAS(PYCOMP(KF1),1)
27162 XMSF2=PMAS(PYCOMP(KF2),1)
27163 IF(XMI.GT.XMB+XMSF1) THEN
27164 IF(MOD(IFL,2).EQ.0) THEN
27165 IF(ILR.EQ.1) THEN
27166 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
27167 ELSE
27168 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
27169 ENDIF
27170 ELSE
27171 IF(ILR.EQ.1) THEN
27172 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
27173 ELSE
27174 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
27175 ENDIF
27176 ENDIF
27177 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27178 LKNT=LKNT+1
27179 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27180 IDLAM(LKNT,3)=0
27181 IDLAM(LKNT,1)=KF1
27182 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27183 ENDIF
27184 IF(XMI.GT.XMB+XMSF2) THEN
27185 IF(MOD(IFL,2).EQ.0) THEN
27186 IF(ILR.EQ.1) THEN
27187 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
27188 ELSE
27189 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
27190 ENDIF
27191 ELSE
27192 IF(ILR.EQ.1) THEN
27193 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
27194 ELSE
27195 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
27196 ENDIF
27197 ENDIF
27198 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
27199 LKNT=LKNT+1
27200 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27201 IDLAM(LKNT,3)=0
27202 IDLAM(LKNT,1)=KF2
27203 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27204 ENDIF
27205
27206C...SF -> SF' + HC
27207 XMB=PMAS(37,1)
27208 IF(MOD(IFL,2).EQ.0) THEN
27209 KF1=KSUSY1+IFL-1
27210 ELSE
27211 KF1=KSUSY1+IFL+1
27212 ENDIF
27213 KF2=KF1+KSUSY1
27214 XMSF1=PMAS(PYCOMP(KF1),1)
27215 XMSF2=PMAS(PYCOMP(KF2),1)
27216 IF(XMI.GT.XMB+XMSF1) THEN
27217 XMF=0D0
27218 XMFP=0D0
27219 AT=0D0
27220 AB=0D0
27221 IF(MOD(IFL,2).EQ.0) THEN
27222C...T1-> B1 HC
27223 IF(ILR.EQ.1) THEN
27224 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
27225 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
27226 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
27227 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
27228C...T2-> B1 HC
27229 ELSE
27230 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
27231 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
27232 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
27233 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
27234 ENDIF
27235 IF(IFL.EQ.6) THEN
27236 XMF=XMTOP
27237 XMFP=XMBOT
27238 AT=ATRIT
27239 AB=ATRIB
27240 ENDIF
27241 ELSE
27242C...B1 -> T1 HC
27243 IF(ILR.EQ.1) THEN
27244 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
27245 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
27246 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
27247 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
27248C...B2-> T1 HC
27249 ELSE
27250 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
27251 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
27252 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
27253 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
27254 ENDIF
27255 IF(IFL.EQ.5) THEN
27256 XMF=XMTOP
27257 XMFP=XMBOT
27258 AT=ATRIT
27259 AB=ATRIB
27260 ENDIF
27261 ENDIF
27262 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27263 LKNT=LKNT+1
27264 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27265 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27266 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27267 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27268 IDLAM(LKNT,3)=0
27269 IDLAM(LKNT,1)=KF1
27270 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27271 ENDIF
27272 IF(XMI.GT.XMB+XMSF2) THEN
27273 XMF=0D0
27274 XMFP=0D0
27275 AT=0D0
27276 AB=0D0
27277 IF(MOD(IFL,2).EQ.0) THEN
27278C...T1-> B2 HC
27279 IF(ILR.EQ.1) THEN
27280 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
27281 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
27282 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
27283 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
27284C...T2-> B2 HC
27285 ELSE
27286 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
27287 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
27288 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
27289 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
27290 ENDIF
27291 IF(IFL.EQ.6) THEN
27292 XMF=XMTOP
27293 XMFP=XMBOT
27294 AT=ATRIT
27295 AB=ATRIB
27296 ENDIF
27297 ELSE
27298C...B1 -> T2 HC
27299 IF(ILR.EQ.1) THEN
27300 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
27301 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
27302 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
27303 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
27304C...B2-> T2 HC
27305 ELSE
27306 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
27307 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
27308 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
27309 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
27310 ENDIF
27311 IF(IFL.EQ.5) THEN
27312 XMF=XMTOP
27313 XMFP=XMBOT
27314 AT=ATRIT
27315 AB=ATRIB
27316 ENDIF
27317 ENDIF
27318 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27319 LKNT=LKNT+1
27320 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27321 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27322 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27323 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27324 IDLAM(LKNT,3)=0
27325 IDLAM(LKNT,1)=KF2
27326 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27327 ENDIF
27328
27329C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
27330
27331 IF(IFL.LE.6) THEN
27332 XMFP=0D0
27333 XMF=0D0
27334 IF(IFL.EQ.6) XMF=PMAS(6,1)
27335 IF(IFL.EQ.5) XMF=PMAS(5,1)
27336 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
27337 AXMJ=ABS(XMJ)
27338 IF(XMI.GE.AXMJ+XMF) THEN
27339 AL=-SFMIX(IFL,2)
27340 BL=SFMIX(IFL,1)
27341 AR=-SFMIX(IFL,4)
27342 BR=SFMIX(IFL,3)
27343C...F1 -> F CHI
27344 IF(ILR.EQ.1) THEN
27345 CA=AL
27346 CB=BL
27347C...F2 -> F CHI
27348 ELSE
27349 CA=AR
27350 CB=BR
27351 ENDIF
27352 LKNT=LKNT+1
27353 XMA2=XMJ**2
27354 XMB2=XMF**2
27355 XL=PYLAMF(XMI2,XMA2,XMB2)
27356 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27357 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27358 IDLAM(LKNT,1)=KSUSY1+21
27359 IDLAM(LKNT,2)=IFL
27360 IDLAM(LKNT,3)=0
27361 ENDIF
27362 ENDIF
27363
27364C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
27365 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
27366 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
27367C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
27368C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
27369C...M*M = C1**2 * G**2/(16PI**2)
27370C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
27371 LKNT=LKNT+1
27372 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
27373 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
27374 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
27375 IDLAM(LKNT,1)=KSUSY1+22
27376 IDLAM(LKNT,2)=4
27377 IDLAM(LKNT,3)=0
27378 ENDIF
27379
27380 IKNT=LKNT
27381 XLAM(0)=0D0
27382 DO 130 I=1,IKNT
27383 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27384 XLAM(0)=XLAM(0)+XLAM(I)
27385 130 CONTINUE
27386 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
27387
27388 RETURN
27389 END
27390
27391C*********************************************************************
27392
27393C...PYGLUI
27394C...Calculates gluino decay modes.
27395
27396 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
27397
27398C...Double precision and integer declarations.
27399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27400 INTEGER PYK,PYCHGE,PYCOMP
27401C...Parameter statement to help give large particle numbers.
27402 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27403C...Commonblocks.
27404 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27405 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27406 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27407 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27408 &SFMIX(16,4)
27409 COMMON/PYINTS/XXM(20)
27410 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
27411
27412C...Local variables.
27413 INTEGER KFIN,KCIN,KF
27414 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
27415 &XMZ,XMZ2,AXMJ,AXMI
27416 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
27417 DOUBLE PRECISION C1L,C1R,D1L,D1R
27418 DOUBLE PRECISION C2L,C2R,D2L,D2R
27419 DOUBLE PRECISION PYLAMF,XL
27420 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
27421 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
27422 DOUBLE PRECISION ALFA,BETA
27423 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
27424 DOUBLE PRECISION XLAM(0:200)
27425 INTEGER IDLAM(200,3)
27426 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
27427 DOUBLE PRECISION SR2
27428 DOUBLE PRECISION GAM
27429 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
27430 DOUBLE PRECISION PYGAUS
27431 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
27432 DOUBLE PRECISION PREC
27433 INTEGER KFNCHI(4),KFCCHI(2)
27434 DATA PI/3.141592654D0/
27435 DATA SR2/1.4142136D0/
27436 DATA PREC/1D-2/
27437 DATA KFNCHI/1000022,1000023,1000025,1000035/
27438 DATA KFCCHI/1000024,1000037/
27439
27440C...COUNT THE NUMBER OF DECAY MODES
27441 LKNT=0
27442 IF(KFIN.NE.KSUSY1+21) RETURN
27443 KCIN=PYCOMP(KFIN)
27444
27445 XMW=PMAS(24,1)
27446 XMW2=XMW**2
27447 XMZ=PMAS(23,1)
27448 XMZ2=XMZ**2
27449 XW=PARU(102)
27450 TANW = SQRT(XW/(1D0-XW))
27451
27452 XMI=PMAS(KCIN,1)
27453 AXMI=ABS(XMI)
27454 XMI2=XMI**2
27455 AEM=PYALEM(XMI2)
27456 AS =PYALPS(XMI2)
27457 C1=AEM/XW
27458 XMI3=XMI**3
27459 BETA=ATAN(RMSS(5))
27460
27461C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
27462
27463 IF(IMSS(11).EQ.1) THEN
27464 XMP=RMSS(28)
27465 IDG=39+KSUSY1
27466 XMGR=PMAS(PYCOMP(IDG),1)
27467 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27468 IF(AXMI.GT.XMGR) THEN
27469 LKNT=LKNT+1
27470 IDLAM(LKNT,1)=IDG
27471 IDLAM(LKNT,2)=21
27472 IDLAM(LKNT,3)=0
27473 XLAM(LKNT)=XFAC
27474 ENDIF
27475 ENDIF
27476
27477C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
27478
27479 DO 110 IFL=1,6
27480 DO 100 ILR=1,2
27481 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
27482 AXMJ=ABS(XMJ)
27483 XMF=PMAS(IFL,1)
27484 IDU=3-(1+MOD(IFL,2))
27485 IF(XMI.GE.AXMJ+XMF) THEN
27486 AL=SFMIX(IFL,1)
27487 BL=SFMIX(IFL,2)
27488 AR=SFMIX(IFL,3)
27489 BR=SFMIX(IFL,4)
27490C...F1 -> F CHI
27491 IF(ILR.EQ.1) THEN
27492 CA=AL
27493 CB=BL
27494C...F2 -> F CHI
27495 ELSE
27496 CA=AR
27497 CB=BR
27498 ENDIF
27499 LKNT=LKNT+1
27500 XMA2=XMJ**2
27501 XMB2=XMF**2
27502 XL=PYLAMF(XMI2,XMA2,XMB2)
27503 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
27504 & (CA**2+CB**2)+4D0*CA*CB*XMI*XMF)
27505 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
27506 IDLAM(LKNT,2)=-IFL
27507 IDLAM(LKNT,3)=0
27508 LKNT=LKNT+1
27509 XLAM(LKNT)=XLAM(LKNT-1)
27510 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27511 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27512 IDLAM(LKNT,3)=0
27513 ENDIF
27514 100 CONTINUE
27515 110 CONTINUE
27516
27517C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
27518C...GLUINO -> NI Q QBAR
27519 DO 160 IX=1,4
27520 XMJ=SMZ(IX)
27521 AXMJ=ABS(XMJ)
27522 IF(XMI.GE.AXMJ) THEN
27523 XXM(1)=0D0
27524 XXM(2)=XMJ
27525 XXM(3)=0D0
27526 XXM(4)=XMI
27527 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
27528 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
27529 XXM(7)=1D6
27530 XXM(8)=0D0
27531 XXM(9)=0D0
27532 XXM(10)=0D0
27533 S12MIN=0D0
27534 S12MAX=(XMI-AXMJ)**2
27535C...D-TYPE QUARKS
27536 XXM(11)=0D0
27537 XXM(12)=0D0
27538 XXM(13)=1D0
27539 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27540 XXM(15)=1D0
27541 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
27542 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
27543 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
27544 LKNT=LKNT+1
27545 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27546 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27547 IDLAM(LKNT,1)=KFNCHI(IX)
27548 IDLAM(LKNT,2)=1
27549 IDLAM(LKNT,3)=-1
27550 ENDIF
27551 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
27552 LKNT=LKNT+1
27553 XLAM(LKNT)=XLAM(LKNT-1)
27554 IDLAM(LKNT,1)=KFNCHI(IX)
27555 IDLAM(LKNT,2)=3
27556 IDLAM(LKNT,3)=-3
27557 ENDIF
27558 120 CONTINUE
27559 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
27560 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
27561 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
27562 LKNT=LKNT+1
27563 XLAM(LKNT)=GAM
27564 IDLAM(LKNT,1)=KFNCHI(IX)
27565 IDLAM(LKNT,2)=5
27566 IDLAM(LKNT,3)=-5
27567 ENDIF
27568C...U-TYPE QUARKS
27569 130 CONTINUE
27570 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
27571 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
27572 XXM(13)=1D0
27573 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27574 XXM(15)=1D0
27575 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
27576 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
27577 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
27578 LKNT=LKNT+1
27579 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27580 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27581 IDLAM(LKNT,1)=KFNCHI(IX)
27582 IDLAM(LKNT,2)=2
27583 IDLAM(LKNT,3)=-2
27584 ENDIF
27585 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
27586 LKNT=LKNT+1
27587 XLAM(LKNT)=XLAM(LKNT-1)
27588 IDLAM(LKNT,1)=KFNCHI(IX)
27589 IDLAM(LKNT,2)=4
27590 IDLAM(LKNT,3)=-4
27591 ENDIF
27592 140 CONTINUE
27593C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
27594C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
27595 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
27596 XMF=PMAS(6,1)
27597 IF(XMI.GE.AXMJ+2D0*XMF) THEN
27598 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
27599 LKNT=LKNT+1
27600 XLAM(LKNT)=GAM
27601 IDLAM(LKNT,1)=KFNCHI(IX)
27602 IDLAM(LKNT,2)=6
27603 IDLAM(LKNT,3)=-6
27604 ENDIF
27605 150 CONTINUE
27606 ENDIF
27607 160 CONTINUE
27608
27609C...GLUINO -> CI Q QBAR'
27610 DO 190 IX=1,2
27611 XMJ=SMW(IX)
27612 AXMJ=ABS(XMJ)
27613 IF(XMI.GE.AXMJ) THEN
27614 S12MIN=0D0
27615 S12MAX=(AXMI-AXMJ)**2
27616 XXM(1)=0D0
27617 XXM(2)=XMJ
27618 XXM(3)=0D0
27619 XXM(4)=XMI
27620 XXM(5)=0D0
27621 XXM(6)=0D0
27622 XXM(9)=1D6
27623 XXM(10)=0D0
27624 XXM(7)=UMIX(IX,1)*SR2
27625 XXM(8)=VMIX(IX,1)*SR2
27626 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
27627 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
27628 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
27629 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
27630 LKNT=LKNT+1
27631 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
27632 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
27633 IDLAM(LKNT,1)=KFCCHI(IX)
27634 IDLAM(LKNT,2)=1
27635 IDLAM(LKNT,3)=-2
27636 LKNT=LKNT+1
27637 XLAM(LKNT)=XLAM(LKNT-1)
27638 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27639 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27640 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27641 ENDIF
27642 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
27643 LKNT=LKNT+1
27644 XLAM(LKNT)=XLAM(LKNT-1)
27645 IDLAM(LKNT,1)=KFCCHI(IX)
27646 IDLAM(LKNT,2)=3
27647 IDLAM(LKNT,3)=-4
27648 LKNT=LKNT+1
27649 XLAM(LKNT)=XLAM(LKNT-1)
27650 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27651 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27652 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27653 ENDIF
27654 170 CONTINUE
27655
27656 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
27657 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
27658 XMF=PMAS(6,1)
27659 XMFP=PMAS(5,1)
27660 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
27661 CALL PYTBBC(IX,80,AXMI,GAM)
27662 LKNT=LKNT+1
27663 XLAM(LKNT)=GAM
27664 IDLAM(LKNT,1)=KFCCHI(IX)
27665 IDLAM(LKNT,2)=5
27666 IDLAM(LKNT,3)=-6
27667 LKNT=LKNT+1
27668 XLAM(LKNT)=XLAM(LKNT-1)
27669 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27670 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27671 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27672 ENDIF
27673 180 CONTINUE
27674 ENDIF
27675 190 CONTINUE
27676
27677 IKNT=LKNT
27678 XLAM(0)=0D0
27679 DO 200 I=1,IKNT
27680 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27681 XLAM(0)=XLAM(0)+XLAM(I)
27682 200 CONTINUE
27683 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
27684
27685 RETURN
27686 END
27687
27688C*********************************************************************
27689
27690C...PYTBBN
27691C...Calculates the three-body decay of gluinos into
27692C...neutralinos and third generation fermions.
27693
27694 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
27695
27696C...Double precision and integer declarations.
27697 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27698 INTEGER PYK,PYCHGE,PYCOMP
27699C...Parameter statement to help give large particle numbers.
27700 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27701C...Commonblocks.
27702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27704 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27705 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27706 &SFMIX(16,4)
27707 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27708
27709C...Local variables.
27710 EXTERNAL PYSIMP,PYLAMF
27711 INTEGER LIN,NN
27712 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
27713 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
27714 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
27715 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
27716 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
27717 DOUBLE PRECISION XLN1,XLN2,B1,B2
27718 DOUBLE PRECISION E,XMGLU,GAM
27719 DOUBLE PRECISION PYSIMP,PYLAMF
27720 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
27721 SAVE HRB,HLB,FLB,FRB
27722 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27723 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
27724 SAVE HLT,HRT,FLT,FRT
27725 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
27726 &FLD(4),FRD(4)
27727 SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
27728 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27729 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27730 SAVE AMSB,AMST
27731 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27732 DOUBLE PRECISION ROT1(4,4)
27733 LOGICAL IFIRST
27734 SAVE IFIRST
27735 DATA IFIRST/.TRUE./
27736
27737 TANB=RMSS(5)
27738 SINB=TANB/SQRT(1D0+TANB**2)
27739 COSB=SINB/TANB
27740 XW=PARU(102)
27741 SINW=SQRT(XW)
27742 COSW=SQRT(1D0-XW)
27743 TANW=SINW/COSW
27744 AMW=PMAS(24,1)
27745 COSC=SFMIX(5,1)
27746 SINC=SFMIX(5,3)
27747 COSA=SFMIX(6,1)
27748 SINA=SFMIX(6,3)
27749 AMBOT=0D0
27750 AMTOP=PYRNMT(PMAS(6,1))
27751 W2=SQRT(2D0)
27752 FAKT1=AMBOT/W2/AMW/COSB
27753 FAKT2=AMTOP/W2/AMW/SINB
27754 IF(IFIRST) THEN
27755 DO 110 II=1,4
27756 AMN(II)=SMZ(II)
27757 DO 100 J=1,4
27758 ROT1(II,J)=0D0
27759 AN(II,J)=0D0
27760 100 CONTINUE
27761 110 CONTINUE
27762 ROT1(1,1)=COSW
27763 ROT1(1,2)=-SINW
27764 ROT1(2,1)=-ROT1(1,2)
27765 ROT1(2,2)=ROT1(1,1)
27766 ROT1(3,3)=COSB
27767 ROT1(3,4)=SINB
27768 ROT1(4,3)=-ROT1(3,4)
27769 ROT1(4,4)=ROT1(3,3)
27770 DO 140 II=1,4
27771 DO 130 J=1,4
27772 DO 120 JJ=1,4
27773 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
27774 120 CONTINUE
27775 130 CONTINUE
27776 140 CONTINUE
27777 DO 150 J=1,4
27778 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
27779 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27780 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
27781 & XW)*AN(J,2)/COSW
27782 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
27783 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
27784 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
27785 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
27786 FLU(J)=ZN(3)
27787 FRU(J)=ZN(2)
27788 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
27789 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27790 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
27791 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
27792 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
27793 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
27794 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
27795 FLD(J)=ZN(3)
27796 FRD(J)=ZN(2)
27797 150 CONTINUE
27798 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27799 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27800 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27801 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27802 IFIRST=.FALSE.
27803 ENDIF
27804
27805 IF(NINT(3D0*E).EQ.2) THEN
27806 HL=HLT(I)
27807 HR=HRT(I)
27808 FL=FLT(I)
27809 FR=FRT(I)
27810 COSD=SFMIX(6,1)
27811 SIND=SFMIX(6,3)
27812 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
27813 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
27814 XM=PMAS(6,1)
27815 ELSE
27816 HL=HLB(I)
27817 HR=HRB(I)
27818 FL=FLB(I)
27819 FR=FRB(I)
27820 COSD=SFMIX(5,1)
27821 SIND=SFMIX(5,3)
27822 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
27823 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
27824 XM=PMAS(5,1)
27825 ENDIF
27826 COSD2=COSD*COSD
27827 SIND2=SIND*SIND
27828 COS2D=COSD2-SIND2
27829 SIN2D=SIND*COSD*2D0
27830 HL2=HL*HL
27831 HR2=HR*HR
27832 FL2=FL*FL
27833 FR2=FR*FR
27834 FF=FL*FR
27835 HH=HL*HR
27836 HFL=HL*FL
27837 HFR=HR*FR
27838 HRFL=HR*FL
27839 HLFR=HL*FR
27840 XM2=XM*XM
27841 XMG=XMGLU
27842 XMG2=XMG*XMG
27843 ALPHAW=PYALEM(XMG2)
27844 ALPHAS=PYALPS(XMG2)
27845 XMR=AMN(I)
27846 XMR2=XMR*XMR
27847 XMQ4=XMG*XM2*XMR
27848 XM24=(XMG2+XM2)*(XM2+XMR2)
27849 SMIN=4D0*XM2
27850 SMAX=(XMG-ABS(XMR))**2
27851 XMQA=XMG2+2D0*XM2+XMR2
27852 DO 170 LIN=1,NN-1
27853 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
27854 GRS=SBAR-XMQA
27855 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
27856 W=DSQRT(W)
27857 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
27858 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
27859 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
27860 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
27861 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
27862 & +2D0*(FF*SIND2-HH*COSD2))*W
27863 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
27864 & +4D0*HFL*XM*XMR)*XLN1
27865 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
27866 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
27867 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
27868 & +8D0*HFL*XMQ4*SIN2D)*B1
27869 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
27870 & +4D0*HFR*XMR*XM)*XLN2
27871 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
27872 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
27873 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
27874 & -8D0*HFR*XMQ4*SIN2D)*B2
27875 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
27876 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
27877 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
27878 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
27879 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
27880 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
27881 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
27882 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
27883 G(5)=(2D0*(HH*COSD2-FF*SIND2)
27884 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
27885 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
27886 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
27887 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
27888 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
27889 & +COS2D*XM*(SBAR+XMG2-XMR2))
27890 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
27891 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
27892 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
27893 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
27894 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
27895 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
27896 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
27897 SUMME(LIN)=0D0
27898 DO 160 J=0,6
27899 SUMME(LIN)=SUMME(LIN)+G(J)
27900 160 CONTINUE
27901 170 CONTINUE
27902 SUMME(0)=0D0
27903 SUMME(NN)=0D0
27904 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
27905 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
27906
27907 RETURN
27908 END
27909
27910C*********************************************************************
27911
27912C...PYTBBC
27913C...Calculates the three-body decay of gluinos into
27914C...charginos and third generation fermions.
27915
27916 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
27917
27918C...Double precision and integer declarations.
27919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27920 INTEGER PYK,PYCHGE,PYCOMP
27921C...Parameter statement to help give large particle numbers.
27922 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27923C...Commonblocks.
27924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27925 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27926 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27927 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27928 &SFMIX(16,4)
27929 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27930
27931C...Local variables.
27932 EXTERNAL PYSIMP,PYLAMF
27933 INTEGER I,NN,LIN
27934 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
27935 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
27936 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
27937 DOUBLE PRECISION SUMME(0:100),A(4,8)
27938 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
27939 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
27940 DOUBLE PRECISION XMGLU,GAM
27941 DOUBLE PRECISION PYSIMP,PYLAMF
27942 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
27943 &DDD(2),EEE(2),FFF(2)
27944 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
27945 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27946 DOUBLE PRECISION AMC(2),AMN(4)
27947 SAVE AMC,AMN
27948 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27949 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27950 SAVE AMSB,AMST
27951 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27952 LOGICAL IFIRST
27953 SAVE IFIRST
27954 DATA IFIRST/.TRUE./
27955
27956 TANB=RMSS(5)
27957 SINB=TANB/SQRT(1D0+TANB**2)
27958 COSB=SINB/TANB
27959 XW=PARU(102)
27960 SINW=SQRT(XW)
27961 COSW=SQRT(1D0-XW)
27962 AMW=PMAS(24,1)
27963 COSC=SFMIX(5,1)
27964 SINC=SFMIX(5,3)
27965 COSA=SFMIX(6,1)
27966 SINA=SFMIX(6,3)
27967 AMBOT=0D0
27968 AMTOP=PYRNMT(PMAS(6,1))
27969 W2=SQRT(2D0)
27970 AMW=PMAS(24,1)
27971 FAKT1=AMBOT/W2/AMW/COSB
27972 FAKT2=AMTOP/W2/AMW/SINB
27973 IF(IFIRST) THEN
27974 AMC(1)=SMW(1)
27975 AMC(2)=SMW(2)
27976 DO 100 JJ=1,2
27977 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
27978 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
27979 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
27980 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
27981 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
27982 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
27983 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
27984 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
27985 100 CONTINUE
27986 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27987 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27988 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27989 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27990 IFIRST=.FALSE.
27991 ENDIF
27992 AMTOP=PMAS(6,1)
27993
27994 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
27995 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
27996 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
27997 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
27998
27999 COS2A=COSA**2-SINA**2
28000 SIN2A=SINA*COSA*2D0
28001 COS2C=COSC**2-SINC**2
28002 SIN2C=SINC*COSC*2D0
28003
28004 XMG=XMGLU
28005 XMT=AMTOP
28006 XMB=0D0
28007 XMR=AMC(I)
28008 XMG2=XMG*XMG
28009 ALPHAW=PYALEM(XMG2)
28010 ALPHAS=PYALPS(XMG2)
28011 XMT2=XMT*XMT
28012 XMB2=XMB*XMB
28013 XMR2=XMR*XMR
28014 XMQ2=XMG2+XMT2+XMB2+XMR2
28015 XMQ4=XMG*XMT*XMB*XMR
28016 XMQ3=XMG2*XMR2+XMT2*XMB2
28017 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
28018 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
28019
28020 XMST(1)=AMST(1)*AMST(1)
28021 XMST(2)=AMST(1)*AMST(1)
28022 XMST(3)=AMST(2)*AMST(2)
28023 XMST(4)=AMST(2)*AMST(2)
28024 XMSB(1)=AMSB(1)*AMSB(1)
28025 XMSB(2)=AMSB(2)*AMSB(2)
28026 XMSB(3)=AMSB(1)*AMSB(1)
28027 XMSB(4)=AMSB(2)*AMSB(2)
28028
28029 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
28030 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
28031 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
28032 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
28033 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
28034 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
28035 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
28036 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
28037
28038 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
28039 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
28040 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
28041 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
28042 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
28043 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
28044 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
28045 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
28046
28047 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
28048 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
28049 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
28050 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
28051 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
28052 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
28053 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
28054 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
28055
28056 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
28057 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
28058 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
28059 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
28060 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
28061 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
28062 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
28063 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
28064
28065 SMAX=(XMG-ABS(XMR))**2
28066 SMIN=(XMB+XMT)**2+0.1D0
28067
28068 DO 120 LIN=0,NN-1
28069 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28070 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
28071 GRS=SBAR-XMQ2
28072 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
28073 W=DSQRT(W)/2D0/SBAR
28074 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
28075 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
28076 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
28077 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
28078 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
28079 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
28080 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
28081 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
28082 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
28083 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
28084 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
28085 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
28086 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
28087 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
28088 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
28089 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
28090 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
28091 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
28092 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
28093 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
28094 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
28095 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
28096 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
28097 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
28098 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
28099 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
28100 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
28101 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
28102 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
28103 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
28104 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
28105 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
28106 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
28107 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
28108 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
28109 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
28110 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
28111 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
28112 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
28113 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
28114 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
28115 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
28116 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
28117 DO 110 J=1,4
28118 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
28119 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
28120 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
28121 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
28122 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
28123 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
28124 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
28125 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
28126 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
28127 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
28128 & -A(J,6)*(XMG2+XMR2-SBAR)
28129 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
28130 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
28131 & /(GRS+XMSB(J)+XMST(J))
28132 110 CONTINUE
28133 120 CONTINUE
28134 SUMME(NN)=0D0
28135 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28136 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28137
28138 RETURN
28139 END
28140
28141C*********************************************************************
28142
28143C...PYNJDC
28144C...Calculates decay widths for the neutralinos (admixtures of
28145C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
28146
28147C...Input: KCIN = KF code for particle
28148C...Output: XLAM = widths
28149C... IDLAM = KF codes for decay particles
28150C... IKNT = number of decay channels defined
28151C...AUTHOR: STEPHEN MRENNA
28152C...Last change:
28153C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
28154C...when CHIGAMMA .NE. 0
28155C...10 FEB 96: Calculate this decay for small tan(beta)
28156
28157 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
28158
28159C...Double precision and integer declarations.
28160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28161 INTEGER PYK,PYCHGE,PYCOMP
28162C...Parameter statement to help give large particle numbers.
28163 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28164C...Commonblocks.
28165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28166 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28167 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28168 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28169 &SFMIX(16,4)
28170 COMMON/PYINTS/XXM(20)
28171 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28172
28173C...Local variables.
28174 INTEGER KFIN,KCIN
28175 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28176 &XMZ,XMZ2,AXMJ,AXMI
28177 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
28178 DOUBLE PRECISION S12MIN,S12MAX
28179 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
28180 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
28181 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
28182 DOUBLE PRECISION PYX2XH,PYX2XG
28183 DOUBLE PRECISION XLAM(0:200)
28184 INTEGER IDLAM(200,3)
28185 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28186 INTEGER ITH(3),KF1,KF2
28187 INTEGER ITHC
28188 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28189 DOUBLE PRECISION SR2
28190 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
28191 DOUBLE PRECISION GAMCON,XMT1,XMT2
28192 DOUBLE PRECISION PYALEM,PI,PYALPS
28193 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
28194 DOUBLE PRECISION RAT1,RAT2
28195 DOUBLE PRECISION T3T,CA,CB,FCOL
28196 DOUBLE PRECISION ALFA,BETA,TANB
28197 DOUBLE PRECISION PYGAUS,PYXXGA
28198 EXTERNAL PYXXW5,PYGAUS,PYXXZ5
28199 DOUBLE PRECISION PREC
28200 INTEGER KFNCHI(4),KFCCHI(2)
28201 DATA ETAH/1D0,1D0,-1D0/
28202 DATA ITH/25,35,36/
28203 DATA ITHC/37/
28204 DATA PREC/1D-2/
28205 DATA PI/3.141592654D0/
28206 DATA SR2/1.4142136D0/
28207 DATA KFNCHI/1000022,1000023,1000025,1000035/
28208 DATA KFCCHI/1000024,1000037/
28209
28210C...COUNT THE NUMBER OF DECAY MODES
28211 LKNT=0
28212
28213 XMW=PMAS(24,1)
28214 XMW2=XMW**2
28215 XMZ=PMAS(23,1)
28216 XMZ2=XMZ**2
28217 XW=1D0-XMW2/XMZ2
28218 TANW = SQRT(XW/(1D0-XW))
28219
28220C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
28221 KCIN=PYCOMP(KFIN)
28222 IX=1
28223 IF(KFIN.EQ.KFNCHI(2)) IX=2
28224 IF(KFIN.EQ.KFNCHI(3)) IX=3
28225 IF(KFIN.EQ.KFNCHI(4)) IX=4
28226
28227 XMI=SMZ(IX)
28228 XMI2=XMI**2
28229 AXMI=ABS(XMI)
28230 AEM=PYALEM(XMI2)
28231 AS =PYALPS(XMI2)
28232 C1=AEM/XW
28233 XMI3=ABS(XMI**3)
28234
28235 TANB=RMSS(5)
28236 BETA=ATAN(TANB)
28237 ALFA=RMSS(18)
28238 CBETA=COS(BETA)
28239 SBETA=TANB*CBETA
28240 CALFA=COS(ALFA)
28241 SALFA=SIN(ALFA)
28242
28243C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28244 IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN
28245 RETURN
28246 ENDIF
28247
28248C...FORCE CHI0_2 -> CHI0_1 + GAMMA
28249 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
28250 XMJ=SMZ(1)
28251 AXMJ=ABS(XMJ)
28252 LKNT=LKNT+1
28253 GAMCON=AEM**3/8D0/PI/XMW2/XW
28254 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28255 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28256 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28257 IDLAM(LKNT,1)=KSUSY1+22
28258 IDLAM(LKNT,2)=22
28259 IDLAM(LKNT,3)=0
28260 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
28261 GOTO 290
28262 ENDIF
28263
28264C...GRAVITINO DECAY MODES
28265
28266 IF(IMSS(11).EQ.1) THEN
28267 XMP=RMSS(28)
28268 IDG=39+KSUSY1
28269 XMGR=PMAS(PYCOMP(IDG),1)
28270 SINW=SQRT(XW)
28271 COSW=SQRT(1D0-XW)
28272 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
28273 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
28274 LKNT=LKNT+1
28275 IDLAM(LKNT,1)=IDG
28276 IDLAM(LKNT,2)=22
28277 IDLAM(LKNT,3)=0
28278 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
28279 ENDIF
28280 IF(AXMI.GT.XMGR+XMZ) THEN
28281 LKNT=LKNT+1
28282 IDLAM(LKNT,1)=IDG
28283 IDLAM(LKNT,2)=23
28284 IDLAM(LKNT,3)=0
28285 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
28286 $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
28287 ENDIF
28288 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
28289 LKNT=LKNT+1
28290 IDLAM(LKNT,1)=IDG
28291 IDLAM(LKNT,2)=25
28292 IDLAM(LKNT,3)=0
28293 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
28294 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
28295 ENDIF
28296 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
28297 LKNT=LKNT+1
28298 IDLAM(LKNT,1)=IDG
28299 IDLAM(LKNT,2)=35
28300 IDLAM(LKNT,3)=0
28301 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
28302 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
28303 ENDIF
28304 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
28305 LKNT=LKNT+1
28306 IDLAM(LKNT,1)=IDG
28307 IDLAM(LKNT,2)=36
28308 IDLAM(LKNT,3)=0
28309 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
28310 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
28311 ENDIF
28312 ENDIF
28313
28314 DO 180 IJ=1,IX-1
28315 XMJ=SMZ(IJ)
28316 AXMJ=ABS(XMJ)
28317 XMJ2=XMJ**2
28318
28319C...CHI0_I -> CHI0_J + GAMMA
28320 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
28321 RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
28322 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
28323 RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
28324 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
28325 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
28326 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
28327 LKNT=LKNT+1
28328 IDLAM(LKNT,1)=KFNCHI(IJ)
28329 IDLAM(LKNT,2)=22
28330 IDLAM(LKNT,3)=0
28331 GAMCON=AEM**3/8D0/PI/XMW2/XW
28332 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28333 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28334 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28335 ENDIF
28336 ENDIF
28337
28338C...CHI0_I -> CHI0_J + Z0
28339 IF(AXMI.GE.AXMJ+XMZ) THEN
28340 LKNT=LKNT+1
28341 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28342 GR=-GL
28343 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
28344 IDLAM(LKNT,1)=KFNCHI(IJ)
28345 IDLAM(LKNT,2)=23
28346 IDLAM(LKNT,3)=0
28347 ELSEIF(AXMI.GE.AXMJ) THEN
28348 FID=11
28349 EI=KCHG(FID,1)/3D0
28350 T3=-0.5D0
28351 XXM(1)=0D0
28352 XXM(2)=XMJ
28353 XXM(3)=0D0
28354 XXM(4)=XMI
28355 XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
28356 XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
28357 XXM(7)=XMZ
28358 XXM(8)=PMAS(23,2)
28359 XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28360 XXM(10)=-XXM(9)
28361 XXM(11)=(T3-EI*XW)/(1D0-XW)
28362 XXM(12)=-EI*XW/(1D0-XW)
28363 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28364 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28365 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28366 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28367 S12MIN=0D0
28368 S12MAX=(AXMI-AXMJ)**2
28369
28370C...CHARGED LEPTONS
28371 IF( XXM(5).LT.AXMI ) THEN
28372 XXM(5)=1D6
28373 ENDIF
28374 IF(XXM(6).LT.AXMI ) THEN
28375 XXM(6)=1D6
28376 ENDIF
28377 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
28378 LKNT=LKNT+1
28379 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28380 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28381 IDLAM(LKNT,1)=KFNCHI(IJ)
28382 IDLAM(LKNT,2)=11
28383 IDLAM(LKNT,3)=-11
28384 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
28385 LKNT=LKNT+1
28386 XLAM(LKNT)=XLAM(LKNT-1)
28387 IDLAM(LKNT,1)=KFNCHI(IJ)
28388 IDLAM(LKNT,2)=13
28389 IDLAM(LKNT,3)=-13
28390 ENDIF
28391 ENDIF
28392 100 CONTINUE
28393 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28394 XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
28395 XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
28396 ELSE
28397 XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
28398 XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
28399 ENDIF
28400 IF( XXM(5).LT.AXMI ) THEN
28401 XXM(5)=1D6
28402 ENDIF
28403 IF(XXM(6).LT.AXMI ) THEN
28404 XXM(6)=1D6
28405 ENDIF
28406
28407 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
28408 LKNT=LKNT+1
28409 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28410 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28411 IDLAM(LKNT,1)=KFNCHI(IJ)
28412 IDLAM(LKNT,2)=15
28413 IDLAM(LKNT,3)=-15
28414 ENDIF
28415
28416C...NEUTRINOS
28417 110 CONTINUE
28418 FID=12
28419 EI=KCHG(FID,1)/3D0
28420 T3=0.5D0
28421 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
28422 XXM(6)=1D6
28423 XXM(11)=(T3-EI*XW)/(1D0-XW)
28424 XXM(12)=-EI*XW/(1D0-XW)
28425 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28426 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28427 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28428 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28429
28430 IF( XXM(5).LT.AXMI ) THEN
28431 XXM(5)=1D6
28432 ENDIF
28433
28434 LKNT=LKNT+1
28435 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28436 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28437 IDLAM(LKNT,1)=KFNCHI(IJ)
28438 IDLAM(LKNT,2)=12
28439 IDLAM(LKNT,3)=-12
28440 LKNT=LKNT+1
28441 XLAM(LKNT)=XLAM(LKNT-1)
28442 IDLAM(LKNT,1)=KFNCHI(IJ)
28443 IDLAM(LKNT,2)=14
28444 IDLAM(LKNT,3)=-14
28445 120 CONTINUE
28446 XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
28447 IF( XXM(5).LT.AXMI ) THEN
28448 XXM(5)=1D6
28449 ENDIF
28450 LKNT=LKNT+1
28451 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28452 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28453 IDLAM(LKNT,1)=KFNCHI(IJ)
28454 IDLAM(LKNT,2)=16
28455 IDLAM(LKNT,3)=-16
28456
28457C...D-TYPE QUARKS
28458 130 CONTINUE
28459 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28460 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28461 FID=1
28462 EI=KCHG(FID,1)/3D0
28463 T3=-0.5D0
28464
28465 XXM(11)=(T3-EI*XW)/(1D0-XW)
28466 XXM(12)=-EI*XW/(1D0-XW)
28467 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28468 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28469 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28470 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28471
28472 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
28473 IF( XXM(5).LT.AXMI ) THEN
28474 XXM(5)=1D6
28475 ELSEIF( XXM(6).LT.AXMI ) THEN
28476 XXM(6)=1D6
28477 ENDIF
28478 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28479 LKNT=LKNT+1
28480 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28481 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28482 IDLAM(LKNT,1)=KFNCHI(IJ)
28483 IDLAM(LKNT,2)=1
28484 IDLAM(LKNT,3)=-1
28485 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28486 LKNT=LKNT+1
28487 XLAM(LKNT)=XLAM(LKNT-1)
28488 IDLAM(LKNT,1)=KFNCHI(IJ)
28489 IDLAM(LKNT,2)=3
28490 IDLAM(LKNT,3)=-3
28491 ENDIF
28492 ENDIF
28493 140 CONTINUE
28494 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28495 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28496 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28497 ELSE
28498 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28499 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28500 ENDIF
28501 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
28502 IF(XXM(5).LT.AXMI) THEN
28503 XXM(5)=1D6
28504 ELSEIF(XXM(6).LT.AXMI) THEN
28505 XXM(6)=1D6
28506 ENDIF
28507 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28508 LKNT=LKNT+1
28509 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28510 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28511 IDLAM(LKNT,1)=KFNCHI(IJ)
28512 IDLAM(LKNT,2)=5
28513 IDLAM(LKNT,3)=-5
28514 ENDIF
28515
28516C...U-TYPE QUARKS
28517 150 CONTINUE
28518 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28519 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28520 FID=2
28521 EI=KCHG(FID,1)/3D0
28522 T3=0.5D0
28523
28524 XXM(11)=(T3-EI*XW)/(1D0-XW)
28525 XXM(12)=-EI*XW/(1D0-XW)
28526 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28527 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28528 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28529 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28530
28531 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
28532 IF(XXM(5).LT.AXMI) THEN
28533 XXM(5)=1D6
28534 ELSEIF(XXM(6).LT.AXMI) THEN
28535 XXM(6)=1D6
28536 ENDIF
28537 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28538 LKNT=LKNT+1
28539 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28540 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28541 IDLAM(LKNT,1)=KFNCHI(IJ)
28542 IDLAM(LKNT,2)=2
28543 IDLAM(LKNT,3)=-2
28544 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28545 LKNT=LKNT+1
28546 XLAM(LKNT)=XLAM(LKNT-1)
28547 IDLAM(LKNT,1)=KFNCHI(IJ)
28548 IDLAM(LKNT,2)=4
28549 IDLAM(LKNT,3)=-4
28550 ENDIF
28551 ENDIF
28552 160 CONTINUE
28553 ENDIF
28554
28555C...CHI0_I -> CHI0_J + H0_K
28556 EH(1)=SIN(ALFA)
28557 EH(2)=COS(ALFA)
28558 EH(3)=-SIN(BETA)
28559 DH(1)=COS(ALFA)
28560 DH(2)=-SIN(ALFA)
28561 DH(3)=COS(BETA)
28562
28563 QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
28564 & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
28565 RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
28566 & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
28567
28568 DO 170 IH=1,3
28569 XMH=PMAS(ITH(IH),1)
28570 XMH2=XMH**2
28571 IF(AXMI.GE.AXMJ+XMH) THEN
28572 LKNT=LKNT+1
28573 XL=PYLAMF(XMI2,XMJ2,XMH2)
28574 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
28575 F12K=F21K
28576C...SIGN OF MASSES I,J
28577 XMK=XMJ
28578 IF(IH.EQ.3) XMK=-XMK
28579 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
28580 IDLAM(LKNT,1)=KFNCHI(IJ)
28581 IDLAM(LKNT,2)=ITH(IH)
28582 IDLAM(LKNT,3)=0
28583 ENDIF
28584 170 CONTINUE
28585 180 CONTINUE
28586
28587C...CHI0_I -> CHI+_J + W-
28588 DO 220 IJ=1,2
28589 XMJ=SMW(IJ)
28590 AXMJ=ABS(XMJ)
28591 XMJ2=XMJ**2
28592 IF(AXMI.GE.AXMJ+XMW) THEN
28593 LKNT=LKNT+1
28594 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28595 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28596 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
28597 IDLAM(LKNT,1)=KFCCHI(IJ)
28598 IDLAM(LKNT,2)=-24
28599 IDLAM(LKNT,3)=0
28600 LKNT=LKNT+1
28601 XLAM(LKNT)=XLAM(LKNT-1)
28602 IDLAM(LKNT,1)=-KFCCHI(IJ)
28603 IDLAM(LKNT,2)=24
28604 IDLAM(LKNT,3)=0
28605 ELSEIF(AXMI.GE.AXMJ) THEN
28606 S12MIN=0D0
28607 S12MAX=(AXMI-AXMJ)**2
28608 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28609 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28610
28611C...LEPTONS
28612 FID=11
28613 EI=KCHG(FID,1)/3D0
28614 T3=-0.5D0
28615 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28616 FID=12
28617 EI=KCHG(FID,1)/3D0
28618 T3=0.5D0
28619 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28620
28621 XXM(1)=0D0
28622 XXM(2)=XMJ
28623 XXM(3)=0D0
28624 XXM(4)=XMI
28625 XXM(9)=PMAS(24,1)
28626 XXM(10)=PMAS(24,2)
28627 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
28628 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
28629 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
28630 IF(XXM(11).LT.AXMI) THEN
28631 XXM(11)=1D6
28632 ELSEIF(XXM(12).LT.AXMI) THEN
28633 XXM(12)=1D6
28634 ENDIF
28635 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
28636 LKNT=LKNT+1
28637 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28638 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28639 IDLAM(LKNT,1)=KFCCHI(IJ)
28640 IDLAM(LKNT,2)=11
28641 IDLAM(LKNT,3)=-12
28642 LKNT=LKNT+1
28643 XLAM(LKNT)=XLAM(LKNT-1)
28644 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28645 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28646 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28647 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
28648 LKNT=LKNT+1
28649 XLAM(LKNT)=XLAM(LKNT-1)
28650 IDLAM(LKNT,1)=KFCCHI(IJ)
28651 IDLAM(LKNT,2)=13
28652 IDLAM(LKNT,3)=-14
28653 LKNT=LKNT+1
28654 XLAM(LKNT)=XLAM(LKNT-1)
28655 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28656 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28657 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28658 ENDIF
28659 ENDIF
28660 190 CONTINUE
28661 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28662 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
28663 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28664 ELSE
28665 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
28666 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28667 ENDIF
28668
28669 IF(XXM(11).LT.AXMI) THEN
28670 XXM(11)=1D6
28671 ENDIF
28672 IF(XXM(12).LT.AXMI) THEN
28673 XXM(12)=1D6
28674 ENDIF
28675 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
28676 LKNT=LKNT+1
28677 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28678 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28679 XLAM(LKNT)=XLAM(LKNT-1)
28680 IDLAM(LKNT,1)=KFCCHI(IJ)
28681 IDLAM(LKNT,2)=15
28682 IDLAM(LKNT,3)=-16
28683 LKNT=LKNT+1
28684 XLAM(LKNT)=XLAM(LKNT-1)
28685 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28686 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28687 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28688 ENDIF
28689
28690C...NOW, DO THE QUARKS
28691 200 CONTINUE
28692 FID=1
28693 EI=KCHG(FID,1)/3D0
28694 T3=-0.5D0
28695 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28696 FID=2
28697 EI=KCHG(FID,1)/3D0
28698 T3=0.5D0
28699 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28700
28701 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
28702 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
28703 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
28704 IF(XXM(11).LT.AXMI) THEN
28705 XXM(11)=1D6
28706 ELSEIF(XXM(12).LT.AXMI) THEN
28707 XXM(12)=1D6
28708 ENDIF
28709 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
28710 LKNT=LKNT+1
28711 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
28712 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28713 IDLAM(LKNT,1)=KFCCHI(IJ)
28714 IDLAM(LKNT,2)=1
28715 IDLAM(LKNT,3)=-2
28716 LKNT=LKNT+1
28717 XLAM(LKNT)=XLAM(LKNT-1)
28718 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28719 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28720 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28721 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
28722 LKNT=LKNT+1
28723 XLAM(LKNT)=XLAM(LKNT-1)
28724 IDLAM(LKNT,1)=KFCCHI(IJ)
28725 IDLAM(LKNT,2)=3
28726 IDLAM(LKNT,3)=-4
28727 LKNT=LKNT+1
28728 XLAM(LKNT)=XLAM(LKNT-1)
28729 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28730 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28731 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28732 ENDIF
28733 ENDIF
28734 210 CONTINUE
28735 ENDIF
28736 220 CONTINUE
28737 230 CONTINUE
28738
28739C...CHI0_I -> CHI+_I + H-
28740 DO 240 IJ=1,2
28741 XMJ=SMW(IJ)
28742 AXMJ=ABS(XMJ)
28743 XMJ2=XMJ**2
28744 XMHP=PMAS(ITHC,1)
28745 XMHP2=XMHP**2
28746 IF(AXMI.GE.AXMJ+XMHP) THEN
28747 LKNT=LKNT+1
28748 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
28749 & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
28750 GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
28751 & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
28752 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
28753 IDLAM(LKNT,1)=KFCCHI(IJ)
28754 IDLAM(LKNT,2)=-ITHC
28755 IDLAM(LKNT,3)=0
28756 LKNT=LKNT+1
28757 XLAM(LKNT)=XLAM(LKNT-1)
28758 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28759 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28760 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28761 ELSE
28762
28763 ENDIF
28764 240 CONTINUE
28765
28766C...2-BODY DECAYS TO FERMION SFERMION
28767 DO 250 J=1,16
28768 IF(J.GE.7.AND.J.LE.10) GOTO 250
28769 KF1=KSUSY1+J
28770 KF2=KSUSY2+J
28771 XMSF1=PMAS(PYCOMP(KF1),1)
28772 XMSF2=PMAS(PYCOMP(KF2),1)
28773 XMF=PMAS(J,1)
28774 IF(J.LE.6) THEN
28775 FCOL=3D0
28776 ELSE
28777 FCOL=1D0
28778 ENDIF
28779
28780 EI=KCHG(J,1)/3D0
28781 T3T=SIGN(1D0,EI)
28782 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
28783 IF(MOD(J,2).EQ.0) THEN
28784 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28785 AL=XMF*ZMIX(IX,4)/XMW/SBETA
28786 AR=-2D0*EI*TANW*ZMIX(IX,1)
28787 BR=AL
28788 ELSE
28789 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28790 AL=XMF*ZMIX(IX,3)/XMW/CBETA
28791 AR=-2D0*EI*TANW*ZMIX(IX,1)
28792 BR=AL
28793 ENDIF
28794
28795C...D~ D_L
28796 IF(AXMI.GE.XMF+XMSF1) THEN
28797 LKNT=LKNT+1
28798 XMA2=XMSF1**2
28799 XMB2=XMF**2
28800 XL=PYLAMF(XMI2,XMA2,XMB2)
28801 CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
28802 CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
28803 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28804 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28805 IDLAM(LKNT,1)=KF1
28806 IDLAM(LKNT,2)=-J
28807 IDLAM(LKNT,3)=0
28808 LKNT=LKNT+1
28809 XLAM(LKNT)=XLAM(LKNT-1)
28810 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28811 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28812 IDLAM(LKNT,3)=0
28813 ENDIF
28814
28815C...D~ D_R
28816 IF(AXMI.GE.XMF+XMSF2) THEN
28817 LKNT=LKNT+1
28818 XMA2=XMSF2**2
28819 XMB2=XMF**2
28820 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
28821 CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
28822 XL=PYLAMF(XMI2,XMA2,XMB2)
28823 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28824 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28825 IDLAM(LKNT,1)=KF2
28826 IDLAM(LKNT,2)=-J
28827 IDLAM(LKNT,3)=0
28828 LKNT=LKNT+1
28829 XLAM(LKNT)=XLAM(LKNT-1)
28830 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28831 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28832 IDLAM(LKNT,3)=0
28833 ENDIF
28834 250 CONTINUE
28835
28836C...3-BODY DECAY TO Q Q~ GLUINO
28837 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
28838 IF(AXMI.GE.XMJ) THEN
28839 AXMJ=ABS(XMJ)
28840 XXM(1)=0D0
28841 XXM(2)=XMJ
28842 XXM(3)=0D0
28843 XXM(4)=XMI
28844 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28845 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28846 XXM(7)=1D6
28847 XXM(8)=0D0
28848 XXM(9)=0D0
28849 XXM(10)=0D0
28850 S12MIN=0D0
28851 S12MAX=(AXMI-AXMJ)**2
28852C...ALL QUARKS BUT T
28853 XXM(11)=0D0
28854 XXM(12)=0D0
28855 XXM(13)=1D0
28856 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
28857 XXM(15)=1D0
28858 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
28859 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260
28860 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28861 LKNT=LKNT+1
28862 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
28863 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28864 IDLAM(LKNT,1)=KSUSY1+21
28865 IDLAM(LKNT,2)=1
28866 IDLAM(LKNT,3)=-1
28867 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28868 LKNT=LKNT+1
28869 XLAM(LKNT)=XLAM(LKNT-1)
28870 IDLAM(LKNT,1)=KSUSY1+21
28871 IDLAM(LKNT,2)=3
28872 IDLAM(LKNT,3)=-3
28873 ENDIF
28874 ENDIF
28875 260 CONTINUE
28876 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28877 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28878 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28879 ELSE
28880 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28881 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28882 ENDIF
28883 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
28884 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28885 LKNT=LKNT+1
28886 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
28887 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28888 IDLAM(LKNT,1)=KSUSY1+21
28889 IDLAM(LKNT,2)=5
28890 IDLAM(LKNT,3)=-5
28891 ENDIF
28892C...U-TYPE QUARKS
28893 270 CONTINUE
28894 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28895 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28896 XXM(13)=1D0
28897 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
28898 XXM(15)=1D0
28899 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
28900 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
28901 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28902 LKNT=LKNT+1
28903 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
28904 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28905 IDLAM(LKNT,1)=KSUSY1+21
28906 IDLAM(LKNT,2)=2
28907 IDLAM(LKNT,3)=-2
28908 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28909 LKNT=LKNT+1
28910 XLAM(LKNT)=XLAM(LKNT-1)
28911 IDLAM(LKNT,1)=KSUSY1+21
28912 IDLAM(LKNT,2)=4
28913 IDLAM(LKNT,3)=-4
28914 ENDIF
28915 ENDIF
28916 280 CONTINUE
28917 ENDIF
28918
28919 290 IKNT=LKNT
28920 XLAM(0)=0D0
28921 DO 300 I=1,IKNT
28922 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
28923 XLAM(0)=XLAM(0)+XLAM(I)
28924 300 CONTINUE
28925 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
28926
28927 RETURN
28928 END
28929
28930C*********************************************************************
28931
28932C...PYCJDC
28933C...Calculate decay widths for the charginos (admixtures of
28934C...charged Wino and charged Higgsino.
28935
28936C...Input: KCIN = KF code for particle
28937C...Output: XLAM = widths
28938C... IDLAM = KF codes for decay particles
28939C... IKNT = number of decay channels defined
28940C...AUTHOR: STEPHEN MRENNA
28941C...Last change:
28942C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
28943C...when CHIENU .NE. 0
28944
28945 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
28946
28947C...Double precision and integer declarations.
28948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28949 INTEGER PYK,PYCHGE,PYCOMP
28950C...Parameter statement to help give large particle numbers.
28951 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28952C...Commonblocks.
28953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28955 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28956 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28957 &SFMIX(16,4)
28958 COMMON/PYINTS/XXM(20)
28959 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28960
28961C...Local variables.
28962 INTEGER KFIN,KCIN
28963 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28964 &XMZ,XMZ2,AXMJ,AXMI
28965 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
28966 DOUBLE PRECISION S12MIN,S12MAX
28967 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
28968 DOUBLE PRECISION PYLAMF,XL
28969 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
28970 DOUBLE PRECISION PYX2XH,PYX2XG
28971 DOUBLE PRECISION XLAM(0:200)
28972 INTEGER IDLAM(200,3)
28973 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28974 INTEGER ITH(3)
28975 INTEGER ITHC
28976 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28977 DOUBLE PRECISION SR2
28978 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
28979
28980 DOUBLE PRECISION PYALEM,PI,PYALPS
28981 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
28982 DOUBLE PRECISION CA,CB,FCOL
28983 INTEGER KF1,KF2,ISF
28984 INTEGER KFNCHI(4),KFCCHI(2)
28985
28986 DOUBLE PRECISION TEMP
28987 DOUBLE PRECISION PYGAUS
28988 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
28989 DOUBLE PRECISION PREC
28990 DATA ITH/25,35,36/
28991 DATA ITHC/37/
28992 DATA ETAH/1D0,1D0,-1D0/
28993 DATA SR2/1.4142136D0/
28994 DATA PI/3.141592654D0/
28995 DATA PREC/1D-2/
28996 DATA KFNCHI/1000022,1000023,1000025,1000035/
28997 DATA KFCCHI/1000024,1000037/
28998
28999C...COUNT THE NUMBER OF DECAY MODES
29000 LKNT=0
29001 XMW=PMAS(24,1)
29002 XMW2=XMW**2
29003 XMZ=PMAS(23,1)
29004 XMZ2=XMZ**2
29005 XW=1D0-XMW2/XMZ2
29006 TANW = SQRT(XW/(1D0-XW))
29007
29008C...1 OR 2 DEPENDING ON CHARGINO TYPE
29009 IX=1
29010 IF(KFIN.EQ.KFCCHI(2)) IX=2
29011 KCIN=PYCOMP(KFIN)
29012
29013 XMI=SMW(IX)
29014 XMI2=XMI**2
29015 AXMI=ABS(XMI)
29016 AEM=PYALEM(XMI2)
29017 AS =PYALPS(XMI2)
29018 C1=AEM/XW
29019 XMI3=ABS(XMI**3)
29020 TANB=RMSS(5)
29021 BETA=ATAN(TANB)
29022 CBETA=COS(BETA)
29023 SBETA=TANB*CBETA
29024 ALFA=RMSS(18)
29025
29026C...GRAVITINO DECAY MODES
29027
29028 IF(IMSS(11).EQ.1) THEN
29029 XMP=RMSS(28)
29030 IDG=39+KSUSY1
29031 XMGR=PMAS(PYCOMP(IDG),1)
29032 SINW=SQRT(XW)
29033 COSW=SQRT(1D0-XW)
29034 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
29035 IF(AXMI.GT.XMGR+XMW) THEN
29036 LKNT=LKNT+1
29037 IDLAM(LKNT,1)=IDG
29038 IDLAM(LKNT,2)=24
29039 IDLAM(LKNT,3)=0
29040 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
29041 & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
29042 & (1D0-XMW2/XMI2)**4
29043 ENDIF
29044 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
29045 LKNT=LKNT+1
29046 IDLAM(LKNT,1)=IDG
29047 IDLAM(LKNT,2)=37
29048 IDLAM(LKNT,3)=0
29049 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
29050 & (UMIX(IX,2)*SBETA)**2))
29051 & *(1D0-PMAS(37,1)**2/XMI2)**4
29052 ENDIF
29053 ENDIF
29054
29055C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
29056 IF(IX.EQ.1) GOTO 150
29057 XMJ=SMW(1)
29058 AXMJ=ABS(XMJ)
29059 XMJ2=XMJ**2
29060
29061C...CHI_2+ -> CHI_1+ + Z0
29062 IF(AXMI.GE.AXMJ+XMZ) THEN
29063 LKNT=LKNT+1
29064 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
29065 GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
29066 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
29067 IDLAM(LKNT,1)=KFCCHI(1)
29068 IDLAM(LKNT,2)=23
29069 IDLAM(LKNT,3)=0
29070
29071C...CHARGED LEPTONS
29072 ELSEIF(AXMI.GE.AXMJ) THEN
29073 XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
29074 XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
29075 XXM(9)=XMZ
29076 XXM(10)=PMAS(23,2)
29077 XXM(1)=0D0
29078 XXM(2)=XMJ
29079 XXM(3)=0D0
29080 XXM(4)=XMI
29081 S12MIN=0D0
29082 S12MAX=(AXMJ-AXMI)**2
29083 XXM(7)= (-0.5D0+XW)/(1D0-XW)
29084 XXM(8)= XW/(1D0-XW)
29085 XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
29086 XXM(12)=VMIX(2,1)*VMIX(1,1)
29087 IF( XXM(11).LT.AXMI ) THEN
29088 XXM(11)=1D6
29089 ENDIF
29090 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
29091 LKNT=LKNT+1
29092 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29093 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29094 IDLAM(LKNT,1)=KFCCHI(1)
29095 IDLAM(LKNT,2)=11
29096 IDLAM(LKNT,3)=-11
29097 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
29098 LKNT=LKNT+1
29099 XLAM(LKNT)=XLAM(LKNT-1)
29100 IDLAM(LKNT,1)=KFCCHI(1)
29101 IDLAM(LKNT,2)=13
29102 IDLAM(LKNT,3)=-13
29103 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
29104 LKNT=LKNT+1
29105 XLAM(LKNT)=XLAM(LKNT-1)
29106 IDLAM(LKNT,1)=KFCCHI(1)
29107 IDLAM(LKNT,2)=15
29108 IDLAM(LKNT,3)=-15
29109 ENDIF
29110 ENDIF
29111 ENDIF
29112
29113C...NEUTRINOS
29114 100 CONTINUE
29115 XXM(7)= (0.5D0)/(1D0-XW)
29116 XXM(8)= 0D0
29117 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29118 XXM(12)=UMIX(2,1)*UMIX(1,1)
29119 IF( XXM(11).LT.AXMI ) THEN
29120 XXM(11)=1D6
29121 ENDIF
29122 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
29123 LKNT=LKNT+1
29124 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29125 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29126 IDLAM(LKNT,1)=KFCCHI(1)
29127 IDLAM(LKNT,2)=12
29128 IDLAM(LKNT,3)=-12
29129 LKNT=LKNT+1
29130 XLAM(LKNT)=XLAM(LKNT-1)
29131 IDLAM(LKNT,1)=KFCCHI(1)
29132 IDLAM(LKNT,2)=14
29133 IDLAM(LKNT,3)=-14
29134 LKNT=LKNT+1
29135 XLAM(LKNT)=XLAM(LKNT-1)
29136 IDLAM(LKNT,1)=KFCCHI(1)
29137 IDLAM(LKNT,2)=16
29138 IDLAM(LKNT,3)=-16
29139 ENDIF
29140
29141C...D-TYPE QUARKS
29142 110 CONTINUE
29143 XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
29144 XXM(8)= XW/3D0/(1D0-XW)
29145 XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
29146 XXM(12)=VMIX(2,1)*VMIX(1,1)
29147 IF( XXM(11).LT.AXMI ) GOTO 120
29148 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29149 LKNT=LKNT+1
29150 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29151 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29152 IDLAM(LKNT,1)=KFCCHI(1)
29153 IDLAM(LKNT,2)=1
29154 IDLAM(LKNT,3)=-1
29155 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29156 LKNT=LKNT+1
29157 XLAM(LKNT)=XLAM(LKNT-1)
29158 IDLAM(LKNT,1)=KFCCHI(1)
29159 IDLAM(LKNT,2)=3
29160 IDLAM(LKNT,3)=-3
29161 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29162 LKNT=LKNT+1
29163 XLAM(LKNT)=XLAM(LKNT-1)
29164 IDLAM(LKNT,1)=KFCCHI(1)
29165 IDLAM(LKNT,2)=5
29166 IDLAM(LKNT,3)=-5
29167 ENDIF
29168 ENDIF
29169 ENDIF
29170
29171C...U-TYPE QUARKS
29172 120 CONTINUE
29173 XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
29174 XXM(8)= -2D0*XW/3D0/(1D0-XW)
29175 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29176 XXM(12)=UMIX(2,1)*UMIX(1,1)
29177 IF( XXM(11).LT.AXMI ) GOTO 130
29178 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29179 LKNT=LKNT+1
29180 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29181 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29182 IDLAM(LKNT,1)=KFCCHI(1)
29183 IDLAM(LKNT,2)=2
29184 IDLAM(LKNT,3)=-2
29185 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29186 LKNT=LKNT+1
29187 XLAM(LKNT)=XLAM(LKNT-1)
29188 IDLAM(LKNT,1)=KFCCHI(1)
29189 IDLAM(LKNT,2)=4
29190 IDLAM(LKNT,3)=-4
29191 ENDIF
29192 ENDIF
29193 130 CONTINUE
29194 ENDIF
29195
29196C...CHI_2+ -> CHI_1+ + H0_K
29197 EH(2)=COS(ALFA)
29198 EH(1)=SIN(ALFA)
29199 EH(3)=-SBETA
29200 DH(2)=-SIN(ALFA)
29201 DH(1)=COS(ALFA)
29202 DH(3)=COS(BETA)
29203 DO 140 IH=1,3
29204 XMH=PMAS(ITH(IH),1)
29205 XMH2=XMH**2
29206C...NO 3-BODY OPTION
29207 IF(AXMI.GE.AXMJ+XMH) THEN
29208 LKNT=LKNT+1
29209 XL=PYLAMF(XMI2,XMJ2,XMH2)
29210 F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
29211 & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
29212 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
29213 & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
29214 XMK=XMJ*ETAH(IH)
29215 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
29216 IDLAM(LKNT,1)=KFCCHI(1)
29217 IDLAM(LKNT,2)=ITH(IH)
29218 IDLAM(LKNT,3)=0
29219 ENDIF
29220 140 CONTINUE
29221
29222C...CHI1 JUMPS TO HERE
29223 150 CONTINUE
29224
29225C...CHI+_I -> CHI0_J + W+
29226 DO 180 IJ=1,4
29227 XMJ=SMZ(IJ)
29228 AXMJ=ABS(XMJ)
29229 XMJ2=XMJ**2
29230 IF(AXMI.GE.AXMJ+XMW) THEN
29231 LKNT=LKNT+1
29232 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
29233 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
29234 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
29235 IDLAM(LKNT,1)=KFNCHI(IJ)
29236 IDLAM(LKNT,2)=24
29237 IDLAM(LKNT,3)=0
29238
29239C...LEPTONS
29240 ELSEIF(AXMI.GE.AXMJ) THEN
29241 XMF1=0D0
29242 XMF2=0D0
29243 S12MIN=(XMF1+XMF2)**2
29244 S12MAX=(AXMJ-AXMI)**2
29245 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
29246 XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
29247 FID=11
29248 EI=KCHG(FID,1)/3D0
29249 T3=-0.5D0
29250 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29251 FID=12
29252 EI=KCHG(FID,1)/3D0
29253 T3=0.5D0
29254 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29255
29256 XXM(4)=XMI
29257 XXM(1)=XMF1
29258 XXM(2)=XMJ
29259 XXM(3)=XMF2
29260 XXM(9)=PMAS(24,1)
29261 XXM(10)=PMAS(24,2)
29262 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29263 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
29264
29265C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
29266C...--> 1/(16PI)/M**3*(AEM/XW)**2
29267
29268 IF(XXM(11).LT.AXMI) THEN
29269 XXM(11)=1D6
29270 ENDIF
29271 IF(XXM(12).LT.AXMI) THEN
29272 XXM(12)=1D6
29273 ENDIF
29274 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
29275 LKNT=LKNT+1
29276 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29277 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29278 IDLAM(LKNT,1)=KFNCHI(IJ)
29279 IDLAM(LKNT,2)=-11
29280 IDLAM(LKNT,3)=12
29281
29282C...ONLY DECAY CHI+1 -> E+ NU_E
29283 IF( IMSS(12).NE. 0 ) GOTO 220
29284 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
29285 LKNT=LKNT+1
29286 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
29287 XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
29288 IF(XXM(11).LT.AXMI) THEN
29289 XXM(11)=1D6
29290 ELSEIF(XXM(12).LT.AXMI) THEN
29291 XXM(12)=1D6
29292 ENDIF
29293 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29294 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29295 IDLAM(LKNT,1)=KFNCHI(IJ)
29296 IDLAM(LKNT,2)=-13
29297 IDLAM(LKNT,3)=14
29298 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
29299 LKNT=LKNT+1
29300 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
29301 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
29302 ELSE
29303 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
29304 ENDIF
29305 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
29306 IF(XXM(11).LT.AXMI) THEN
29307 XXM(11)=1D6
29308 ENDIF
29309 IF(XXM(12).LT.AXMI) THEN
29310 XXM(12)=1D6
29311 ENDIF
29312 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29313 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29314 IDLAM(LKNT,1)=KFNCHI(IJ)
29315 IDLAM(LKNT,2)=-15
29316 IDLAM(LKNT,3)=16
29317 ENDIF
29318 ENDIF
29319 ENDIF
29320
29321C...NOW, DO THE QUARKS
29322 160 CONTINUE
29323 FID=1
29324 EI=KCHG(FID,1)/3D0
29325 T3=-0.5D0
29326 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29327 FID=1
29328 EI=KCHG(FID,1)/3D0
29329 T3=0.5D0
29330 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29331
29332 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29333 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29334 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
29335 IF(XXM(11).LT.AXMI) THEN
29336 XXM(11)=1D6
29337 ELSEIF(XXM(12).LT.AXMI) THEN
29338 XXM(12)=1D6
29339 ENDIF
29340 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29341 LKNT=LKNT+1
29342 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29343 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29344 IDLAM(LKNT,1)=KFNCHI(IJ)
29345 IDLAM(LKNT,2)=-1
29346 IDLAM(LKNT,3)=2
29347 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29348 LKNT=LKNT+1
29349 XLAM(LKNT)=XLAM(LKNT-1)
29350 IDLAM(LKNT,1)=KFNCHI(IJ)
29351 IDLAM(LKNT,2)=-3
29352 IDLAM(LKNT,3)=4
29353 ENDIF
29354 ENDIF
29355 170 CONTINUE
29356 ENDIF
29357 180 CONTINUE
29358
29359C...CHI+_I -> CHI0_J + H+
29360 DO 190 IJ=1,4
29361 XMJ=SMZ(IJ)
29362 AXMJ=ABS(XMJ)
29363 XMJ2=XMJ**2
29364 XMHP=PMAS(ITHC,1)
29365 XMHP2=XMHP**2
29366 IF(AXMI.GE.AXMJ+XMHP) THEN
29367 LKNT=LKNT+1
29368 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
29369 & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
29370 GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
29371 & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
29372 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
29373 IDLAM(LKNT,1)=KFNCHI(IJ)
29374 IDLAM(LKNT,2)=ITHC
29375 IDLAM(LKNT,3)=0
29376 ELSE
29377
29378 ENDIF
29379 190 CONTINUE
29380
29381C...2-BODY DECAYS TO FERMION SFERMION
29382 DO 200 J=1,16
29383 IF(J.GE.7.AND.J.LE.10) GOTO 200
29384 IF(MOD(J,2).EQ.0) THEN
29385 KF1=KSUSY1+J-1
29386 ELSE
29387 KF1=KSUSY1+J+1
29388 ENDIF
29389 KF2=KF1+KSUSY1
29390 XMSF1=PMAS(PYCOMP(KF1),1)
29391 XMSF2=PMAS(PYCOMP(KF2),1)
29392 XMF=PMAS(J,1)
29393 IF(J.LE.6) THEN
29394 FCOL=3D0
29395 ELSE
29396 FCOL=1D0
29397 ENDIF
29398
29399C...U~ D_L
29400 IF(MOD(J,2).EQ.0) THEN
29401 XMFP=PMAS(J-1,1)
29402 AL=UMIX(IX,1)
29403 BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
29404 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
29405 BR=0D0
29406 ISF=J-1
29407 ELSE
29408 XMFP=PMAS(J+1,1)
29409 AL=VMIX(IX,1)
29410 BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
29411 BR=0D0
29412 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
29413 ISF=J+1
29414 ENDIF
29415
29416C...~U_L D
29417 IF(AXMI.GE.XMF+XMSF1) THEN
29418 LKNT=LKNT+1
29419 XMA2=XMSF1**2
29420 XMB2=XMF**2
29421 XL=PYLAMF(XMI2,XMA2,XMB2)
29422 CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
29423 CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
29424 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29425 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29426 IDLAM(LKNT,3)=0
29427 IF(MOD(J,2).EQ.0) THEN
29428 IDLAM(LKNT,1)=-KF1
29429 IDLAM(LKNT,2)=J
29430 ELSE
29431 IDLAM(LKNT,1)=KF1
29432 IDLAM(LKNT,2)=-J
29433 ENDIF
29434 ENDIF
29435
29436C...U~ D_R
29437 IF(AXMI.GE.XMF+XMSF2) THEN
29438 LKNT=LKNT+1
29439 XMA2=XMSF2**2
29440 XMB2=XMF**2
29441 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
29442 CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
29443 XL=PYLAMF(XMI2,XMA2,XMB2)
29444 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29445 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29446 IDLAM(LKNT,3)=0
29447 IF(MOD(J,2).EQ.0) THEN
29448 IDLAM(LKNT,1)=-KF2
29449 IDLAM(LKNT,2)=J
29450 ELSE
29451 IDLAM(LKNT,1)=KF2
29452 IDLAM(LKNT,2)=-J
29453 ENDIF
29454 ENDIF
29455 200 CONTINUE
29456
29457C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
29458C...A 2-BODY -- 2-BODY CHAIN
29459 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
29460 IF(AXMI.GE.XMJ) THEN
29461 AXMJ=ABS(XMJ)
29462 S12MIN=0D0
29463 S12MAX=(AXMI-AXMJ)**2
29464 XXM(1)=0D0
29465 XXM(2)=XMJ
29466 XXM(3)=0D0
29467 XXM(4)=XMI
29468 XXM(5)=0D0
29469 XXM(6)=0D0
29470 XXM(9)=1D6
29471 XXM(10)=0D0
29472 XXM(7)=UMIX(IX,1)*SR2
29473 XXM(8)=VMIX(IX,1)*SR2
29474 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29475 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29476 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
29477 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29478 LKNT=LKNT+1
29479 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29480 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29481 IDLAM(LKNT,1)=KSUSY1+21
29482 IDLAM(LKNT,2)=-1
29483 IDLAM(LKNT,3)=2
29484 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29485 LKNT=LKNT+1
29486 XLAM(LKNT)=XLAM(LKNT-1)
29487 IDLAM(LKNT,1)=KSUSY1+21
29488 IDLAM(LKNT,2)=-3
29489 IDLAM(LKNT,3)=4
29490 ENDIF
29491 ENDIF
29492 210 CONTINUE
29493 ENDIF
29494
29495 220 IKNT=LKNT
29496 XLAM(0)=0D0
29497 DO 230 I=1,IKNT
29498 XLAM(0)=XLAM(0)+XLAM(I)
29499 IF(XLAM(I).LT.0D0) THEN
29500 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
29501 & (IDLAM(I,J),J=1,3)
29502 XLAM(I)=0D0
29503 ENDIF
29504 230 CONTINUE
29505 IF(XLAM(0).EQ.0D0) THEN
29506 XLAM(0)=1D-6
29507 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
29508 WRITE(MSTU(11),*) LKNT
29509 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
29510 ENDIF
29511
29512 RETURN
29513 END
29514
29515C*********************************************************************
29516
29517C...PYXXZ5
29518C...Calculates chi0 -> chi0 + f + ~f.
29519
29520 FUNCTION PYXXZ5(X)
29521
29522C...Double precision and integer declarations.
29523 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29524 INTEGER PYK,PYCHGE,PYCOMP
29525C...Parameter statement to help give large particle numbers.
29526 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29527C...Commonblocks.
29528 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29529 COMMON/PYINTS/XXM(20)
29530 SAVE /PYDAT1/,/PYINTS/
29531
29532C...Local variables.
29533 DOUBLE PRECISION PYXXZ5,X
29534 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
29535 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
29536 DOUBLE PRECISION SIJ
29537 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
29538 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
29539 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29540 INTEGER I
29541 DATA SR2/1.4142136D0/
29542
29543C...Statement functions.
29544C...Integral from x to y of (t-a)(b-t) dt.
29545 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29546C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29547 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29548 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29549C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29550 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29551 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29552C...Integral from x to y of (t-a)/(b-t) dt.
29553 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29554C...Integral from x to y of 1/(t-a) dt.
29555 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29556
29557 XM12=XXM(1)**2
29558 XM22=XXM(2)**2
29559 XM32=XXM(3)**2
29560 S=XXM(4)**2
29561 S13=X
29562
29563 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29564 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29565 &( (X-XM22-S)**2 -4D0*XM22*S ) )
29566
29567 S23MIN=(S23AVE-S23DEL)
29568 S23MAX=(S23AVE+S23DEL)
29569
29570 XMV=XXM(7)
29571 XMG=XXM(8)
29572 XMSD=XXM(5)**2
29573 XMSU=XXM(6)**2
29574 OL=XXM(9)
29575 OR=XXM(10)
29576 OL2=OL**2
29577 OR2=OR**2
29578 LE=XXM(11)
29579 RE=XXM(12)
29580 LE2=LE**2
29581 RE2=RE**2
29582 FLI=XXM(13)
29583 FLJ=XXM(14)
29584 FRI=XXM(15)
29585 FRJ=XXM(16)
29586
29587 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29588 SIJ=2D0*XXM(2)*XXM(4)*S13
29589
29590 IF(XMV.LE.1000D0) THEN
29591 WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
29592 & +SIJ*(S23MAX-S23MIN) )/WPROP2
29593 IF(XXM(5).LE.10000D0) THEN
29594 WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29595 & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
29596 WFL1=WFL1*(S13-XMV**2)/WPROP2
29597 ELSE
29598 WFL1=0D0
29599 ENDIF
29600 IF(XXM(6).LE.10000D0) THEN
29601 WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29602 & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
29603 WFL2=WFL2*(S13-XMV**2)/WPROP2
29604 ELSE
29605 WFL2=0D0
29606 ENDIF
29607 ELSE
29608 WW=0D0
29609 WFL1=0D0
29610 WFL2=0D0
29611 ENDIF
29612 IF(XXM(5).LE.10000D0) THEN
29613 WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29614 & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
29615 ELSE
29616 WF1=0D0
29617 ENDIF
29618 IF(XXM(6).LE.10000D0) THEN
29619 WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29620 & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
29621 ELSE
29622 WF2=0D0
29623 ENDIF
29624
29625C...WFL1=0.0
29626C...WFL2=0.0
29627 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
29628 IF(PYXXZ5.LT.0D0) THEN
29629 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
29630 WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
29631 WRITE(MSTU(11),*) (XXM(I),I=5,8)
29632 WRITE(MSTU(11),*) (XXM(I),I=9,12)
29633 WRITE(MSTU(11),*) (XXM(I),I=13,16)
29634 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
29635 WRITE(MSTU(11),*) S23MIN,S23MAX
29636 PYXXZ5=0D0
29637 ENDIF
29638
29639 RETURN
29640 END
29641
29642C*********************************************************************
29643
29644C...PYXXW5
29645C...Calculates chi0(+) -> chi+(0) + f + ~f'.
29646
29647 FUNCTION PYXXW5(X)
29648
29649C...Double precision and integer declarations.
29650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29651 INTEGER PYK,PYCHGE,PYCOMP
29652C...Parameter statement to help give large particle numbers.
29653 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29654C...Commonblocks.
29655 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29656 COMMON/PYINTS/XXM(20)
29657 SAVE /PYDAT1/,/PYINTS/
29658
29659C...Local variables.
29660 DOUBLE PRECISION PYXXW5,X
29661 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29662 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29663 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
29664 DOUBLE PRECISION SIJ
29665 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29666 INTEGER IK
29667 SAVE IK
29668 DATA IK/0/
29669 DATA SR2/1.4142136D0/
29670
29671C...Statement functions.
29672C...Integral from x to y of (t-a)(b-t) dt.
29673 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29674C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29675 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29676 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29677C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29678 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29679 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29680C...Integral from x to y of (t-a)/(b-t) dt.
29681 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29682C...Integral from x to y of 1/(t-a) dt.
29683 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29684
29685 XM12=XXM(1)**2
29686 XM22=XXM(2)**2
29687 XM32=XXM(3)**2
29688 S=XXM(4)**2
29689 S13=X
29690 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29691 S23AVE=0.5D0*(XM22+S-S13)
29692 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29693 ELSE
29694 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29695 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29696 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
29697 ENDIF
29698 S23MIN=(S23AVE-S23DEL)
29699 S23MAX=(S23AVE+S23DEL)
29700 IF(S23DEL.LT.1D-3) THEN
29701 PYXXW5=0D0
29702 RETURN
29703 ENDIF
29704 XMV=XXM(9)
29705 XMG=XXM(10)
29706 XMSD=XXM(11)**2
29707 XMSU=XXM(12)**2
29708 OL=XXM(5)
29709 OR=XXM(6)
29710 FLD=XXM(7)
29711 FLU=XXM(8)
29712
29713 WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
29714 SIJ=S13*XXM(2)*XXM(4)
29715 IF(XMV.LE.1000D0) THEN
29716 WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
29717 & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
29718 WW=WW/WPROP2
29719 IF(XXM(11).LE.10000D0) THEN
29720 WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
29721 & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29722 WWD=-WWD*SR2*FLD
29723 WWD=WWD*(S13-XMV**2)/WPROP2
29724 ELSE
29725 WWD=0D0
29726 ENDIF
29727 IF(XXM(12).LE.10000D0) THEN
29728 WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
29729 & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29730 WWU=WWU*SR2*FLU
29731 WWU=WWU*(S13-XMV**2)/WPROP2
29732 ELSE
29733 WWU=0D0
29734 ENDIF
29735 ELSE
29736 WW=0D0
29737 WWD=0D0
29738 WWU=0D0
29739 ENDIF
29740 IF(XXM(12).LE.10000D0) THEN
29741 WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29742 ELSE
29743 WU=0D0
29744 ENDIF
29745 IF(XXM(11).LE.10000D0) THEN
29746 WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29747 ELSE
29748 WD=0D0
29749 ENDIF
29750 IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
29751 WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
29752 ELSE
29753 WUD=0D0
29754 ENDIF
29755
29756 PYXXW5=WW+WU+WD+WWU+WWD+WUD
29757
29758 IF(PYXXW5.LT.0D0) THEN
29759 IF(IK.EQ.0) THEN
29760 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
29761 WRITE(MSTU(11),*) WW,WU,WD
29762 WRITE(MSTU(11),*) WWD,WWU,WUD
29763 WRITE(MSTU(11),*) SQRT(S13)
29764 WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
29765 IK=1
29766 ENDIF
29767 PYXXW5=0D0
29768 ENDIF
29769
29770 RETURN
29771 END
29772
29773C*********************************************************************
29774
29775C...PYXXGA
29776C...Calculates chi0_i -> chi0_j + gamma.
29777
29778 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
29779
29780C...Double precision and integer declarations.
29781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29782 INTEGER PYK,PYCHGE,PYCOMP
29783
29784C...Local variables.
29785 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
29786 DOUBLE PRECISION F1,F2
29787
29788 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
29789 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
29790 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
29791 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
29792
29793 RETURN
29794 END
29795
29796C*********************************************************************
29797
29798C...PYX2XG
29799C...Calculates the decay rate for ino -> ino + gauge boson.
29800
29801 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
29802
29803C...Double precision and integer declarations.
29804 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29805 INTEGER PYK,PYCHGE,PYCOMP
29806
29807C...Local variables.
29808 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
29809 DOUBLE PRECISION XL,PYLAMF,C1
29810 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29811
29812 XMI2=XM1**2
29813 XMI3=ABS(XM1**3)
29814 XMJ2=XM2**2
29815 XMV2=XM3**2
29816 XL=PYLAMF(XMI2,XMJ2,XMV2)
29817 PYX2XG=C1/8D0/XMI3*SQRT(XL)
29818 &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
29819 &12D0*GL*GR*XM1*XM2*XMV2)
29820
29821 RETURN
29822 END
29823
29824C*********************************************************************
29825
29826C...PYX2XH
29827C...Calculates the decay rate for ino -> ino + H.
29828
29829 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
29830
29831C...Double precision and integer declarations.
29832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29833 INTEGER PYK,PYCHGE,PYCOMP
29834
29835C...Local variables.
29836 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
29837 DOUBLE PRECISION XL,PYLAMF,C1
29838 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29839
29840 XMI2=XM1**2
29841 XMI3=ABS(XM1**3)
29842 XMJ2=XM2**2
29843 XMV2=XM3**2
29844 XL=PYLAMF(XMI2,XMJ2,XMV2)
29845 PYX2XH=C1/8D0/XMI3*SQRT(XL)
29846 &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
29847 &4D0*GL*GR*XM1*XM2)
29848
29849 RETURN
29850 END
29851
29852C*********************************************************************
29853
29854C...PYXXZ2
29855C...Calculates chi+ -> chi+ + f + ~f.
29856
29857 FUNCTION PYXXZ2(X)
29858
29859C...Double precision and integer declarations.
29860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29861 INTEGER PYK,PYCHGE,PYCOMP
29862C...Parameter statement to help give large particle numbers.
29863 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29864C...Commonblocks.
29865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29866 COMMON/PYINTS/XXM(20)
29867 SAVE /PYDAT1/,/PYINTS/
29868
29869C...Local variables.
29870 DOUBLE PRECISION PYXXZ2,X
29871 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29872 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29873 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
29874 DOUBLE PRECISION SIJ
29875 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
29876 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29877 INTEGER I
29878 DATA SR2/1.4142136D0/
29879
29880C...Statement functions.
29881C...Integral from x to y of (t-a)(b-t) dt.
29882 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29883C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29884 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29885 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29886C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29887 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29888 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29889C...Integral from x to y of 1/(t-a) dt.
29890 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29891
29892 XM12=XXM(1)**2
29893 XM22=XXM(2)**2
29894 XM32=XXM(3)**2
29895 S=XXM(4)**2
29896 S13=X
29897 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29898 S23AVE=0.5D0*(XM22+S-S13)
29899 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29900 ELSE
29901 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29902 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29903 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
29904 ENDIF
29905 S23MIN=(S23AVE-S23DEL)
29906 S23MAX=(S23AVE+S23DEL)
29907 IF(S23DEL.LT.1D-3) THEN
29908 PYXXZ2=0D0
29909 RETURN
29910 ENDIF
29911
29912 XMV=XXM(9)
29913 XMG=XXM(10)
29914 XMSL=XXM(11)**2
29915 OL=XXM(5)
29916 OR=XXM(6)
29917 OL2=OL**2
29918 OR2=OR**2
29919 LE=XXM(7)
29920 RE=XXM(8)
29921 LE2=LE**2
29922 RE2=RE**2
29923 CT=XXM(12)
29924
29925 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29926 SIJ=XXM(2)*XXM(4)*S13
29927 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
29928 &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
29929 WW=WW/WPROP2
29930 IF(XMSL.GT.1D4*S) THEN
29931 WD=0D0
29932 WWD=0D0
29933 ELSE
29934 WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
29935 WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
29936 & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
29937 WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
29938 ENDIF
29939
29940 PYXXZ2=(WW+WD+WWD)
29941 IF(PYXXZ2.LT.0D0) THEN
29942 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
29943 WRITE(MSTU(11),*) WW,WD,WWD
29944 WRITE(MSTU(11),*) S23MIN,S23MAX
29945 WRITE(MSTU(11),*) (XXM(I),I=1,4)
29946 WRITE(MSTU(11),*) (XXM(I),I=5,8)
29947 WRITE(MSTU(11),*) (XXM(I),I=9,12)
29948 PYXXZ2=0D0
29949 ENDIF
29950
29951 RETURN
29952 END
29953
29954C*********************************************************************
29955
29956C...PYHEXT
29957C...Calculates the non-standard decay modes of the Higgs boson.
29958
29959 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
29960
29961C...Double precision and integer declarations.
29962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29963 INTEGER PYK,PYCHGE,PYCOMP
29964C...Parameter statement to help give large particle numbers.
29965 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29966C...Commonblocks.
29967 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29968 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29969 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29970 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29971 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29972 &SFMIX(16,4)
29973 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
29974
29975C...Local variables.
29976 INTEGER KFIN
29977 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
29978 &XMZ,XMZ2,AXMJ,AXMI
29979 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
29980 DOUBLE PRECISION S12MIN,S12MAX
29981 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
29982 DOUBLE PRECISION PYLAMF,XL,CF,EI
29983 INTEGER IDU,IC,ILR,IFL
29984 DOUBLE PRECISION TANW,XW,AEM,C1,AS
29985 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
29986 DOUBLE PRECISION XLAM(0:200)
29987 INTEGER IDLAM(200,3)
29988 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
29989 INTEGER ITH(4)
29990 INTEGER KFNCHI(4),KFCCHI(2)
29991 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
29992 DOUBLE PRECISION SR2
29993 DOUBLE PRECISION BETA,ALFA
29994 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
29995 DOUBLE PRECISION PYALEM,PI,PYALPS
29996 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
29997 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
29998 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
29999 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
30000 DATA ITH/25,35,36,37/
30001 DATA ETAH/1D0,1D0,-1D0/
30002 DATA SR2/1.4142136D0/
30003 DATA PI/3.141592654D0/
30004 DATA KFNCHI/1000022,1000023,1000025,1000035/
30005 DATA KFCCHI/1000024,1000037/
30006
30007C...COUNT THE NUMBER OF DECAY MODES
30008 LKNT=IKNT
30009
30010 XMW=PMAS(24,1)
30011 XMW2=XMW**2
30012 XMZ=PMAS(23,1)
30013 XMZ2=XMZ**2
30014 XW=PARU(102)
30015 TANW = SQRT(XW/(1D0-XW))
30016 CW=SQRT(1D0-XW)
30017
30018C...1 - 4 DEPENDING ON Higgs species.
30019 IH=1
30020 IF(KFIN.EQ.ITH(2)) IH=2
30021 IF(KFIN.EQ.ITH(3)) IH=3
30022 IF(KFIN.EQ.ITH(4)) IH=4
30023
30024 XMI=PMAS(KFIN,1)
30025 XMI2=XMI**2
30026 AXMI=ABS(XMI)
30027 AEM=PYALEM(XMI2)
30028 AS =PYALPS(XMI2)
30029 C1=AEM/XW
30030 XMI3=ABS(XMI**3)
30031
30032 TANB=RMSS(5)
30033 BETA=ATAN(TANB)
30034 CBETA=COS(BETA)
30035 SBETA=TANB*CBETA
30036 ALFA=RMSS(18)
30037 COSA=COS(ALFA)
30038 SINA=SIN(ALFA)
30039 ATRIT=RMSS(16)
30040 ATRIB=RMSS(15)
30041 ATRIL=RMSS(17)
30042 XMUZ=-RMSS(4)
30043
30044 IF(IH.EQ.4) GOTO 180
30045
30046C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
30047C...H0_K -> CHI0_I + CHI0_J
30048 EH(1)=SINA
30049 EH(2)=COSA
30050 EH(3)=-SBETA
30051 DH(1)=COSA
30052 DH(2)=-SINA
30053 DH(3)=CBETA
30054 DO 110 IJ=1,4
30055 XMJ=SMZ(IJ)
30056 AXMJ=ABS(XMJ)
30057 DO 100 IK=1,IJ
30058 XMK=SMZ(IK)
30059 AXMK=ABS(XMK)
30060 IF(AXMI.GE.AXMJ+AXMK) THEN
30061 LKNT=LKNT+1
30062 F21K=0.5D0*
30063 & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
30064 & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
30065 & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
30066 & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
30067 F12K=0.5D0*
30068 & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
30069 & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
30070 & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
30071 & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
30072C...SIGN OF MASSES I,J
30073 XML=XMK*ETAH(IH)
30074 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30075 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
30076 IDLAM(LKNT,1)=KFNCHI(IJ)
30077 IDLAM(LKNT,2)=KFNCHI(IK)
30078 IDLAM(LKNT,3)=0
30079 ENDIF
30080 100 CONTINUE
30081 110 CONTINUE
30082
30083C...H0_K -> CHI+_I CHI-_J
30084 DO 130 IJ=1,2
30085 XMJ=SMW(IJ)
30086 AXMJ=ABS(XMJ)
30087 DO 120 IK=1,2
30088 XMK=SMW(IK)
30089 AXMK=ABS(XMK)
30090 IF(AXMI.GE.AXMJ+AXMK) THEN
30091 LKNT=LKNT+1
30092 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
30093 & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
30094 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
30095 & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
30096 XML=-XMK*ETAH(IH)
30097 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30098 IDLAM(LKNT,1)=KFCCHI(IJ)
30099 IDLAM(LKNT,2)=-KFCCHI(IK)
30100 IDLAM(LKNT,3)=0
30101 ENDIF
30102 120 CONTINUE
30103 130 CONTINUE
30104
30105C...HIGGS TO SFERMION SFERMION
30106 DO 160 IFL=1,16
30107 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
30108 IJ=KSUSY1+IFL
30109 XMJL=PMAS(PYCOMP(IJ),1)
30110 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
30111 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
30112 XMJ=XMJL
30113 XMJ2=XMJ**2
30114 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30115 XMF=PMAS(IFL,1)
30116 EI=KCHG(IFL,1)/3D0
30117 IDU=2-MOD(IFL,2)
30118
30119 IF(IH.EQ.1) THEN
30120 IF(IDU.EQ.1) THEN
30121 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
30122 & XMF**2/XMW*SINA/CBETA
30123 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
30124 & XMF**2/XMW*SINA/CBETA
30125 IF(IFL.EQ.5) THEN
30126 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30127 & ATRIB*SINA)
30128 ELSEIF(IFL.EQ.15) THEN
30129 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30130 & ATRIL*SINA)
30131 ELSE
30132 GHLR=0D0
30133 ENDIF
30134 ELSE
30135 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
30136 & XMF**2/XMW*COSA/SBETA
30137 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
30138 & XMF**2/XMW*COSA/SBETA
30139 IF(IFL.EQ.6) THEN
30140 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
30141 & ATRIT*COSA)
30142 ELSE
30143 GHLR=0D0
30144 ENDIF
30145 ENDIF
30146
30147 ELSEIF(IH.EQ.2) THEN
30148 IF(IDU.EQ.1) THEN
30149 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
30150 & XMF**2/XMW*COSA/CBETA
30151 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30152 & XMF**2/XMW*COSA/CBETA
30153 IF(IFL.EQ.5) THEN
30154 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30155 & ATRIB*COSA)
30156 ELSEIF(IFL.EQ.15) THEN
30157 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30158 & ATRIL*COSA)
30159 ELSE
30160 GHLR=0D0
30161 ENDIF
30162 ELSE
30163 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
30164 & XMF**2/XMW*SINA/SBETA
30165 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30166 & XMF**2/XMW*SINA/SBETA
30167 IF(IFL.EQ.6) THEN
30168 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
30169 & ATRIT*SINA)
30170 ELSE
30171 GHLR=0D0
30172 ENDIF
30173 ENDIF
30174
30175 ELSEIF(IH.EQ.3) THEN
30176 GHLL=0D0
30177 GHRR=0D0
30178 GHLR=0D0
30179 IF(IDU.EQ.1) THEN
30180 IF(IFL.EQ.5) THEN
30181 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
30182 ELSEIF(IFL.EQ.15) THEN
30183 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
30184 ENDIF
30185 ELSE
30186 IF(IFL.EQ.6) THEN
30187 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
30188 ENDIF
30189 ENDIF
30190 ENDIF
30191 IF(IH.EQ.3) GOTO 140
30192
30193 AL=SFMIX(IFL,1)**2
30194 AR=SFMIX(IFL,2)**2
30195 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
30196 IF(IFL.LE.6) THEN
30197 CF=3D0
30198 ELSE
30199 CF=1D0
30200 ENDIF
30201
30202 IF(AXMI.GE.2D0*XMJ) THEN
30203 LKNT=LKNT+1
30204 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30205 & (GHLL*AL+GHRR*AR
30206 & +2D0*GHLR*ALR)**2
30207 IDLAM(LKNT,1)=IJ
30208 IDLAM(LKNT,2)=-IJ
30209 IDLAM(LKNT,3)=0
30210 ENDIF
30211
30212 IF(AXMI.GE.2D0*XMJR) THEN
30213 LKNT=LKNT+1
30214 AL=SFMIX(IFL,3)**2
30215 AR=SFMIX(IFL,4)**2
30216 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
30217 XMJ=XMJR
30218 XMJ2=XMJ**2
30219 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30220 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30221 & (GHLL*AL+GHRR*AR
30222 & +2D0*GHLR*ALR)**2
30223 IDLAM(LKNT,1)=IJ+KSUSY1
30224 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30225 IDLAM(LKNT,3)=0
30226 ENDIF
30227 140 CONTINUE
30228
30229 IF(AXMI.GE.XMJL+XMJR) THEN
30230 LKNT=LKNT+1
30231 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
30232 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
30233 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
30234 XMJ=XMJR
30235 XMJ2=XMJ**2
30236 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
30237 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30238 & (GHLL*AL+GHRR*AR)**2
30239 IDLAM(LKNT,1)=IJ
30240 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30241 IDLAM(LKNT,3)=0
30242 LKNT=LKNT+1
30243 IDLAM(LKNT,1)=-IJ
30244 IDLAM(LKNT,2)=IJ+KSUSY1
30245 IDLAM(LKNT,3)=0
30246 XLAM(LKNT)=XLAM(LKNT-1)
30247 ENDIF
30248 ENDIF
30249 150 CONTINUE
30250 160 CONTINUE
30251 170 CONTINUE
30252
30253 GOTO 230
30254 180 CONTINUE
30255
30256C...H+ -> CHI+_I + CHI0_J
30257 DO 200 IJ=1,4
30258 XMJ=SMZ(IJ)
30259 AXMJ=ABS(XMJ)
30260 XMJ2=XMJ**2
30261 DO 190 IK=1,2
30262 XMK=SMW(IK)
30263 AXMK=ABS(XMK)
30264 XMK2=XMK**2
30265 IF(AXMI.GE.AXMJ+AXMK) THEN
30266 LKNT=LKNT+1
30267 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
30268 & TANW)*VMIX(IK,2)/SR2)
30269 GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
30270 & TANW)*UMIX(IK,2)/SR2)
30271 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
30272 IDLAM(LKNT,1)=KFNCHI(IJ)
30273 IDLAM(LKNT,2)=KFCCHI(IK)
30274 IDLAM(LKNT,3)=0
30275 ENDIF
30276 190 CONTINUE
30277 200 CONTINUE
30278
30279 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
30280 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
30281 AL=0D0
30282 AR=0D0
30283 CF=3D0
30284
30285C...H+ -> T_1 B_1~
30286 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30287 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30288 IF(XMI.GE.XM1+XM2) THEN
30289 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30290 LKNT=LKNT+1
30291 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30292 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
30293 IDLAM(LKNT,1)=KSUSY1+6
30294 IDLAM(LKNT,2)=-(KSUSY1+5)
30295 IDLAM(LKNT,3)=0
30296 ENDIF
30297
30298C...H+ -> T_2 B_1~
30299 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30300 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30301 IF(XMI.GE.XM1+XM2) THEN
30302 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30303 LKNT=LKNT+1
30304 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30305 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
30306 IDLAM(LKNT,1)=KSUSY2+6
30307 IDLAM(LKNT,2)=-(KSUSY1+5)
30308 IDLAM(LKNT,3)=0
30309 ENDIF
30310
30311C...H+ -> T_1 B_2~
30312 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30313 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30314 IF(XMI.GE.XM1+XM2) THEN
30315 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30316 LKNT=LKNT+1
30317 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30318 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
30319 IDLAM(LKNT,1)=KSUSY1+6
30320 IDLAM(LKNT,2)=-(KSUSY2+5)
30321 IDLAM(LKNT,3)=0
30322 ENDIF
30323
30324C...H+ -> T_2 B_2~
30325 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30326 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30327 IF(XMI.GE.XM1+XM2) THEN
30328 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30329 LKNT=LKNT+1
30330 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30331 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
30332 IDLAM(LKNT,1)=KSUSY2+6
30333 IDLAM(LKNT,2)=-(KSUSY2+5)
30334 IDLAM(LKNT,3)=0
30335 ENDIF
30336
30337C...H+ -> UL DL~
30338 GL=-XMW/SR2*SIN(2D0*BETA)
30339 DO 210 IJ=1,3,2
30340 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30341 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30342 IF(XMI.GE.XM1+XM2) THEN
30343 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30344 LKNT=LKNT+1
30345 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30346 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30347 IDLAM(LKNT,2)=KSUSY1+IJ+1
30348 IDLAM(LKNT,3)=0
30349 ENDIF
30350 210 CONTINUE
30351
30352C...H+ -> EL~ NUL
30353 CF=1D0
30354 DO 220 IJ=11,13,2
30355 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30356 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30357 IF(XMI.GE.XM1+XM2) THEN
30358 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30359 LKNT=LKNT+1
30360 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30361 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30362 IDLAM(LKNT,2)=KSUSY1+IJ+1
30363 IDLAM(LKNT,3)=0
30364 ENDIF
30365 220 CONTINUE
30366
30367C...H+ -> TAU1 NUTAUL
30368 XM1=PMAS(PYCOMP(KSUSY1+15),1)
30369 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30370 IF(XMI.GE.XM1+XM2) THEN
30371 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30372 LKNT=LKNT+1
30373 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
30374 IDLAM(LKNT,1)=-(KSUSY1+15)
30375 IDLAM(LKNT,2)= KSUSY1+16
30376 IDLAM(LKNT,3)=0
30377 ENDIF
30378
30379C...H+ -> TAU2 NUTAUL
30380 XM1=PMAS(PYCOMP(KSUSY2+15),1)
30381 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30382 IF(XMI.GE.XM1+XM2) THEN
30383 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30384 LKNT=LKNT+1
30385 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
30386 IDLAM(LKNT,1)=-(KSUSY2+15)
30387 IDLAM(LKNT,2)= KSUSY1+16
30388 IDLAM(LKNT,3)=0
30389 ENDIF
30390
30391 230 CONTINUE
30392 IKNT=LKNT
30393 XLAM(0)=0D0
30394 DO 240 I=1,IKNT
30395 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
30396 XLAM(0)=XLAM(0)+XLAM(I)
30397 240 CONTINUE
30398 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
30399
30400 RETURN
30401 END
30402
30403C*********************************************************************
30404
30405C...PYH2XX
30406C...Calculates the decay rate for a Higgs to an ino pair.
30407
30408 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
30409
30410C...Double precision and integer declarations.
30411 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30412 INTEGER PYK,PYCHGE,PYCOMP
30413C...Commonblocks.
30414 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30415 SAVE /PYDAT1/
30416
30417C...Local variables.
30418 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
30419 DOUBLE PRECISION XL,PYLAMF,C1
30420 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
30421
30422 XMI2=XM1**2
30423 XMI3=ABS(XM1**3)
30424 XMJ2=XM2**2
30425 XMK2=XM3**2
30426 XL=PYLAMF(XMI2,XMJ2,XMK2)
30427 PYH2XX=C1/4D0/XMI3*SQRT(XL)
30428 &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
30429 &4D0*GL*GR*XM3*XM2)
30430 IF(PYH2XX.LT.0D0) THEN
30431 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
30432 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
30433 STOP
30434 ENDIF
30435
30436 RETURN
30437 END
30438
30439C*********************************************************************
30440
30441C...PYGAUS
30442C...Integration by adaptive Gaussian quadrature.
30443C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
30444
30445 FUNCTION PYGAUS(F, A, B, EPS)
30446
30447C...Double precision and integer declarations.
30448 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30449 INTEGER PYK,PYCHGE,PYCOMP
30450
30451C...Local declarations.
30452 EXTERNAL F
30453 DOUBLE PRECISION W(12), X(12)
30454 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
30455 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
30456 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
30457 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
30458 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
30459 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
30460 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
30461 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
30462 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
30463 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
30464 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
30465 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
30466
30467C...The Gaussian quadrature algorithm.
30468 H = 0D0
30469 IF(B .EQ. A) GO TO 140
30470 CONST = 5D-3 / ABS(B-A)
30471 BB = A
30472 100 CONTINUE
30473 AA = BB
30474 BB = B
30475 110 CONTINUE
30476 C1 = 0.5D0*(BB+AA)
30477 C2 = 0.5D0*(BB-AA)
30478 S8 = 0D0
30479 DO 120 I = 1, 4
30480 U = C2*X(I)
30481 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
30482 120 CONTINUE
30483 S16 = 0D0
30484 DO 130 I = 5, 12
30485 U = C2*X(I)
30486 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
30487 130 CONTINUE
30488 S16 = C2*S16
30489 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
30490 H = H + S16
30491 IF(BB .NE. B) GO TO 100
30492 ELSE
30493 BB = C1
30494 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
30495 H = 0D0
30496 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
30497 GO TO 140
30498 ENDIF
30499 140 CONTINUE
30500 PYGAUS = H
30501
30502 RETURN
30503 END
30504
30505C*********************************************************************
30506
30507C...PYSIMP
30508C...Simpson formula for an integral.
30509
30510 FUNCTION PYSIMP(Y,X0,X1,N)
30511
30512C...Double precision and integer declarations.
30513 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30514 INTEGER PYK,PYCHGE,PYCOMP
30515
30516C...Local variables.
30517 DOUBLE PRECISION Y,X0,X1,H,S
30518 DIMENSION Y(0:N)
30519
30520 S=0D0
30521 H=(X1-X0)/N
30522 DO 100 I=0,N-2,2
30523 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
30524 100 CONTINUE
30525 PYSIMP=S*H/3D0
30526
30527 RETURN
30528 END
30529
30530C*********************************************************************
30531
30532C...PYLAMF
30533C...The standard lambda function.
30534
30535 FUNCTION PYLAMF(X,Y,Z)
30536
30537C...Double precision and integer declarations.
30538 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30539 INTEGER PYK,PYCHGE,PYCOMP
30540
30541C...Local variables.
30542 DOUBLE PRECISION PYLAMF,X,Y,Z
30543
30544 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
30545 IF(PYLAMF.LT.0D0) PYLAMF=0D0
30546
30547 RETURN
30548 END
30549
30550C*********************************************************************
30551
30552C...PYTBDY
30553C...Generates 3-body decays of gauginos.
30554
30555 SUBROUTINE PYTBDY(XM)
30556
30557C...Double precision and integer declarations.
30558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30559 INTEGER PYK,PYCHGE,PYCOMP
30560C...Parameter statement to help give large particle numbers.
30561 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30562C...Commonblocks.
30563 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30565 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30566 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
30567 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30568 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
30569
30570C...Local variables.
30571 DOUBLE PRECISION XM(5)
30572 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
30573 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
30574 DOUBLE PRECISION CPHI1,SPHI1
30575 DOUBLE PRECISION S23DEL,EPS
30576 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
30577 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
30578 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
30579 DATA EPS/1D-6/
30580
30581C...GENERATE S12
30582 S12MIN=(XM(1)+XM(2))**2
30583 S12MAX=(XM(5)-XM(3))**2
30584 YJACO1=S12MAX-S12MIN
30585
30586C...FIND S12*
30587 AX=S12MIN
30588 CX=S12MAX
30589 BX=S12MIN+0.5D0*YJACO1
30590 X0=AX
30591 X3=CX
30592 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30593 X1=BX
30594 X2=BX+C*(CX-BX)
30595 ELSE
30596 X2=BX
30597 X1=BX-C*(BX-AX)
30598 ENDIF
30599
30600C...SOLVE FOR F1 AND F2
30601 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30602 &-(2D0*XM(1)*XM(2))**2
30603 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30604 &-(2D0*XM(3)*XM(5))**2
30605 S23DF1=S23DF1*EPS
30606 S23DF2=S23DF2*EPS
30607 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30608 F1=-2D0*S23DEL/EPS
30609 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30610 &-(2D0*XM(1)*XM(2))**2
30611 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30612 &-(2D0*XM(3)*XM(5))**2
30613 S23DF1=S23DF1*EPS
30614 S23DF2=S23DF2*EPS
30615 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30616 F2=-2D0*S23DEL/EPS
30617
30618 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
30619 IF(F2.LT.F1)THEN
30620 X0=X1
30621 X1=X2
30622 X2=R*X1+C*X3
30623 F1=F2
30624 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30625 & -(2D0*XM(1)*XM(2))**2
30626 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30627 & -(2D0*XM(3)*XM(5))**2
30628 S23DF1=S23DF1*EPS
30629 S23DF2=S23DF2*EPS
30630 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30631 F2=-2D0*S23DEL/EPS
30632 ELSE
30633 X3=X2
30634 X2=X1
30635 X1=R*X2+C*X0
30636 F2=F1
30637 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30638 & -(2D0*XM(1)*XM(2))**2
30639 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30640 & -(2D0*XM(3)*XM(5))**2
30641 S23DF1=S23DF1*EPS
30642 S23DF2=S23DF2*EPS
30643 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30644 F1=-2D0*S23DEL/EPS
30645 ENDIF
30646 GOTO 100
30647 ENDIF
30648C...WE WANT THE MAXIMUM, NOT THE MINIMUM
30649 IF(F1.LT.F2)THEN
30650 GOLDEN=-F1
30651 XMIN=X1
30652 ELSE
30653 GOLDEN=-F2
30654 XMIN=X2
30655 ENDIF
30656
30657 IKNT=0
30658 110 S12=S12MIN+PYR(0)*YJACO1
30659 IKNT=IKNT+1
30660C...GENERATE S23
30661 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
30662 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
30663 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
30664 &-(2D0*XM(1)*XM(2))**2
30665 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
30666 &-(2D0*XM(3)*XM(5))**2
30667 S23DF1=S23DF1*EPS
30668 S23DF2=S23DF2*EPS
30669 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
30670 S23DEL=S23DEL/EPS
30671 S23MIN=S23AVE-S23DEL
30672 S23MAX=S23AVE+S23DEL
30673 YJACO2=S23MAX-S23MIN
30674 S23=S23MIN+PYR(0)*YJACO2
30675
30676C...CHECK THE SAMPLING
30677 IF(IKNT.GT.100) THEN
30678 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
30679 GOTO 120
30680 ENDIF
30681 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
30682 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
30683 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
30684 D2=XM(5)-D1-D3
30685 P1=SQRT(D1*D1-XM(1)**2)
30686 P2=SQRT(D2*D2-XM(2)**2)
30687 P3=SQRT(D3*D3-XM(3)**2)
30688 CTHE1=2D0*PYR(0)-1D0
30689 ANG1=2D0*PYR(0)*PARU(1)
30690 CPHI1=COS(ANG1)
30691 SPHI1=SIN(ANG1)
30692 ARG=1D0-CTHE1**2
30693 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30694 STHE1=SQRT(ARG)
30695 P(N+1,1)=P1*STHE1*CPHI1
30696 P(N+1,2)=P1*STHE1*SPHI1
30697 P(N+1,3)=P1*CTHE1
30698 P(N+1,4)=D1
30699
30700C...GET CPHI3
30701 ANG3=2D0*PYR(0)*PARU(1)
30702 CPHI3=COS(ANG3)
30703 SPHI3=SIN(ANG3)
30704 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
30705 ARG=1D0-CTHE3**2
30706 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30707 STHE3=SQRT(ARG)
30708 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
30709 &+P3*STHE3*SPHI3*SPHI1
30710 &+P3*CTHE3*STHE1*CPHI1
30711 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
30712 &-P3*STHE3*SPHI3*CPHI1
30713 &+P3*CTHE3*STHE1*SPHI1
30714 P(N+3,3)=P3*STHE3*CPHI3*STHE1
30715 &+P3*CTHE3*CTHE1
30716 P(N+3,4)=D3
30717
30718 DO 130 I=1,3
30719 P(N+2,I)=-P(N+1,I)-P(N+3,I)
30720 130 CONTINUE
30721 P(N+2,4)=D2
30722
30723 RETURN
30724 END
30725
30726C*********************************************************************
30727
30728C...PY1ENT
30729C...Stores one parton/particle in commonblock PYJETS.
30730
30731 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
30732
30733C...Double precision and integer declarations.
30734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30735 INTEGER PYK,PYCHGE,PYCOMP
30736C...Commonblocks.
30737 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30738 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30739 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30740 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30741
30742C...Standard checks.
30743 MSTU(28)=0
30744 IF(MSTU(12).GE.1) CALL PYLIST(0)
30745 IPA=MAX(1,IABS(IP))
30746 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
30747 &'(PY1ENT:) writing outside PYJETS memory')
30748 KC=PYCOMP(KF)
30749 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
30750
30751C...Find mass. Reset K, P and V vectors.
30752 PM=0D0
30753 IF(MSTU(10).EQ.1) PM=P(IPA,5)
30754 IF(MSTU(10).GE.2) PM=PYMASS(KF)
30755 DO 100 J=1,5
30756 K(IPA,J)=0
30757 P(IPA,J)=0D0
30758 V(IPA,J)=0D0
30759 100 CONTINUE
30760
30761C...Store parton/particle in K and P vectors.
30762 K(IPA,1)=1
30763 IF(IP.LT.0) K(IPA,1)=2
30764 K(IPA,2)=KF
30765 P(IPA,5)=PM
30766 P(IPA,4)=MAX(PE,PM)
30767 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
30768 P(IPA,1)=PA*SIN(THE)*COS(PHI)
30769 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
30770 P(IPA,3)=PA*COS(THE)
30771
30772C...Set N. Optionally fragment/decay.
30773 N=IPA
30774 IF(IP.EQ.0) CALL PYEXEC
30775
30776 RETURN
30777 END
30778
30779C*********************************************************************
30780
30781C...PY2ENT
30782C...Stores two partons/particles in their CM frame,
30783C...with the first along the +z axis.
30784
30785 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
30786
30787C...Double precision and integer declarations.
30788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30789 INTEGER PYK,PYCHGE,PYCOMP
30790C...Commonblocks.
30791 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30792 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30793 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30794 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30795
30796C...Standard checks.
30797 MSTU(28)=0
30798 IF(MSTU(12).GE.1) CALL PYLIST(0)
30799 IPA=MAX(1,IABS(IP))
30800 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
30801 &'(PY2ENT:) writing outside PYJETS memory')
30802 KC1=PYCOMP(KF1)
30803 KC2=PYCOMP(KF2)
30804 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
30805 &'(PY2ENT:) unknown flavour code')
30806
30807C...Find masses. Reset K, P and V vectors.
30808 PM1=0D0
30809 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30810 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30811 PM2=0D0
30812 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30813 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
30814 DO 110 I=IPA,IPA+1
30815 DO 100 J=1,5
30816 K(I,J)=0
30817 P(I,J)=0D0
30818 V(I,J)=0D0
30819 100 CONTINUE
30820 110 CONTINUE
30821
30822C...Check flavours.
30823 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
30824 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
30825 IF(MSTU(19).EQ.1) THEN
30826 MSTU(19)=0
30827 ELSE
30828 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
30829 & '(PY2ENT:) unphysical flavour combination')
30830 ENDIF
30831 K(IPA,2)=KF1
30832 K(IPA+1,2)=KF2
30833
30834C...Store partons/particles in K vectors for normal case.
30835 IF(IP.GE.0) THEN
30836 K(IPA,1)=1
30837 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
30838 K(IPA+1,1)=1
30839
30840C...Store partons in K vectors for parton shower evolution.
30841 ELSE
30842 K(IPA,1)=3
30843 K(IPA+1,1)=3
30844 K(IPA,4)=MSTU(5)*(IPA+1)
30845 K(IPA,5)=K(IPA,4)
30846 K(IPA+1,4)=MSTU(5)*IPA
30847 K(IPA+1,5)=K(IPA+1,4)
30848 ENDIF
30849
30850C...Check kinematics and store partons/particles in P vectors.
30851 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
30852 &'(PY2ENT:) energy smaller than sum of masses')
30853 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
30854 &(2D0*PECM)
30855 P(IPA,3)=PA
30856 P(IPA,4)=SQRT(PM1**2+PA**2)
30857 P(IPA,5)=PM1
30858 P(IPA+1,3)=-PA
30859 P(IPA+1,4)=SQRT(PM2**2+PA**2)
30860 P(IPA+1,5)=PM2
30861
30862C...Set N. Optionally fragment/decay.
30863 N=IPA+1
30864 IF(IP.EQ.0) CALL PYEXEC
30865
30866 RETURN
30867 END
30868
30869C*********************************************************************
30870
30871C...PY3ENT
30872C...Stores three partons or particles in their CM frame,
30873C...with the first along the +z axis and the third in the (x,z)
30874C...plane with x > 0.
30875
30876 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
30877
30878C...Double precision and integer declarations.
30879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30880 INTEGER PYK,PYCHGE,PYCOMP
30881C...Commonblocks.
30882 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30883 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30884 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30885 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30886
30887C...Standard checks.
30888 MSTU(28)=0
30889 IF(MSTU(12).GE.1) CALL PYLIST(0)
30890 IPA=MAX(1,IABS(IP))
30891 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
30892 &'(PY3ENT:) writing outside PYJETS memory')
30893 KC1=PYCOMP(KF1)
30894 KC2=PYCOMP(KF2)
30895 KC3=PYCOMP(KF3)
30896 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
30897 &'(PY3ENT:) unknown flavour code')
30898
30899C...Find masses. Reset K, P and V vectors.
30900 PM1=0D0
30901 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30902 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30903 PM2=0D0
30904 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30905 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
30906 PM3=0D0
30907 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
30908 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
30909 DO 110 I=IPA,IPA+2
30910 DO 100 J=1,5
30911 K(I,J)=0
30912 P(I,J)=0D0
30913 V(I,J)=0D0
30914 100 CONTINUE
30915 110 CONTINUE
30916
30917C...Check flavours.
30918 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
30919 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
30920 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
30921 IF(MSTU(19).EQ.1) THEN
30922 MSTU(19)=0
30923 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
30924 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
30925 & KQ1+KQ3.EQ.4)) THEN
30926 ELSE
30927 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
30928 ENDIF
30929 K(IPA,2)=KF1
30930 K(IPA+1,2)=KF2
30931 K(IPA+2,2)=KF3
30932
30933C...Store partons/particles in K vectors for normal case.
30934 IF(IP.GE.0) THEN
30935 K(IPA,1)=1
30936 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
30937 K(IPA+1,1)=1
30938 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
30939 K(IPA+2,1)=1
30940
30941C...Store partons in K vectors for parton shower evolution.
30942 ELSE
30943 K(IPA,1)=3
30944 K(IPA+1,1)=3
30945 K(IPA+2,1)=3
30946 KCS=4
30947 IF(KQ1.EQ.-1) KCS=5
30948 K(IPA,KCS)=MSTU(5)*(IPA+1)
30949 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
30950 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
30951 K(IPA+1,9-KCS)=MSTU(5)*IPA
30952 K(IPA+2,KCS)=MSTU(5)*IPA
30953 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
30954 ENDIF
30955
30956C...Check kinematics.
30957 MKERR=0
30958 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
30959 &0.5D0*X3*PECM.LE.PM3) MKERR=1
30960 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
30961 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
30962 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
30963 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
30964 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
30965 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
30966 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
30967 IF(MKERR.NE.0) CALL PYERRM(13,
30968 &'(PY3ENT:) unphysical kinematical variable setup')
30969
30970C...Store partons/particles in P vectors.
30971 P(IPA,3)=PA1
30972 P(IPA,4)=SQRT(PA1**2+PM1**2)
30973 P(IPA,5)=PM1
30974 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
30975 P(IPA+2,3)=PA3*CTHE3
30976 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
30977 P(IPA+2,5)=PM3
30978 P(IPA+1,1)=-P(IPA+2,1)
30979 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
30980 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
30981 P(IPA+1,5)=PM2
30982
30983C...Set N. Optionally fragment/decay.
30984 N=IPA+2
30985 IF(IP.EQ.0) CALL PYEXEC
30986
30987 RETURN
30988 END
30989
30990C*********************************************************************
30991
30992C...PY4ENT
30993C...Stores four partons or particles in their CM frame, with
30994C...the first along the +z axis, the last in the xz plane with x > 0
30995C...and the second having y < 0 and y > 0 with equal probability.
30996
30997 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
30998
30999C...Double precision and integer declarations.
31000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31001 INTEGER PYK,PYCHGE,PYCOMP
31002C...Commonblocks.
31003 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31005 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31006 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31007
31008C...Standard checks.
31009 MSTU(28)=0
31010 IF(MSTU(12).GE.1) CALL PYLIST(0)
31011 IPA=MAX(1,IABS(IP))
31012 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
31013 &'(PY4ENT:) writing outside PYJETS momory')
31014 KC1=PYCOMP(KF1)
31015 KC2=PYCOMP(KF2)
31016 KC3=PYCOMP(KF3)
31017 KC4=PYCOMP(KF4)
31018 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
31019 &'(PY4ENT:) unknown flavour code')
31020
31021C...Find masses. Reset K, P and V vectors.
31022 PM1=0D0
31023 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31024 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31025 PM2=0D0
31026 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31027 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31028 PM3=0D0
31029 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31030 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31031 PM4=0D0
31032 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
31033 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
31034 DO 110 I=IPA,IPA+3
31035 DO 100 J=1,5
31036 K(I,J)=0
31037 P(I,J)=0D0
31038 V(I,J)=0D0
31039 100 CONTINUE
31040 110 CONTINUE
31041
31042C...Check flavours.
31043 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31044 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31045 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31046 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
31047 IF(MSTU(19).EQ.1) THEN
31048 MSTU(19)=0
31049 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
31050 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
31051 & KQ1+KQ4.EQ.4)) THEN
31052 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
31053 & THEN
31054 ELSE
31055 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
31056 ENDIF
31057 K(IPA,2)=KF1
31058 K(IPA+1,2)=KF2
31059 K(IPA+2,2)=KF3
31060 K(IPA+3,2)=KF4
31061
31062C...Store partons/particles in K vectors for normal case.
31063 IF(IP.GE.0) THEN
31064 K(IPA,1)=1
31065 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
31066 K(IPA+1,1)=1
31067 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
31068 & K(IPA+1,1)=2
31069 K(IPA+2,1)=1
31070 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
31071 K(IPA+3,1)=1
31072
31073C...Store partons for parton shower evolution from q-g-g-qbar or
31074C...g-g-g-g event.
31075 ELSEIF(KQ1+KQ2.NE.0) THEN
31076 K(IPA,1)=3
31077 K(IPA+1,1)=3
31078 K(IPA+2,1)=3
31079 K(IPA+3,1)=3
31080 KCS=4
31081 IF(KQ1.EQ.-1) KCS=5
31082 K(IPA,KCS)=MSTU(5)*(IPA+1)
31083 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
31084 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31085 K(IPA+1,9-KCS)=MSTU(5)*IPA
31086 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
31087 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31088 K(IPA+3,KCS)=MSTU(5)*IPA
31089 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
31090
31091C...Store partons for parton shower evolution from q-qbar-q-qbar event.
31092 ELSE
31093 K(IPA,1)=3
31094 K(IPA+1,1)=3
31095 K(IPA+2,1)=3
31096 K(IPA+3,1)=3
31097 K(IPA,4)=MSTU(5)*(IPA+1)
31098 K(IPA,5)=K(IPA,4)
31099 K(IPA+1,4)=MSTU(5)*IPA
31100 K(IPA+1,5)=K(IPA+1,4)
31101 K(IPA+2,4)=MSTU(5)*(IPA+3)
31102 K(IPA+2,5)=K(IPA+2,4)
31103 K(IPA+3,4)=MSTU(5)*(IPA+2)
31104 K(IPA+3,5)=K(IPA+3,4)
31105 ENDIF
31106
31107C...Check kinematics.
31108 MKERR=0
31109 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
31110 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
31111 &MKERR=1
31112 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31113 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
31114 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
31115 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
31116 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
31117 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
31118 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
31119 STHE4=SQRT(1D0-CTHE4**2)
31120 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
31121 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
31122 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
31123 STHE2=SQRT(1D0-CTHE2**2)
31124 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
31125 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
31126 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
31127 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
31128 IF(MKERR.EQ.1) CALL PYERRM(13,
31129 &'(PY4ENT:) unphysical kinematical variable setup')
31130
31131C...Store partons/particles in P vectors.
31132 P(IPA,3)=PA1
31133 P(IPA,4)=SQRT(PA1**2+PM1**2)
31134 P(IPA,5)=PM1
31135 P(IPA+3,1)=PA4*STHE4
31136 P(IPA+3,3)=PA4*CTHE4
31137 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
31138 P(IPA+3,5)=PM4
31139 P(IPA+1,1)=PA2*STHE2*CPHI2
31140 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
31141 P(IPA+1,3)=PA2*CTHE2
31142 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
31143 P(IPA+1,5)=PM2
31144 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
31145 P(IPA+2,2)=-P(IPA+1,2)
31146 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
31147 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
31148 P(IPA+2,5)=PM3
31149
31150C...Set N. Optionally fragment/decay.
31151 N=IPA+3
31152 IF(IP.EQ.0) CALL PYEXEC
31153
31154 RETURN
31155 END
31156
31157C*********************************************************************
31158
31159C...PYJOIN
31160C...Connects a sequence of partons with colour flow indices,
31161C...as required for subsequent shower evolution (or other operations).
31162
31163 SUBROUTINE PYJOIN(NJOIN,IJOIN)
31164
31165C...Double precision and integer declarations.
31166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31167 INTEGER PYK,PYCHGE,PYCOMP
31168C...Commonblocks.
31169 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31170 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31171 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31172 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31173C...Local array.
31174 DIMENSION IJOIN(*)
31175
31176C...Check that partons are of right types to be connected.
31177 IF(NJOIN.LT.2) GOTO 120
31178 KQSUM=0
31179 DO 100 IJN=1,NJOIN
31180 I=IJOIN(IJN)
31181 IF(I.LE.0.OR.I.GT.N) GOTO 120
31182 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
31183 KC=PYCOMP(K(I,2))
31184 IF(KC.EQ.0) GOTO 120
31185 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
31186 IF(KQ.EQ.0) GOTO 120
31187 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
31188 IF(KQ.NE.2) KQSUM=KQSUM+KQ
31189 IF(IJN.EQ.1) KQS=KQ
31190 100 CONTINUE
31191 IF(KQSUM.NE.0) GOTO 120
31192
31193C...Connect the partons sequentially (closing for gluon loop).
31194 KCS=(9-KQS)/2
31195 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
31196 DO 110 IJN=1,NJOIN
31197 I=IJOIN(IJN)
31198 K(I,1)=3
31199 IF(IJN.NE.1) IP=IJOIN(IJN-1)
31200 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
31201 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
31202 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
31203 K(I,KCS)=MSTU(5)*IN
31204 K(I,9-KCS)=MSTU(5)*IP
31205 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
31206 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
31207 110 CONTINUE
31208
31209C...Error exit: no action taken.
31210 RETURN
31211 120 CALL PYERRM(12,
31212 &'(PYJOIN:) given entries can not be joined by one string')
31213
31214 RETURN
31215 END
31216
31217C*********************************************************************
31218
31219C...PYGIVE
31220C...Sets values of commonblock variables.
31221
31222 SUBROUTINE PYGIVE(CHIN)
31223
31224C...Double precision and integer declarations.
31225 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31226 INTEGER PYK,PYCHGE,PYCOMP
31227C...Commonblocks.
31228 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31231 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31232 COMMON/PYDAT4/CHAF(500,2)
31233 CHARACTER CHAF*16
31234 COMMON/PYDATR/MRPY(6),RRPY(100)
31235 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31236 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31237 COMMON/PYINT1/MINT(400),VINT(400)
31238 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31239 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31240 COMMON/PYINT4/MWID(500),WIDS(500,5)
31241 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
31242 COMMON/PYINT6/PROC(0:500)
31243 CHARACTER PROC*28
31244 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
31245 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
31246 &XPDIR(-6:6)
31247 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31248 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
31249 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
31250 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
31251C...Local arrays and character variables.
31252 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
31253 &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
31254 &CHINR*16
31255 DIMENSION MSVAR(49,8)
31256
31257C...For each variable to be translated give: name,
31258C...integer/real/character, no. of indices, lower&upper index bounds.
31259 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
31260 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
31261 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
31262 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
31263 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
31264 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
31265 DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
31266 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
31267 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31268 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
31269 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
31270 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
31271 &1,1,1,6,4*0, 2,1,1,100,4*0,
31272 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
31273 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31274 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
31275 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
31276 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
31277 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
31278 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
31279 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
31280 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
31281 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
31282 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
31283
31284C...Length of character variable. Subdivide it into instructions.
31285 IF(MSTU(12).GE.1) CALL PYLIST(0)
31286 CHBIT=CHIN//' '
31287 LBIT=101
31288 100 LBIT=LBIT-1
31289 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
31290 LTOT=0
31291 DO 110 LCOM=1,LBIT
31292 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
31293 LTOT=LTOT+1
31294 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
31295 110 CONTINUE
31296 LLOW=0
31297 120 LHIG=LLOW+1
31298 130 LHIG=LHIG+1
31299 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
31300 LBIT=LHIG-LLOW-1
31301 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
31302
31303C...Identify commonblock variable.
31304 LNAM=1
31305 140 LNAM=LNAM+1
31306 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
31307 &LNAM.LE.6) GOTO 140
31308 CHNAM=CHBIT(1:LNAM-1)//' '
31309 DO 160 LCOM=1,LNAM-1
31310 DO 150 LALP=1,26
31311 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
31312 & CHALP(2)(LALP:LALP)
31313 150 CONTINUE
31314 160 CONTINUE
31315 IVAR=0
31316 DO 170 IV=1,49
31317 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
31318 170 CONTINUE
31319 IF(IVAR.EQ.0) THEN
31320 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
31321 LLOW=LHIG
31322 IF(LLOW.LT.LTOT) GOTO 120
31323 RETURN
31324 ENDIF
31325
31326C...Identify any indices.
31327 I1=0
31328 I2=0
31329 I3=0
31330 NINDX=0
31331 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
31332 LIND=LNAM
31333 180 LIND=LIND+1
31334 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
31335 CHIND=' '
31336 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
31337 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
31338 & THEN
31339 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
31340 READ(CHIND,'(I8)') KF
31341 I1=PYCOMP(KF)
31342 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
31343 & 'c') THEN
31344 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
31345 & CHNAM)
31346 LLOW=LHIG
31347 IF(LLOW.LT.LTOT) GOTO 120
31348 RETURN
31349 ELSE
31350 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31351 READ(CHIND,'(I8)') I1
31352 ENDIF
31353 LNAM=LIND
31354 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31355 NINDX=1
31356 ENDIF
31357 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31358 LIND=LNAM
31359 190 LIND=LIND+1
31360 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
31361 CHIND=' '
31362 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31363 READ(CHIND,'(I8)') I2
31364 LNAM=LIND
31365 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31366 NINDX=2
31367 ENDIF
31368 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31369 LIND=LNAM
31370 200 LIND=LIND+1
31371 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
31372 CHIND=' '
31373 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31374 READ(CHIND,'(I8)') I3
31375 LNAM=LIND+1
31376 NINDX=3
31377 ENDIF
31378
31379C...Check that indices allowed.
31380 IERR=0
31381 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
31382 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
31383 &IERR=2
31384 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
31385 &IERR=3
31386 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
31387 &IERR=4
31388 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
31389 IF(IERR.GE.1) THEN
31390 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
31391 & CHBIT(1:LNAM-1))
31392 LLOW=LHIG
31393 IF(LLOW.LT.LTOT) GOTO 120
31394 RETURN
31395 ENDIF
31396
31397C...Save old value of variable.
31398 IF(IVAR.EQ.1) THEN
31399 IOLD=N
31400 ELSEIF(IVAR.EQ.2) THEN
31401 IOLD=K(I1,I2)
31402 ELSEIF(IVAR.EQ.3) THEN
31403 ROLD=P(I1,I2)
31404 ELSEIF(IVAR.EQ.4) THEN
31405 ROLD=V(I1,I2)
31406 ELSEIF(IVAR.EQ.5) THEN
31407 IOLD=MSTU(I1)
31408 ELSEIF(IVAR.EQ.6) THEN
31409 ROLD=PARU(I1)
31410 ELSEIF(IVAR.EQ.7) THEN
31411 IOLD=MSTJ(I1)
31412 ELSEIF(IVAR.EQ.8) THEN
31413 ROLD=PARJ(I1)
31414 ELSEIF(IVAR.EQ.9) THEN
31415 IOLD=KCHG(I1,I2)
31416 ELSEIF(IVAR.EQ.10) THEN
31417 ROLD=PMAS(I1,I2)
31418 ELSEIF(IVAR.EQ.11) THEN
31419 ROLD=PARF(I1)
31420 ELSEIF(IVAR.EQ.12) THEN
31421 ROLD=VCKM(I1,I2)
31422 ELSEIF(IVAR.EQ.13) THEN
31423 IOLD=MDCY(I1,I2)
31424 ELSEIF(IVAR.EQ.14) THEN
31425 IOLD=MDME(I1,I2)
31426 ELSEIF(IVAR.EQ.15) THEN
31427 ROLD=BRAT(I1)
31428 ELSEIF(IVAR.EQ.16) THEN
31429 IOLD=KFDP(I1,I2)
31430 ELSEIF(IVAR.EQ.17) THEN
31431 CHOLD=CHAF(I1,I2)
31432 ELSEIF(IVAR.EQ.18) THEN
31433 IOLD=MRPY(I1)
31434 ELSEIF(IVAR.EQ.19) THEN
31435 ROLD=RRPY(I1)
31436 ELSEIF(IVAR.EQ.20) THEN
31437 IOLD=MSEL
31438 ELSEIF(IVAR.EQ.21) THEN
31439 IOLD=MSUB(I1)
31440 ELSEIF(IVAR.EQ.22) THEN
31441 IOLD=KFIN(I1,I2)
31442 ELSEIF(IVAR.EQ.23) THEN
31443 ROLD=CKIN(I1)
31444 ELSEIF(IVAR.EQ.24) THEN
31445 IOLD=MSTP(I1)
31446 ELSEIF(IVAR.EQ.25) THEN
31447 ROLD=PARP(I1)
31448 ELSEIF(IVAR.EQ.26) THEN
31449 IOLD=MSTI(I1)
31450 ELSEIF(IVAR.EQ.27) THEN
31451 ROLD=PARI(I1)
31452 ELSEIF(IVAR.EQ.28) THEN
31453 IOLD=MINT(I1)
31454 ELSEIF(IVAR.EQ.29) THEN
31455 ROLD=VINT(I1)
31456 ELSEIF(IVAR.EQ.30) THEN
31457 IOLD=ISET(I1)
31458 ELSEIF(IVAR.EQ.31) THEN
31459 IOLD=KFPR(I1,I2)
31460 ELSEIF(IVAR.EQ.32) THEN
31461 ROLD=COEF(I1,I2)
31462 ELSEIF(IVAR.EQ.33) THEN
31463 IOLD=ICOL(I1,I2,I3)
31464 ELSEIF(IVAR.EQ.34) THEN
31465 ROLD=XSFX(I1,I2)
31466 ELSEIF(IVAR.EQ.35) THEN
31467 IOLD=ISIG(I1,I2)
31468 ELSEIF(IVAR.EQ.36) THEN
31469 ROLD=SIGH(I1)
31470 ELSEIF(IVAR.EQ.37) THEN
31471 IOLD=MWID(I1)
31472 ELSEIF(IVAR.EQ.38) THEN
31473 ROLD=WIDS(I1,I2)
31474 ELSEIF(IVAR.EQ.39) THEN
31475 IOLD=NGEN(I1,I2)
31476 ELSEIF(IVAR.EQ.40) THEN
31477 ROLD=XSEC(I1,I2)
31478 ELSEIF(IVAR.EQ.41) THEN
31479 CHOLD2=PROC(I1)
31480 ELSEIF(IVAR.EQ.42) THEN
31481 ROLD=SIGT(I1,I2,I3)
31482 ELSEIF(IVAR.EQ.43) THEN
31483 ROLD=XPVMD(I1)
31484 ELSEIF(IVAR.EQ.44) THEN
31485 ROLD=XPANL(I1)
31486 ELSEIF(IVAR.EQ.45) THEN
31487 ROLD=XPANH(I1)
31488 ELSEIF(IVAR.EQ.46) THEN
31489 ROLD=XPBEH(I1)
31490 ELSEIF(IVAR.EQ.47) THEN
31491 ROLD=XPDIR(I1)
31492 ELSEIF(IVAR.EQ.48) THEN
31493 IOLD=IMSS(I1)
31494 ELSEIF(IVAR.EQ.49) THEN
31495 ROLD=RMSS(I1)
31496 ENDIF
31497
31498C...Print current value of variable. Loop back.
31499 IF(LNAM.GE.LBIT) THEN
31500 CHBIT(LNAM:14)=' '
31501 CHBIT(15:60)=' has the value '
31502 IF(MSVAR(IVAR,1).EQ.1) THEN
31503 WRITE(CHBIT(51:60),'(I10)') IOLD
31504 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31505 WRITE(CHBIT(47:60),'(F14.5)') ROLD
31506 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31507 CHBIT(53:60)=CHOLD
31508 ELSE
31509 CHBIT(33:60)=CHOLD
31510 ENDIF
31511 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31512 LLOW=LHIG
31513 IF(LLOW.LT.LTOT) GOTO 120
31514 RETURN
31515 ENDIF
31516
31517C...Read in new variable value.
31518 IF(MSVAR(IVAR,1).EQ.1) THEN
31519 CHINI=' '
31520 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
31521 READ(CHINI,'(I10)') INEW
31522 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31523 CHINR=' '
31524 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
31525 READ(CHINR,*) RNEW
31526 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31527 CHNEW=CHBIT(LNAM+1:LBIT)//' '
31528 ELSE
31529 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
31530 ENDIF
31531
31532C...Store new variable value.
31533 IF(IVAR.EQ.1) THEN
31534 N=INEW
31535 ELSEIF(IVAR.EQ.2) THEN
31536 K(I1,I2)=INEW
31537 ELSEIF(IVAR.EQ.3) THEN
31538 P(I1,I2)=RNEW
31539 ELSEIF(IVAR.EQ.4) THEN
31540 V(I1,I2)=RNEW
31541 ELSEIF(IVAR.EQ.5) THEN
31542 MSTU(I1)=INEW
31543 ELSEIF(IVAR.EQ.6) THEN
31544 PARU(I1)=RNEW
31545 ELSEIF(IVAR.EQ.7) THEN
31546 MSTJ(I1)=INEW
31547 ELSEIF(IVAR.EQ.8) THEN
31548 PARJ(I1)=RNEW
31549 ELSEIF(IVAR.EQ.9) THEN
31550 KCHG(I1,I2)=INEW
31551 ELSEIF(IVAR.EQ.10) THEN
31552 PMAS(I1,I2)=RNEW
31553 ELSEIF(IVAR.EQ.11) THEN
31554 PARF(I1)=RNEW
31555 ELSEIF(IVAR.EQ.12) THEN
31556 VCKM(I1,I2)=RNEW
31557 ELSEIF(IVAR.EQ.13) THEN
31558 MDCY(I1,I2)=INEW
31559 ELSEIF(IVAR.EQ.14) THEN
31560 MDME(I1,I2)=INEW
31561 ELSEIF(IVAR.EQ.15) THEN
31562 BRAT(I1)=RNEW
31563 ELSEIF(IVAR.EQ.16) THEN
31564 KFDP(I1,I2)=INEW
31565 ELSEIF(IVAR.EQ.17) THEN
31566 CHAF(I1,I2)=CHNEW
31567 ELSEIF(IVAR.EQ.18) THEN
31568 MRPY(I1)=INEW
31569 ELSEIF(IVAR.EQ.19) THEN
31570 RRPY(I1)=RNEW
31571 ELSEIF(IVAR.EQ.20) THEN
31572 MSEL=INEW
31573 ELSEIF(IVAR.EQ.21) THEN
31574 MSUB(I1)=INEW
31575 ELSEIF(IVAR.EQ.22) THEN
31576 KFIN(I1,I2)=INEW
31577 ELSEIF(IVAR.EQ.23) THEN
31578 CKIN(I1)=RNEW
31579 ELSEIF(IVAR.EQ.24) THEN
31580 MSTP(I1)=INEW
31581 ELSEIF(IVAR.EQ.25) THEN
31582 PARP(I1)=RNEW
31583 ELSEIF(IVAR.EQ.26) THEN
31584 MSTI(I1)=INEW
31585 ELSEIF(IVAR.EQ.27) THEN
31586 PARI(I1)=RNEW
31587 ELSEIF(IVAR.EQ.28) THEN
31588 MINT(I1)=INEW
31589 ELSEIF(IVAR.EQ.29) THEN
31590 VINT(I1)=RNEW
31591 ELSEIF(IVAR.EQ.30) THEN
31592 ISET(I1)=INEW
31593 ELSEIF(IVAR.EQ.31) THEN
31594 KFPR(I1,I2)=INEW
31595 ELSEIF(IVAR.EQ.32) THEN
31596 COEF(I1,I2)=RNEW
31597 ELSEIF(IVAR.EQ.33) THEN
31598 ICOL(I1,I2,I3)=INEW
31599 ELSEIF(IVAR.EQ.34) THEN
31600 XSFX(I1,I2)=RNEW
31601 ELSEIF(IVAR.EQ.35) THEN
31602 ISIG(I1,I2)=INEW
31603 ELSEIF(IVAR.EQ.36) THEN
31604 SIGH(I1)=RNEW
31605 ELSEIF(IVAR.EQ.37) THEN
31606 MWID(I1)=INEW
31607 ELSEIF(IVAR.EQ.38) THEN
31608 WIDS(I1,I2)=RNEW
31609 ELSEIF(IVAR.EQ.39) THEN
31610 NGEN(I1,I2)=INEW
31611 ELSEIF(IVAR.EQ.40) THEN
31612 XSEC(I1,I2)=RNEW
31613 ELSEIF(IVAR.EQ.41) THEN
31614 PROC(I1)=CHNEW2
31615 ELSEIF(IVAR.EQ.42) THEN
31616 SIGT(I1,I2,I3)=RNEW
31617 ELSEIF(IVAR.EQ.43) THEN
31618 XPVMD(I1)=RNEW
31619 ELSEIF(IVAR.EQ.44) THEN
31620 XPANL(I1)=RNEW
31621 ELSEIF(IVAR.EQ.45) THEN
31622 XPANH(I1)=RNEW
31623 ELSEIF(IVAR.EQ.46) THEN
31624 XPBEH(I1)=RNEW
31625 ELSEIF(IVAR.EQ.47) THEN
31626 XPDIR(I1)=RNEW
31627 ELSEIF(IVAR.EQ.48) THEN
31628 IMSS(I1)=INEW
31629 ELSEIF(IVAR.EQ.49) THEN
31630 RMSS(I1)=RNEW
31631 ENDIF
31632
31633C...Write old and new value. Loop back.
31634 CHBIT(LNAM:14)=' '
31635 CHBIT(15:60)=' changed from to '
31636 IF(MSVAR(IVAR,1).EQ.1) THEN
31637 WRITE(CHBIT(33:42),'(I10)') IOLD
31638 WRITE(CHBIT(51:60),'(I10)') INEW
31639 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31640 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31641 WRITE(CHBIT(29:42),'(F14.5)') ROLD
31642 WRITE(CHBIT(47:60),'(F14.5)') RNEW
31643 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31644 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31645 CHBIT(35:42)=CHOLD
31646 CHBIT(53:60)=CHNEW
31647 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31648 ELSE
31649 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
31650 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
31651 ENDIF
31652 LLOW=LHIG
31653 IF(LLOW.LT.LTOT) GOTO 120
31654
31655C...Format statement for output on unit MSTU(11) (by default 6).
31656 5000 FORMAT(5X,A60)
31657 5100 FORMAT(5X,A88)
31658
31659 RETURN
31660 END
31661
31662C*********************************************************************
31663
31664C...PYEXEC
31665C...Administrates the fragmentation and decay chain.
31666
31667 SUBROUTINE PYEXEC
31668
31669C...Double precision and integer declarations.
31670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31671 INTEGER PYK,PYCHGE,PYCOMP
31672C...Commonblocks.
31673 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31676 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31677 COMMON/PYINT4/MWID(500),WIDS(500,5)
31678 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
31679C...Local array.
31680 DIMENSION PS(2,6),IJOIN(100)
31681
31682C...Initialize and reset.
31683 MSTU(24)=0
31684 IF(MSTU(12).GE.1) CALL PYLIST(0)
31685 MSTU(31)=MSTU(31)+1
31686 MSTU(1)=0
31687 MSTU(2)=0
31688 MSTU(3)=0
31689 IF(MSTU(17).LE.0) MSTU(90)=0
31690 MCONS=1
31691
31692C...Sum up momentum, energy and charge for starting entries.
31693 NSAV=N
31694 DO 110 I=1,2
31695 DO 100 J=1,6
31696 PS(I,J)=0D0
31697 100 CONTINUE
31698 110 CONTINUE
31699 DO 130 I=1,N
31700 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
31701 DO 120 J=1,4
31702 PS(1,J)=PS(1,J)+P(I,J)
31703 120 CONTINUE
31704 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
31705 130 CONTINUE
31706 PARU(21)=PS(1,4)
31707
31708C...Prepare system for subsequent fragmentation/decay.
31709 CALL PYPREP(0)
31710
31711C...Loop through jet fragmentation and particle decays.
31712 MBE=0
31713 140 MBE=MBE+1
31714 IP=0
31715 150 IP=IP+1
31716 KC=0
31717 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
31718 IF(KC.EQ.0) THEN
31719
31720C...Deal with any remaining undecayed resonance
31721C...(normally the task of PYEVNT, so seldom used).
31722 ELSEIF(MWID(KC).NE.0) THEN
31723 IBEG=IP
31724 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
31725 IBEG=IP+1
31726 160 IBEG=IBEG-1
31727 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
31728 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
31729 IEND=IP-1
31730 170 IEND=IEND+1
31731 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
31732 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
31733 NJOIN=0
31734 DO 180 I=IBEG,IEND
31735 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
31736 NJOIN=NJOIN+1
31737 IJOIN(NJOIN)=I
31738 ENDIF
31739 180 CONTINUE
31740 ENDIF
31741 CALL PYRESD(IP)
31742 CALL PYPREP(IBEG)
31743
31744C...Particle decay if unstable and allowed. Save long-lived particle
31745C...decays until second pass after Bose-Einstein effects.
31746 ELSEIF(KCHG(KC,2).EQ.0) THEN
31747 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
31748 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
31749 & CALL PYDECY(IP)
31750
31751C...Decay products may develop a shower.
31752 IF(MSTJ(92).GT.0) THEN
31753 IP1=MSTJ(92)
31754 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
31755 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
31756 CALL PYSHOW(IP1,IP1+1,QMAX)
31757 CALL PYPREP(IP1)
31758 MSTJ(92)=0
31759 ELSEIF(MSTJ(92).LT.0) THEN
31760 IP1=-MSTJ(92)
31761 CALL PYSHOW(IP1,-3,P(IP,5))
31762 CALL PYPREP(IP1)
31763 MSTJ(92)=0
31764 ENDIF
31765
31766C...Jet fragmentation: string or independent fragmentation.
31767 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
31768 MFRAG=MSTJ(1)
31769 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
31770 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
31771 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
31772 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
31773 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
31774 ENDIF
31775 ENDIF
31776 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
31777 IF(MFRAG.EQ.2) CALL PYINDF(IP)
31778 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
31779 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
31780 ENDIF
31781
31782C...Loop back if enough space left in PYJETS and no error abort.
31783 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
31784 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
31785 GOTO 150
31786 ELSEIF(IP.LT.N) THEN
31787 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
31788 ENDIF
31789
31790C...Include simple Bose-Einstein effect parametrization if desired.
31791 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
31792 CALL PYBOEI(NSAV)
31793 GOTO 140
31794 ENDIF
31795
31796C...Check that momentum, energy and charge were conserved.
31797 DO 200 I=1,N
31798 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
31799 DO 190 J=1,4
31800 PS(2,J)=PS(2,J)+P(I,J)
31801 190 CONTINUE
31802 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
31803 200 CONTINUE
31804 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
31805 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
31806 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
31807 &'(PYEXEC:) four-momentum was not conserved')
31808 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
31809 &'(PYEXEC:) charge was not conserved')
31810
31811 RETURN
31812 END
31813
31814C*********************************************************************
31815
31816C...PYPREP
31817C...Rearranges partons along strings. Allows small systems
31818C...to collapse into one or two particles and checks flavours.
31819
31820 SUBROUTINE PYPREP(IP)
31821
31822C...Double precision and integer declarations.
31823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31824 INTEGER PYK,PYCHGE,PYCOMP
31825C...Commonblocks.
31826 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31828 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31829 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31830 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
31831C...Local arrays.
31832 DIMENSION DPS(5),DPC(5),UE(3)
31833
31834C...Rearrange parton shower product listing along strings: begin loop.
31835 I1=N
31836 DO 130 MQGST=1,2
31837 DO 120 I=MAX(1,IP),N
31838 IF(K(I,1).NE.3) GOTO 120
31839 KC=PYCOMP(K(I,2))
31840 IF(KC.EQ.0) GOTO 120
31841 KQ=KCHG(KC,2)
31842 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
31843
31844C...Pick up loose string end.
31845 KCS=4
31846 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
31847 IA=I
31848 NSTP=0
31849 100 NSTP=NSTP+1
31850 IF(NSTP.GT.4*N) THEN
31851 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
31852 RETURN
31853 ENDIF
31854
31855C...Copy undecayed parton.
31856 IF(K(IA,1).EQ.3) THEN
31857 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
31858 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
31859 RETURN
31860 ENDIF
31861 I1=I1+1
31862 K(I1,1)=2
31863 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
31864 K(I1,2)=K(IA,2)
31865 K(I1,3)=IA
31866 K(I1,4)=0
31867 K(I1,5)=0
31868 DO 110 J=1,5
31869 P(I1,J)=P(IA,J)
31870 V(I1,J)=V(IA,J)
31871 110 CONTINUE
31872 K(IA,1)=K(IA,1)+10
31873 IF(K(I1,1).EQ.1) GOTO 120
31874 ENDIF
31875
31876C...Go to next parton in colour space.
31877 IB=IA
31878 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
31879 & .NE.0) THEN
31880 IA=MOD(K(IB,KCS),MSTU(5))
31881 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
31882 MREV=0
31883 ELSE
31884 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
31885 & MSTU(5)).EQ.0) KCS=9-KCS
31886 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
31887 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
31888 MREV=1
31889 ENDIF
31890 IF(IA.LE.0.OR.IA.GT.N) THEN
31891 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
31892 RETURN
31893 ENDIF
31894 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
31895 & MSTU(5)).EQ.IB) THEN
31896 IF(MREV.EQ.1) KCS=9-KCS
31897 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
31898 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
31899 ELSE
31900 IF(MREV.EQ.0) KCS=9-KCS
31901 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
31902 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
31903 ENDIF
31904 IF(IA.NE.I) GOTO 100
31905 K(I1,1)=1
31906 120 CONTINUE
31907 130 CONTINUE
31908 N=I1
31909 IF(MSTJ(14).LT.0) RETURN
31910
31911C...Find lowest-mass colour singlet jet system, OK if above threshold.
31912 IF(MSTJ(14).EQ.0) GOTO 320
31913 NS=N
31914 140 NSIN=N-NS
31915 PDM=1D0+PARJ(32)
31916 IC=0
31917 DO 190 I=MAX(1,IP),NS
31918 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
31919 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
31920 NSIN=NSIN+1
31921 IC=I
31922 DO 150 J=1,4
31923 DPS(J)=P(I,J)
31924 150 CONTINUE
31925 MSTJ(93)=1
31926 DPS(5)=PYMASS(K(I,2))
31927 ELSEIF(K(I,1).EQ.2) THEN
31928 DO 160 J=1,4
31929 DPS(J)=DPS(J)+P(I,J)
31930 160 CONTINUE
31931 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
31932 DO 170 J=1,4
31933 DPS(J)=DPS(J)+P(I,J)
31934 170 CONTINUE
31935 MSTJ(93)=1
31936 DPS(5)=DPS(5)+PYMASS(K(I,2))
31937 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
31938 & DPS(5)
31939 IF(PD.LT.PDM) THEN
31940 PDM=PD
31941 DO 180 J=1,5
31942 DPC(J)=DPS(J)
31943 180 CONTINUE
31944 IC1=IC
31945 IC2=I
31946 ENDIF
31947 IC=0
31948 ELSE
31949 NSIN=NSIN+1
31950 ENDIF
31951 190 CONTINUE
31952 IF(PDM.GE.PARJ(32)) GOTO 320
31953
31954C...Fill small-mass system as cluster.
31955 NSAV=N
31956 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
31957 K(N+1,1)=11
31958 K(N+1,2)=91
31959 K(N+1,3)=IC1
31960 K(N+1,4)=N+2
31961 K(N+1,5)=N+3
31962 P(N+1,1)=DPC(1)
31963 P(N+1,2)=DPC(2)
31964 P(N+1,3)=DPC(3)
31965 P(N+1,4)=DPC(4)
31966 P(N+1,5)=PECM
31967
31968C...Form two particles from flavours of lowest-mass system, if feasible.
31969 K(N+2,1)=1
31970 K(N+3,1)=1
31971 IF(MSTU(16).NE.2) THEN
31972 K(N+2,3)=N+1
31973 K(N+3,3)=N+1
31974 ELSE
31975 K(N+2,3)=IC1
31976 K(N+3,3)=IC2
31977 ENDIF
31978 K(N+2,4)=0
31979 K(N+3,4)=0
31980 K(N+2,5)=0
31981 K(N+3,5)=0
31982 IF(IABS(K(IC1,2)).NE.21) THEN
31983 KC1=PYCOMP(K(IC1,2))
31984 KC2=PYCOMP(K(IC2,2))
31985 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
31986 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
31987 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
31988 IF(KQ1+KQ2.NE.0) GOTO 320
31989C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson
31990 200 K1=K(IC1,2)
31991 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
31992 MSTU(125)=0
31993 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
31994 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
31995 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
31996 ELSE
31997 IF(IABS(K(IC2,2)).NE.21) GOTO 320
31998C.. No room for popcorn mesons in closed string -> 2 hadrons.
31999 MSTU(125)=0
32000 210 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
32001 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
32002 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
32003 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
32004 ENDIF
32005 P(N+2,5)=PYMASS(K(N+2,2))
32006 P(N+3,5)=PYMASS(K(N+3,2))
32007 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
32008 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
32009
32010C...Perform two-particle decay of jet system, if possible.
32011 IF(PECM.GE.0.02D0*DPC(4)) THEN
32012 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
32013 & (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
32014 UE(3)=2D0*PYR(0)-1D0
32015 PHI=PARU(2)*PYR(0)
32016 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
32017 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
32018 DO 220 J=1,3
32019 P(N+2,J)=PA*UE(J)
32020 P(N+3,J)=-PA*UE(J)
32021 220 CONTINUE
32022 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
32023 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
32024 MSTU(33)=1
32025 CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4),
32026 & DPC(3)/DPC(4))
32027 ELSE
32028 NP=0
32029 DO 230 I=IC1,IC2
32030 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
32031 230 CONTINUE
32032 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
32033 & P(IC1,3)*P(IC2,3)
32034 IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260
32035 HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2)
32036 HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2)
32037 HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
32038 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0
32039 HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2
32040 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
32041 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
32042 DO 240 J=1,4
32043 P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J)
32044 P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J)
32045 240 CONTINUE
32046 ENDIF
32047 DO 250 J=1,4
32048 V(N+1,J)=V(IC1,J)
32049 V(N+2,J)=V(IC1,J)
32050 V(N+3,J)=V(IC2,J)
32051 250 CONTINUE
32052 V(N+1,5)=0D0
32053 V(N+2,5)=0D0
32054 V(N+3,5)=0D0
32055 N=N+3
32056 GOTO 300
32057
32058C...Else form one particle from the flavours available, if possible.
32059 260 K(N+1,5)=N+2
32060 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
32061 GOTO 320
32062 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
32063 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
32064 ELSE
32065 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
32066 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
32067 ENDIF
32068 IF(K(N+2,2).EQ.0) GOTO 260
32069 P(N+2,5)=PYMASS(K(N+2,2))
32070
32071C...Find parton/particle which combines to largest extra mass.
32072 IR=0
32073 HA=0D0
32074 HSM=0D0
32075 DO 280 MCOMB=1,3
32076 IF(IR.NE.0) GOTO 280
32077 DO 270 I=MAX(1,IP),N
32078 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
32079 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
32080 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
32081 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
32082 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
32083 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
32084 & GOTO 270
32085 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
32086 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
32087 IF(HSR.GT.HSM) THEN
32088 IR=I
32089 HA=HCR
32090 HSM=HSR
32091 ENDIF
32092 270 CONTINUE
32093 280 CONTINUE
32094
32095C...Shuffle energy and momentum to put new particle on mass shell.
32096 IF(IR.NE.0) THEN
32097 HB=PECM**2+HA
32098 HC=P(N+2,5)**2+HA
32099 HD=P(IR,5)**2+HA
32100 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
32101 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
32102 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
32103 DO 290 J=1,4
32104 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
32105 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
32106 V(N+1,J)=V(IC1,J)
32107 V(N+2,J)=V(IC1,J)
32108 290 CONTINUE
32109 V(N+1,5)=0D0
32110 V(N+2,5)=0D0
32111 N=N+2
32112 ELSE
32113 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
32114 RETURN
32115 ENDIF
32116
32117C...Mark collapsed system and store daughter pointers. Iterate.
32118 300 DO 310 I=IC1,IC2
32119 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0)
32120 & THEN
32121 K(I,1)=K(I,1)+10
32122 IF(MSTU(16).NE.2) THEN
32123 K(I,4)=NSAV+1
32124 K(I,5)=NSAV+1
32125 ELSE
32126 K(I,4)=NSAV+2
32127 K(I,5)=N
32128 ENDIF
32129 ENDIF
32130 310 CONTINUE
32131 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
32132
32133C...Check flavours and invariant masses in parton systems.
32134 320 NP=0
32135 KFN=0
32136 KQS=0
32137 DO 330 J=1,5
32138 DPS(J)=0D0
32139 330 CONTINUE
32140 DO 360 I=MAX(1,IP),N
32141 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
32142 KC=PYCOMP(K(I,2))
32143 IF(KC.EQ.0) GOTO 360
32144 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32145 IF(KQ.EQ.0) GOTO 360
32146 NP=NP+1
32147 IF(KQ.NE.2) THEN
32148 KFN=KFN+1
32149 KQS=KQS+KQ
32150 MSTJ(93)=1
32151 DPS(5)=DPS(5)+PYMASS(K(I,2))
32152 ENDIF
32153 DO 340 J=1,4
32154 DPS(J)=DPS(J)+P(I,J)
32155 340 CONTINUE
32156 IF(K(I,1).EQ.1) THEN
32157 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
32158 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
32159 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32160 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
32161 & '(PYPREP:) too small mass in jet system')
32162**sr
32163C IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32164C & (0.9D0*PARJ(32)+DPS(5))**2)
32165C & WRITE(*,*) 'I,DPS',I,DPS
32166**
32167 NP=0
32168 KFN=0
32169 KQS=0
32170 DO 350 J=1,5
32171 DPS(J)=0D0
32172 350 CONTINUE
32173 ENDIF
32174 360 CONTINUE
32175
32176 RETURN
32177 END
32178
32179C*********************************************************************
32180
32181C...PYSTRF
32182C...Handles the fragmentation of an arbitrary colour singlet
32183C...jet system according to the Lund string fragmentation model.
32184
32185 SUBROUTINE PYSTRF(IP)
32186
32187C...Double precision and integer declarations.
32188 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32189 INTEGER PYK,PYCHGE,PYCOMP
32190C...Commonblocks.
32191 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32192 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32193 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32194 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
32195C...Local arrays. All MOPS variables ends with MO
32196 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
32197 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
32198 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
32199 &INMO(9),PM2QMO(2),XTMO(2)
32200
32201C...Function: four-product of two vectors.
32202 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
32203 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
32204 &DP(I,3)*DP(J,3)
32205
32206C...Reset counters. Identify parton system.
32207 MSTJ(91)=0
32208 NSAV=N
32209 MSTU90=MSTU(90)
32210 NP=0
32211 KQSUM=0
32212 DO 100 J=1,5
32213 DPS(J)=0D0
32214 100 CONTINUE
32215 MJU(1)=0
32216 MJU(2)=0
32217 I=IP-1
32218 110 I=I+1
32219 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
32220 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
32221 IF(MSTU(21).GE.1) RETURN
32222 ENDIF
32223 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
32224 KC=PYCOMP(K(I,2))
32225 IF(KC.EQ.0) GOTO 110
32226 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32227 IF(KQ.EQ.0) GOTO 110
32228 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
32229 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32230 IF(MSTU(21).GE.1) RETURN
32231 ENDIF
32232
32233C...Take copy of partons to be considered. Check flavour sum.
32234 NP=NP+1
32235 DO 120 J=1,5
32236 K(N+NP,J)=K(I,J)
32237 P(N+NP,J)=P(I,J)
32238 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
32239 120 CONTINUE
32240 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
32241 K(N+NP,3)=I
32242 IF(KQ.NE.2) KQSUM=KQSUM+KQ
32243 IF(K(I,1).EQ.41) THEN
32244 KQSUM=KQSUM+2*KQ
32245 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
32246 IF(KQSUM.NE.KQ) MJU(2)=N+NP
32247 ENDIF
32248 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
32249 IF(KQSUM.NE.0) THEN
32250 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32251 IF(MSTU(21).GE.1) RETURN
32252 ENDIF
32253
32254C...Boost copied system to CM frame (for better numerical precision).
32255 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
32256 MBST=0
32257 MSTU(33)=1
32258 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
32259 & -DPS(3)/DPS(4))
32260 ELSE
32261 MBST=1
32262 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
32263 DO 130 I=N+1,N+NP
32264 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
32265 IF(P(I,3).GT.0D0) THEN
32266 HHPEZ=(P(I,4)+P(I,3))/HHBZ
32267 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
32268 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32269 ELSE
32270 HHPEZ=(P(I,4)-P(I,3))*HHBZ
32271 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
32272 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32273 ENDIF
32274 130 CONTINUE
32275 ENDIF
32276
32277C...Search for very nearby partons that may be recombined.
32278 NTRYR=0
32279 PARU12=PARU(12)
32280 PARU13=PARU(13)
32281 MJU(3)=MJU(1)
32282 MJU(4)=MJU(2)
32283 NR=NP
32284 140 IF(NR.GE.3) THEN
32285 PDRMIN=2D0*PARU12
32286 DO 150 I=N+1,N+NR
32287 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
32288 I1=I+1
32289 IF(I.EQ.N+NR) I1=N+1
32290 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
32291 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
32292 & GOTO 150
32293 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
32294 & GOTO 150
32295 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
32296 & P(I1,2)**2+P(I1,3)**2))
32297 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
32298 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
32299 IF(PDR.LT.PDRMIN) THEN
32300 IR=I
32301 PDRMIN=PDR
32302 ENDIF
32303 150 CONTINUE
32304
32305C...Recombine very nearby partons to avoid machine precision problems.
32306 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
32307 DO 160 J=1,4
32308 P(N+1,J)=P(N+1,J)+P(N+NR,J)
32309 160 CONTINUE
32310 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
32311 & P(N+1,3)**2))
32312 NR=NR-1
32313 GOTO 140
32314 ELSEIF(PDRMIN.LT.PARU12) THEN
32315 DO 170 J=1,4
32316 P(IR,J)=P(IR,J)+P(IR+1,J)
32317 170 CONTINUE
32318 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
32319 & P(IR,3)**2))
32320 DO 190 I=IR+1,N+NR-1
32321 K(I,2)=K(I+1,2)
32322 DO 180 J=1,5
32323 P(I,J)=P(I+1,J)
32324 180 CONTINUE
32325 190 CONTINUE
32326 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
32327 NR=NR-1
32328 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
32329 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
32330 GOTO 140
32331 ENDIF
32332 ENDIF
32333 NTRYR=NTRYR+1
32334
32335C...Reset particle counter. Skip ahead if no junctions are present;
32336C...this is usually the case!
32337 NRS=MAX(5*NR+11,NP)
32338 NTRY=0
32339 200 NTRY=NTRY+1
32340 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32341 PARU12=4D0*PARU12
32342 PARU13=2D0*PARU13
32343 GOTO 140
32344 ELSEIF(NTRY.GT.100) THEN
32345 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32346 IF(MSTU(21).GE.1) RETURN
32347 ENDIF
32348 I=N+NRS
32349 MSTU(90)=MSTU90
32350 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
32351 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
32352 & ' junction strings not handled by MSTJ(12)>3 options')
32353 DO 570 JT=1,2
32354 NJS(JT)=0
32355 IF(MJU(JT).EQ.0) GOTO 570
32356 JS=3-2*JT
32357
32358C...Find and sum up momentum on three sides of junction. Check flavours.
32359 DO 220 IU=1,3
32360 IJU(IU)=0
32361 DO 210 J=1,5
32362 PJU(IU,J)=0D0
32363 210 CONTINUE
32364 220 CONTINUE
32365 IU=0
32366 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
32367 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
32368 IU=IU+1
32369 IJU(IU)=I1
32370 ENDIF
32371 DO 230 J=1,4
32372 PJU(IU,J)=PJU(IU,J)+P(I1,J)
32373 230 CONTINUE
32374 240 CONTINUE
32375 DO 250 IU=1,3
32376 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
32377 250 CONTINUE
32378 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
32379 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
32380 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32381 IF(MSTU(21).GE.1) RETURN
32382 ENDIF
32383
32384C...Calculate (approximate) boost to rest frame of junction.
32385 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
32386 & (PJU(1,5)*PJU(2,5))
32387 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
32388 & (PJU(1,5)*PJU(3,5))
32389 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
32390 & (PJU(2,5)*PJU(3,5))
32391 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
32392 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
32393 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
32394 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
32395 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
32396 DO 260 J=1,3
32397 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
32398 260 CONTINUE
32399 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
32400 DO 270 IU=1,3
32401 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
32402 & TJU(3)*PJU(IU,3)
32403 270 CONTINUE
32404
32405C...Put junction at rest if motion could give inconsistencies.
32406 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
32407 DO 280 J=1,3
32408 TJU(J)=0D0
32409 280 CONTINUE
32410 TJU(4)=1D0
32411 PJU(1,5)=PJU(1,4)
32412 PJU(2,5)=PJU(2,4)
32413 PJU(3,5)=PJU(3,4)
32414 ENDIF
32415
32416C...Start preparing for fragmentation of two strings from junction.
32417 ISTA=I
32418 DO 550 IU=1,2
32419 NS=IJU(IU+1)-IJU(IU)
32420
32421C...Junction strings: find longitudinal string directions.
32422 DO 310 IS=1,NS
32423 IS1=IJU(IU)+IS-1
32424 IS2=IJU(IU)+IS
32425 DO 290 J=1,5
32426 DP(1,J)=0.5D0*P(IS1,J)
32427 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
32428 DP(2,J)=0.5D0*P(IS2,J)
32429 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
32430 290 CONTINUE
32431 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
32432 & PJU(IU,3)**2)
32433 IF(IS.EQ.NS) DP(2,5)=0D0
32434 DP(3,5)=DFOUR(1,1)
32435 DP(4,5)=DFOUR(2,2)
32436 DHKC=DFOUR(1,2)
32437 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32438 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32439 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32440 DP(3,5)=0D0
32441 DP(4,5)=0D0
32442 DHKC=DFOUR(1,2)
32443 ENDIF
32444 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32445 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32446 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32447 IN1=N+NR+4*IS-3
32448 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32449 DO 300 J=1,4
32450 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32451 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32452 300 CONTINUE
32453 310 CONTINUE
32454
32455C...Junction strings: initialize flavour, momentum and starting pos.
32456 ISAV=I
32457 MSTU91=MSTU(90)
32458 320 NTRY=NTRY+1
32459 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32460 PARU12=4D0*PARU12
32461 PARU13=2D0*PARU13
32462 GOTO 140
32463 ELSEIF(NTRY.GT.100) THEN
32464 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32465 IF(MSTU(21).GE.1) RETURN
32466 ENDIF
32467 I=ISAV
32468 MSTU(90)=MSTU91
32469 IRANKJ=0
32470 IE(1)=K(N+1+(JT/2)*(NP-1),3)
32471 IN(4)=N+NR+1
32472 IN(5)=IN(4)+1
32473 IN(6)=N+NR+4*NS+1
32474 DO 340 JQ=1,2
32475 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
32476 P(IN1,1)=2-JQ
32477 P(IN1,2)=JQ-1
32478 P(IN1,3)=1D0
32479 330 CONTINUE
32480 340 CONTINUE
32481 KFL(1)=K(IJU(IU),2)
32482 PX(1)=0D0
32483 PY(1)=0D0
32484 GAM(1)=0D0
32485 DO 350 J=1,5
32486 PJU(IU+3,J)=0D0
32487 350 CONTINUE
32488
32489C...Junction strings: find initial transverse directions.
32490 DO 360 J=1,4
32491 DP(1,J)=P(IN(4),J)
32492 DP(2,J)=P(IN(4)+1,J)
32493 DP(3,J)=0D0
32494 DP(4,J)=0D0
32495 360 CONTINUE
32496 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32497 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32498 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32499 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32500 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32501 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32502 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32503 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32504 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32505 DHC12=DFOUR(1,2)
32506 DHCX1=DFOUR(3,1)/DHC12
32507 DHCX2=DFOUR(3,2)/DHC12
32508 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32509 DHCY1=DFOUR(4,1)/DHC12
32510 DHCY2=DFOUR(4,2)/DHC12
32511 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32512 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32513 DO 370 J=1,4
32514 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32515 P(IN(6),J)=DP(3,J)
32516 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32517 & DHCYX*DP(3,J))
32518 370 CONTINUE
32519
32520C...Junction strings: produce new particle, origin.
32521 380 I=I+1
32522 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32523 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32524 IF(MSTU(21).GE.1) RETURN
32525 ENDIF
32526 IRANKJ=IRANKJ+1
32527 K(I,1)=1
32528 K(I,3)=IE(1)
32529 K(I,4)=0
32530 K(I,5)=0
32531
32532C...Junction strings: generate flavour, hadron, pT, z and Gamma.
32533 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
32534 IF(K(I,2).EQ.0) GOTO 320
32535 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
32536 & IABS(KFL(3)).GT.10) THEN
32537 IF(PYR(0).GT.PARJ(19)) GOTO 390
32538 ENDIF
32539 P(I,5)=PYMASS(K(I,2))
32540 CALL PYPTDI(KFL(1),PX(3),PY(3))
32541 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
32542 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
32543 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
32544 & MSTU(90).LT.8) THEN
32545 MSTU(90)=MSTU(90)+1
32546 MSTU(90+MSTU(90))=I
32547 PARU(90+MSTU(90))=Z
32548 ENDIF
32549 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
32550 DO 400 J=1,3
32551 IN(J)=IN(3+J)
32552 400 CONTINUE
32553
32554C...Junction strings: stepping within or from 'low' string region easy.
32555 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
32556 & P(IN(1),5)**2.GE.PR(1)) THEN
32557 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
32558 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
32559 DO 410 J=1,4
32560 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
32561 410 CONTINUE
32562 GOTO 500
32563 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
32564 P(IN(2)+2,4)=P(IN(2)+2,3)
32565 P(IN(2)+2,1)=1D0
32566 IN(2)=IN(2)+4
32567 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32568 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32569 P(IN(1)+2,4)=P(IN(1)+2,3)
32570 P(IN(1)+2,1)=0D0
32571 IN(1)=IN(1)+4
32572 ENDIF
32573 ENDIF
32574
32575C...Junction strings: find new transverse directions.
32576 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
32577 & IN(1).GT.IN(2)) GOTO 320
32578 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
32579 DO 430 J=1,4
32580 DP(1,J)=P(IN(1),J)
32581 DP(2,J)=P(IN(2),J)
32582 DP(3,J)=0D0
32583 DP(4,J)=0D0
32584 430 CONTINUE
32585 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32586 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32587 DHC12=DFOUR(1,2)
32588 IF(DHC12.LE.1D-2) THEN
32589 P(IN(1)+2,4)=P(IN(1)+2,3)
32590 P(IN(1)+2,1)=0D0
32591 IN(1)=IN(1)+4
32592 GOTO 420
32593 ENDIF
32594 IN(3)=N+NR+4*NS+5
32595 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32596 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32597 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32598 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32599 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32600 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32601 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32602 DHCX1=DFOUR(3,1)/DHC12
32603 DHCX2=DFOUR(3,2)/DHC12
32604 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32605 DHCY1=DFOUR(4,1)/DHC12
32606 DHCY2=DFOUR(4,2)/DHC12
32607 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32608 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32609 DO 440 J=1,4
32610 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32611 P(IN(3),J)=DP(3,J)
32612 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32613 & DHCYX*DP(3,J))
32614 440 CONTINUE
32615C...Express pT with respect to new axes, if sensible.
32616 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
32617 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
32618 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
32619 PX(3)=PXP
32620 PY(3)=PYP
32621 ENDIF
32622 ENDIF
32623
32624C...Junction strings: sum up known four-momentum, coefficients for m2.
32625 DO 470 J=1,4
32626 DHG(J)=0D0
32627 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
32628 & PY(3)*P(IN(3)+1,J)
32629 DO 450 IN1=IN(4),IN(1)-4,4
32630 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
32631 450 CONTINUE
32632 DO 460 IN2=IN(5),IN(2)-4,4
32633 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
32634 460 CONTINUE
32635 470 CONTINUE
32636 DHM(1)=FOUR(I,I)
32637 DHM(2)=2D0*FOUR(I,IN(1))
32638 DHM(3)=2D0*FOUR(I,IN(2))
32639 DHM(4)=2D0*FOUR(IN(1),IN(2))
32640
32641C...Junction strings: find coefficients for Gamma expression.
32642 DO 490 IN2=IN(1)+1,IN(2),4
32643 DO 480 IN1=IN(1),IN2-1,4
32644 DHC=2D0*FOUR(IN1,IN2)
32645 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
32646 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
32647 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
32648 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
32649 480 CONTINUE
32650 490 CONTINUE
32651
32652C...Junction strings: solve (m2, Gamma) equation system for energies.
32653 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
32654 IF(ABS(DHS1).LT.1D-4) GOTO 320
32655 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
32656 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
32657 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
32658 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
32659 & ABS(DHS1)-DHS2/DHS1)
32660 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
32661 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
32662 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
32663
32664C...Junction strings: step to new region if necessary.
32665 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
32666 P(IN(2)+2,4)=P(IN(2)+2,3)
32667 P(IN(2)+2,1)=1D0
32668 IN(2)=IN(2)+4
32669 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32670 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32671 P(IN(1)+2,4)=P(IN(1)+2,3)
32672 P(IN(1)+2,1)=0D0
32673 IN(1)=IN(1)+4
32674 ENDIF
32675 GOTO 420
32676 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
32677 P(IN(1)+2,4)=P(IN(1)+2,3)
32678 P(IN(1)+2,1)=0D0
32679 IN(1)=IN(1)+JS
32680 GOTO 890
32681 ENDIF
32682
32683C...Junction strings: particle four-momentum, remainder, loop back.
32684 500 DO 510 J=1,4
32685 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
32686 & P(IN(2)+2,4)*P(IN(2),J)
32687 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
32688 510 CONTINUE
32689 IF(P(I,4).LT.P(I,5)) GOTO 320
32690 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
32691 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
32692 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
32693 KFL(1)=-KFL(3)
32694 PX(1)=-PX(3)
32695 PY(1)=-PY(3)
32696 GAM(1)=GAM(3)
32697 IF(IN(3).NE.IN(6)) THEN
32698 DO 520 J=1,4
32699 P(IN(6),J)=P(IN(3),J)
32700 P(IN(6)+1,J)=P(IN(3)+1,J)
32701 520 CONTINUE
32702 ENDIF
32703 DO 530 JQ=1,2
32704 IN(3+JQ)=IN(JQ)
32705 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
32706 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
32707 530 CONTINUE
32708 GOTO 380
32709 ENDIF
32710
32711C...Junction strings: save quantities left after each string.
32712 IF(IABS(KFL(1)).GT.10) GOTO 320
32713 I=I-1
32714 KFJH(IU)=KFL(1)
32715 DO 540 J=1,4
32716 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
32717 540 CONTINUE
32718 550 CONTINUE
32719
32720C...Junction strings: put together to new effective string endpoint.
32721 NJS(JT)=I-ISTA
32722 KFJS(JT)=K(K(MJU(JT+2),3),2)
32723 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
32724 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
32725 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
32726 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
32727 & KFLS,KFJH(1))
32728 DO 560 J=1,4
32729 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
32730 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
32731 560 CONTINUE
32732 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
32733 & PJS(JT,3)**2))
32734 570 CONTINUE
32735
32736C...Open versus closed strings. Choose breakup region for latter.
32737 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
32738 NS=MJU(2)-MJU(1)
32739 NB=MJU(1)-N
32740 ELSEIF(MJU(1).NE.0) THEN
32741 NS=N+NR-MJU(1)
32742 NB=MJU(1)-N
32743 ELSEIF(MJU(2).NE.0) THEN
32744 NS=MJU(2)-N
32745 NB=1
32746 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
32747 NS=NR-1
32748 NB=1
32749 ELSE
32750 NS=NR+1
32751 W2SUM=0D0
32752 DO 590 IS=1,NR
32753 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
32754 W2SUM=W2SUM+P(N+NR+IS,1)
32755 590 CONTINUE
32756 W2RAN=PYR(0)*W2SUM
32757 NB=0
32758 600 NB=NB+1
32759 W2SUM=W2SUM-P(N+NR+NB,1)
32760 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
32761 ENDIF
32762
32763C...Find longitudinal string directions (i.e. lightlike four-vectors).
32764 DO 630 IS=1,NS
32765 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
32766 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
32767 DO 610 J=1,5
32768 DP(1,J)=P(IS1,J)
32769 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
32770 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
32771 DP(2,J)=P(IS2,J)
32772 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
32773 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
32774 610 CONTINUE
32775 DP(3,5)=DFOUR(1,1)
32776 DP(4,5)=DFOUR(2,2)
32777 DHKC=DFOUR(1,2)
32778 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32779 DP(3,5)=DP(1,5)**2
32780 DP(4,5)=DP(2,5)**2
32781 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
32782 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
32783 DHKC=DFOUR(1,2)
32784 ENDIF
32785 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32786 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32787 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32788 IN1=N+NR+4*IS-3
32789 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32790 DO 620 J=1,4
32791 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32792 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32793 620 CONTINUE
32794 630 CONTINUE
32795
32796C...Begin initialization: sum up energy, set starting position.
32797 ISAV=I
32798 MSTU91=MSTU(90)
32799 640 NTRY=NTRY+1
32800 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32801 PARU12=4D0*PARU12
32802 PARU13=2D0*PARU13
32803 GOTO 140
32804 ELSEIF(NTRY.GT.100) THEN
32805 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32806 IF(MSTU(21).GE.1) RETURN
32807 ENDIF
32808 I=ISAV
32809 MSTU(90)=MSTU91
32810 DO 660 J=1,4
32811 P(N+NRS,J)=0D0
32812 DO 650 IS=1,NR
32813 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
32814 650 CONTINUE
32815 660 CONTINUE
32816 DO 680 JT=1,2
32817 IRANK(JT)=0
32818 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
32819 IF(NS.GT.NR) IRANK(JT)=1
32820 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
32821 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
32822 IN(3*JT+2)=IN(3*JT+1)+1
32823 IN(3*JT+3)=N+NR+4*NS+2*JT-1
32824 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
32825 P(IN1,1)=2-JT
32826 P(IN1,2)=JT-1
32827 P(IN1,3)=1D0
32828 670 CONTINUE
32829 680 CONTINUE
32830C.. MOPS variables and switches
32831 NRVMO=0
32832 XBMO=1D0
32833 MSTU(121)=0
32834 MSTU(122)=0
32835
32836C...Initialize flavour and pT variables for open string.
32837 IF(NS.LT.NR) THEN
32838 PX(1)=0D0
32839 PY(1)=0D0
32840 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
32841 PX(2)=-PX(1)
32842 PY(2)=-PY(1)
32843 DO 690 JT=1,2
32844 KFL(JT)=K(IE(JT),2)
32845 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
32846 MSTJ(93)=1
32847 PMQ(JT)=PYMASS(KFL(JT))
32848 GAM(JT)=0D0
32849 690 CONTINUE
32850
32851C...Closed string: random initial breakup flavour, pT and vertex.
32852 ELSE
32853 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
32854 IBMO=0
32855 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
32856C.. Closed string: first vertex diq attempt => enforced second
32857C.. vertex diq
32858 IF(IABS(KFL(1)).GT.10)THEN
32859 IBMO=1
32860 MSTU(121)=0
32861 GOTO 700
32862 ENDIF
32863 IF(IBMO.EQ.1) MSTU(121)=-1
32864 KFL(2)=-KFL(1)
32865 CALL PYPTDI(KFL(1),PX(1),PY(1))
32866 PX(2)=-PX(1)
32867 PY(2)=-PY(1)
32868 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
32869 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
32870 ZR=PR3/(Z*P(N+NR+1,5)**2)
32871 IF(ZR.GE.1D0) GOTO 710
32872 DO 720 JT=1,2
32873 MSTJ(93)=1
32874 PMQ(JT)=PYMASS(KFL(JT))
32875 GAM(JT)=PR3*(1D0-Z)/Z
32876 IN1=N+NR+3+4*(JT/2)*(NS-1)
32877 P(IN1,JT)=1D0-Z
32878 P(IN1,3-JT)=JT-1
32879 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
32880 P(IN1+1,JT)=ZR
32881 P(IN1+1,3-JT)=2-JT
32882 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
32883 720 CONTINUE
32884 ENDIF
32885C.. MOPS variables
32886 DO 730 JT=1,2
32887 XTMO(JT)=1D0
32888 PM2QMO(JT)=PMQ(JT)**2
32889 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
32890 730 CONTINUE
32891
32892C...Find initial transverse directions (i.e. spacelike four-vectors).
32893 DO 770 JT=1,2
32894 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
32895 IN1=IN(3*JT+1)
32896 IN3=IN(3*JT+3)
32897 DO 740 J=1,4
32898 DP(1,J)=P(IN1,J)
32899 DP(2,J)=P(IN1+1,J)
32900 DP(3,J)=0D0
32901 DP(4,J)=0D0
32902 740 CONTINUE
32903 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32904 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32905 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32906 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32907 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32908 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32909 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32910 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32911 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32912 DHC12=DFOUR(1,2)
32913 DHCX1=DFOUR(3,1)/DHC12
32914 DHCX2=DFOUR(3,2)/DHC12
32915 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32916 DHCY1=DFOUR(4,1)/DHC12
32917 DHCY2=DFOUR(4,2)/DHC12
32918 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32919 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32920 DO 750 J=1,4
32921 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32922 P(IN3,J)=DP(3,J)
32923 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32924 & DHCYX*DP(3,J))
32925 750 CONTINUE
32926 ELSE
32927 DO 760 J=1,4
32928 P(IN3+2,J)=P(IN3,J)
32929 P(IN3+3,J)=P(IN3+1,J)
32930 760 CONTINUE
32931 ENDIF
32932 770 CONTINUE
32933
32934C...Remove energy used up in junction string fragmentation.
32935 IF(MJU(1)+MJU(2).GT.0) THEN
32936 DO 790 JT=1,2
32937 IF(NJS(JT).EQ.0) GOTO 790
32938 DO 780 J=1,4
32939 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
32940 780 CONTINUE
32941 790 CONTINUE
32942 ENDIF
32943
32944C...Produce new particle: side, origin.
32945 800 I=I+1
32946 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32947 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32948 IF(MSTU(21).GE.1) RETURN
32949 ENDIF
32950C.. New side priority for popcorn systems
32951 IF(MSTU(121).LE.0)THEN
32952 JT=1.5D0+PYR(0)
32953 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
32954 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
32955 ENDIF
32956 JR=3-JT
32957 JS=3-2*JT
32958 IRANK(JT)=IRANK(JT)+1
32959 K(I,1)=1
32960 K(I,3)=IE(JT)
32961 K(I,4)=0
32962 K(I,5)=0
32963
32964C...Generate flavour, hadron and pT.
32965 810 CONTINUE
32966 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
32967 IF(K(I,2).EQ.0) GOTO 640
32968 MU90MO=MSTU(90)
32969 IF(MSTU(121).EQ.-1) GOTO 840
32970 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
32971 &IABS(KFL(3)).GT.10) THEN
32972 IF(PYR(0).GT.PARJ(19)) GOTO 810
32973 ENDIF
32974 P(I,5)=PYMASS(K(I,2))
32975 CALL PYPTDI(KFL(JT),PX(3),PY(3))
32976 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
32977
32978C...Final hadrons for small invariant mass.
32979 MSTJ(93)=1
32980 PMQ(3)=PYMASS(KFL(3))
32981 PARJST=PARJ(33)
32982 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
32983 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
32984 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
32985 &WMIN-0.5D0*PARJ(36)*PMQ(3)
32986 WREM2=FOUR(N+NRS,N+NRS)
32987 IF(WREM2.LT.0.10D0) GOTO 640
32988 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
32989 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
32990
32991C...Choose z, which gives Gamma. Shift z for heavy flavours.
32992 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
32993 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
32994 &MSTU(90).LT.8) THEN
32995 MSTU(90)=MSTU(90)+1
32996 MSTU(90+MSTU(90))=I
32997 PARU(90+MSTU(90))=Z
32998 ENDIF
32999 KFL1A=IABS(KFL(1))
33000 KFL2A=IABS(KFL(2))
33001 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33002 &MOD(KFL2A/1000,10)).GE.4) THEN
33003 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33004 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
33005 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
33006 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33007 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
33008 ENDIF
33009 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
33010
33011C.. MOPS baryon model modification
33012 XTMO3=(1D0-Z)*XTMO(JT)
33013 IF(IABS(KFL(3)).LE.10) NRVMO=0
33014 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
33015 GTSTMO=1D0
33016 PTSTMO=1D0
33017 RTSTMO=PYR(0)
33018 IF(IABS(KFL(JT)).LE.10)THEN
33019 XBMO=MIN(XTMO3,1D0-(2D-10))
33020 GBMO=GAM(3)
33021 PMMO=0D0
33022 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
33023 GTSTMO=1D0-PARF(192)**PGMO
33024 ELSE
33025 IF(IRANK(JT).EQ.1) THEN
33026 GBMO=GAM(JT)
33027 PMMO=0D0
33028 XBMO=1D0
33029 ENDIF
33030 IF(XBMO.LT.1D0-(1D-10))THEN
33031 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
33032 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
33033 PGMO=PGNMO
33034 ENDIF
33035 IF(MSTJ(12).GE.5)THEN
33036 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
33037 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
33038 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
33039 PMMO=PMNMO
33040 ENDIF
33041 ENDIF
33042
33043C.. MOPS Accepting popcorn system hadron.
33044 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
33045 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
33046 NRVMO=I-N-NR
33047 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
33048 CALL PYERRM(11,
33049 & '(PYSTRF:) no more memory left in PYJETS')
33050 IF(MSTU(21).GE.1) RETURN
33051 ENDIF
33052 IMO=I
33053 KFLMO=KFL(JT)
33054 PMQMO=PMQ(JT)
33055 PXMO=PX(JT)
33056 PYMO=PY(JT)
33057 GAMMO=GAM(JT)
33058 IRMO=IRANK(JT)
33059 XMO=XTMO(JT)
33060 DO 830 J=1,9
33061 IF(J.LE.5) THEN
33062 DO 820 LINE=1,I-N-NR
33063 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
33064 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
33065 820 CONTINUE
33066 ENDIF
33067 INMO(J)=IN(J)
33068 830 CONTINUE
33069 ENDIF
33070 ELSE
33071C..Reject popcorn system, flag=-1 if enforcing new one
33072 MSTU(121)=-1
33073 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
33074 ENDIF
33075 ENDIF
33076
33077
33078C..Lift restoring string outside MOPS block
33079 840 IF(MSTU(121).LT.0) THEN
33080 IF(MSTU(121).EQ.-2) MSTU(121)=0
33081 MSTU(90)=MU90MO
33082 NRVMO=0
33083 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
33084 I=IMO
33085 KFL(JT)=KFLMO
33086 PMQ(JT)=PMQMO
33087 PX(JT)=PXMO
33088 PY(JT)=PYMO
33089 GAM(JT)=GAMMO
33090 IRANK(JT)=IRMO
33091 XTMO(JT)=XMO
33092 DO 860 J=1,9
33093 IF(J.LE.5) THEN
33094 DO 850 LINE=1,I-N-NR
33095 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
33096 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
33097 850 CONTINUE
33098 ENDIF
33099 IN(J)=INMO(J)
33100 860 CONTINUE
33101 GOTO 810
33102 ENDIF
33103 XTMO(JT)=XTMO3
33104C.. MOPS end of modification
33105
33106 DO 870 J=1,3
33107 IN(J)=IN(3*JT+J)
33108 870 CONTINUE
33109
33110C...Stepping within or from 'low' string region easy.
33111 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
33112 &P(IN(1),5)**2.GE.PR(JT)) THEN
33113 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
33114 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
33115 DO 880 J=1,4
33116 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
33117 880 CONTINUE
33118 GOTO 970
33119 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
33120 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33121 P(IN(JR)+2,JT)=1D0
33122 IN(JR)=IN(JR)+4*JS
33123 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33124 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33125 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33126 P(IN(JT)+2,JT)=0D0
33127 IN(JT)=IN(JT)+4*JS
33128 ENDIF
33129 ENDIF
33130
33131C...Find new transverse directions (i.e. spacelike string vectors).
33132 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
33133 &IN(1).GT.IN(2)) GOTO 640
33134 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
33135 DO 900 J=1,4
33136 DP(1,J)=P(IN(1),J)
33137 DP(2,J)=P(IN(2),J)
33138 DP(3,J)=0D0
33139 DP(4,J)=0D0
33140 900 CONTINUE
33141 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33142 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33143 DHC12=DFOUR(1,2)
33144 IF(DHC12.LE.1D-2) THEN
33145 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33146 P(IN(JT)+2,JT)=0D0
33147 IN(JT)=IN(JT)+4*JS
33148 GOTO 890
33149 ENDIF
33150 IN(3)=N+NR+4*NS+5
33151 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33152 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33153 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33154 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33155 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33156 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33157 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33158 DHCX1=DFOUR(3,1)/DHC12
33159 DHCX2=DFOUR(3,2)/DHC12
33160 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33161 DHCY1=DFOUR(4,1)/DHC12
33162 DHCY2=DFOUR(4,2)/DHC12
33163 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33164 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33165 DO 910 J=1,4
33166 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33167 P(IN(3),J)=DP(3,J)
33168 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33169 & DHCYX*DP(3,J))
33170 910 CONTINUE
33171C...Express pT with respect to new axes, if sensible.
33172 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
33173 & FOUR(IN(3*JT+3)+1,IN(3)))
33174 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
33175 & FOUR(IN(3*JT+3)+1,IN(3)+1))
33176 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
33177 PX(3)=PXP
33178 PY(3)=PYP
33179 ENDIF
33180 ENDIF
33181
33182C...Sum up known four-momentum. Gives coefficients for m2 expression.
33183 DO 940 J=1,4
33184 DHG(J)=0D0
33185 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
33186 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
33187 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
33188 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
33189 920 CONTINUE
33190 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
33191 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
33192 930 CONTINUE
33193 940 CONTINUE
33194 DHM(1)=FOUR(I,I)
33195 DHM(2)=2D0*FOUR(I,IN(1))
33196 DHM(3)=2D0*FOUR(I,IN(2))
33197 DHM(4)=2D0*FOUR(IN(1),IN(2))
33198
33199C...Find coefficients for Gamma expression.
33200 DO 960 IN2=IN(1)+1,IN(2),4
33201 DO 950 IN1=IN(1),IN2-1,4
33202 DHC=2D0*FOUR(IN1,IN2)
33203 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
33204 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
33205 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
33206 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
33207 950 CONTINUE
33208 960 CONTINUE
33209
33210C...Solve (m2, Gamma) equation system for energies taken.
33211 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
33212 IF(ABS(DHS1).LT.1D-4) GOTO 640
33213 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
33214 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
33215 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
33216 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
33217 &ABS(DHS1)-DHS2/DHS1)
33218 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
33219 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
33220 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
33221
33222C...Step to new region if necessary.
33223 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
33224 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33225 P(IN(JR)+2,JT)=1D0
33226 IN(JR)=IN(JR)+4*JS
33227 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33228 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33229 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33230 P(IN(JT)+2,JT)=0D0
33231 IN(JT)=IN(JT)+4*JS
33232 ENDIF
33233 GOTO 890
33234 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
33235 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33236 P(IN(JT)+2,JT)=0D0
33237 IN(JT)=IN(JT)+4*JS
33238 GOTO 890
33239 ENDIF
33240
33241C...Four-momentum of particle. Remaining quantities. Loop back.
33242 970 DO 980 J=1,4
33243 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
33244 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
33245 980 CONTINUE
33246 IF(P(I,4).LT.P(I,5)) GOTO 640
33247 KFL(JT)=-KFL(3)
33248 PMQ(JT)=PMQ(3)
33249 PX(JT)=-PX(3)
33250 PY(JT)=-PY(3)
33251 GAM(JT)=GAM(3)
33252 IF(IN(3).NE.IN(3*JT+3)) THEN
33253 DO 990 J=1,4
33254 P(IN(3*JT+3),J)=P(IN(3),J)
33255 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
33256 990 CONTINUE
33257 ENDIF
33258 DO 1000 JQ=1,2
33259 IN(3*JT+JQ)=IN(JQ)
33260 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
33261 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
33262 1000 CONTINUE
33263 GOTO 800
33264
33265C...Final hadron: side, flavour, hadron, mass.
33266 1010 I=I+1
33267 K(I,1)=1
33268 K(I,3)=IE(JR)
33269 K(I,4)=0
33270 K(I,5)=0
33271 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
33272 IF(K(I,2).EQ.0) GOTO 640
33273 P(I,5)=PYMASS(K(I,2))
33274 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33275
33276C...Final two hadrons: find common setup of four-vectors.
33277 JQ=1
33278 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
33279 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
33280 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
33281 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
33282 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
33283 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
33284 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
33285 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
33286 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
33287 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
33288 ENDIF
33289
33290C...Solve kinematics for final two hadrons, if possible.
33291 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
33292 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
33293 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
33294 IF(FD.GE.1D0) GOTO 640
33295 FA=WREM2+PR(JT)-PR(JR)
33296 IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)*
33297 &(PR(1)+PR(2))**2))
33298 IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39)
33299 FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV))
33300 KFL1A=IABS(KFL(1))
33301 KFL2A=IABS(KFL(2))
33302 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33303 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
33304 &4D0*WREM2*PR(JT))),DBLE(JS))
33305 DO 1020 J=1,4
33306 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
33307 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
33308 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
33309 P(I,J)=P(N+NRS,J)-P(I-1,J)
33310 1020 CONTINUE
33311 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
33312
33313C...Mark jets as fragmented and give daughter pointers.
33314 N=I-NRS+1
33315 DO 1030 I=NSAV+1,NSAV+NP
33316 IM=K(I,3)
33317 K(IM,1)=K(IM,1)+10
33318 IF(MSTU(16).NE.2) THEN
33319 K(IM,4)=NSAV+1
33320 K(IM,5)=NSAV+1
33321 ELSE
33322 K(IM,4)=NSAV+2
33323 K(IM,5)=N
33324 ENDIF
33325 1030 CONTINUE
33326
33327C...Document string system. Move up particles.
33328 NSAV=NSAV+1
33329 K(NSAV,1)=11
33330 K(NSAV,2)=92
33331 K(NSAV,3)=IP
33332 K(NSAV,4)=NSAV+1
33333 K(NSAV,5)=N
33334 DO 1040 J=1,4
33335 P(NSAV,J)=DPS(J)
33336 V(NSAV,J)=V(IP,J)
33337 1040 CONTINUE
33338 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33339 V(NSAV,5)=0D0
33340 DO 1060 I=NSAV+1,N
33341 DO 1050 J=1,5
33342 K(I,J)=K(I+NRS-1,J)
33343 P(I,J)=P(I+NRS-1,J)
33344 V(I,J)=0D0
33345 1050 CONTINUE
33346 1060 CONTINUE
33347 MSTU91=MSTU(90)
33348 DO 1070 IZ=MSTU90+1,MSTU91
33349 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
33350 PARU9T(IZ)=PARU(90+IZ)
33351 1070 CONTINUE
33352 MSTU(90)=MSTU90
33353
33354C...Order particles in rank along the chain. Update mother pointer.
33355 DO 1090 I=NSAV+1,N
33356 DO 1080 J=1,5
33357 K(I-NSAV+N,J)=K(I,J)
33358 P(I-NSAV+N,J)=P(I,J)
33359 1080 CONTINUE
33360 1090 CONTINUE
33361 I1=NSAV
33362 DO 1120 I=N+1,2*N-NSAV
33363 IF(K(I,3).NE.IE(1)) GOTO 1120
33364 I1=I1+1
33365 DO 1100 J=1,5
33366 K(I1,J)=K(I,J)
33367 P(I1,J)=P(I,J)
33368 1100 CONTINUE
33369 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33370 DO 1110 IZ=MSTU90+1,MSTU91
33371 IF(MSTU9T(IZ).EQ.I) THEN
33372 MSTU(90)=MSTU(90)+1
33373 MSTU(90+MSTU(90))=I1
33374 PARU(90+MSTU(90))=PARU9T(IZ)
33375 ENDIF
33376 1110 CONTINUE
33377 1120 CONTINUE
33378 DO 1150 I=2*N-NSAV,N+1,-1
33379 IF(K(I,3).EQ.IE(1)) GOTO 1150
33380 I1=I1+1
33381 DO 1130 J=1,5
33382 K(I1,J)=K(I,J)
33383 P(I1,J)=P(I,J)
33384 1130 CONTINUE
33385 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33386 DO 1140 IZ=MSTU90+1,MSTU91
33387 IF(MSTU9T(IZ).EQ.I) THEN
33388 MSTU(90)=MSTU(90)+1
33389 MSTU(90+MSTU(90))=I1
33390 PARU(90+MSTU(90))=PARU9T(IZ)
33391 ENDIF
33392 1140 CONTINUE
33393 1150 CONTINUE
33394
33395C...Boost back particle system. Set production vertices.
33396 IF(MBST.EQ.0) THEN
33397 MSTU(33)=1
33398 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
33399 & DPS(3)/DPS(4))
33400 ELSE
33401 DO 1160 I=NSAV+1,N
33402 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
33403 IF(P(I,3).GT.0D0) THEN
33404 HHPEZ=(P(I,4)+P(I,3))*HHBZ
33405 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
33406 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33407 ELSE
33408 HHPEZ=(P(I,4)-P(I,3))/HHBZ
33409 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
33410 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33411 ENDIF
33412 1160 CONTINUE
33413 ENDIF
33414 DO 1180 I=NSAV+1,N
33415 DO 1170 J=1,4
33416 V(I,J)=V(IP,J)
33417 1170 CONTINUE
33418 1180 CONTINUE
33419
33420 RETURN
33421 END
33422
33423C*********************************************************************
33424
33425C...PYINDF
33426C...Handles the fragmentation of a jet system (or a single
33427C...jet) according to independent fragmentation models.
33428
33429 SUBROUTINE PYINDF(IP)
33430
33431C...Double precision and integer declarations.
33432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33433 INTEGER PYK,PYCHGE,PYCOMP
33434C...Commonblocks.
33435 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33436 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33437 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33438 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
33439C...Local arrays.
33440 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
33441 &KFLO(2),PXO(2),PYO(2),WO(2)
33442
33443C.. MOPS error message
33444 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
33445 &' are not treated as expected in independent fragmentation')
33446
33447C...Reset counters. Identify parton system and take copy. Check flavour.
33448 NSAV=N
33449 MSTU90=MSTU(90)
33450 NJET=0
33451 KQSUM=0
33452 DO 100 J=1,5
33453 DPS(J)=0D0
33454 100 CONTINUE
33455 I=IP-1
33456 110 I=I+1
33457 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
33458 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
33459 IF(MSTU(21).GE.1) RETURN
33460 ENDIF
33461 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
33462 KC=PYCOMP(K(I,2))
33463 IF(KC.EQ.0) GOTO 110
33464 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
33465 IF(KQ.EQ.0) GOTO 110
33466 NJET=NJET+1
33467 IF(KQ.NE.2) KQSUM=KQSUM+KQ
33468 DO 120 J=1,5
33469 K(NSAV+NJET,J)=K(I,J)
33470 P(NSAV+NJET,J)=P(I,J)
33471 DPS(J)=DPS(J)+P(I,J)
33472 120 CONTINUE
33473 K(NSAV+NJET,3)=I
33474 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
33475 &K(I+1,1).EQ.2)) GOTO 110
33476 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
33477 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
33478 IF(MSTU(21).GE.1) RETURN
33479 ENDIF
33480
33481C...Boost copied system to CM frame. Find CM energy and sum flavours.
33482 IF(NJET.NE.1) THEN
33483 MSTU(33)=1
33484 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
33485 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
33486 ENDIF
33487 PECM=0D0
33488 DO 130 J=1,3
33489 NFI(J)=0
33490 130 CONTINUE
33491 DO 140 I=NSAV+1,NSAV+NJET
33492 PECM=PECM+P(I,4)
33493 KFA=IABS(K(I,2))
33494 IF(KFA.LE.3) THEN
33495 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
33496 ELSEIF(KFA.GT.1000) THEN
33497 KFLA=MOD(KFA/1000,10)
33498 KFLB=MOD(KFA/100,10)
33499 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
33500 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
33501 ENDIF
33502 140 CONTINUE
33503
33504C...Loop over attempts made. Reset counters.
33505 NTRY=0
33506 150 NTRY=NTRY+1
33507 IF(NTRY.GT.200) THEN
33508 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
33509 IF(MSTU(21).GE.1) RETURN
33510 ENDIF
33511 N=NSAV+NJET
33512 MSTU(90)=MSTU90
33513 DO 160 J=1,3
33514 NFL(J)=NFI(J)
33515 IFET(J)=0
33516 KFLF(J)=0
33517 160 CONTINUE
33518
33519C...Loop over jets to be fragmented.
33520 DO 230 IP1=NSAV+1,NSAV+NJET
33521 MSTJ(91)=0
33522 NSAV1=N
33523 MSTU91=MSTU(90)
33524
33525C...Initial flavour and momentum values. Jet along +z axis.
33526 KFLH=IABS(K(IP1,2))
33527 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
33528 KFLO(2)=0
33529 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
33530
33531C...Initial values for quark or diquark jet.
33532 170 IF(IABS(K(IP1,2)).NE.21) THEN
33533 NSTR=1
33534 KFLO(1)=K(IP1,2)
33535 CALL PYPTDI(0,PXO(1),PYO(1))
33536 WO(1)=WF
33537
33538C...Initial values for gluon treated like random quark jet.
33539 ELSEIF(MSTJ(2).LE.2) THEN
33540 NSTR=1
33541 IF(MSTJ(2).EQ.2) MSTJ(91)=1
33542 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33543 CALL PYPTDI(0,PXO(1),PYO(1))
33544 WO(1)=WF
33545
33546C...Initial values for gluon treated like quark-antiquark jet pair,
33547C...sharing energy according to Altarelli-Parisi splitting function.
33548 ELSE
33549 NSTR=2
33550 IF(MSTJ(2).EQ.4) MSTJ(91)=1
33551 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33552 KFLO(2)=-KFLO(1)
33553 CALL PYPTDI(0,PXO(1),PYO(1))
33554 PXO(2)=-PXO(1)
33555 PYO(2)=-PYO(1)
33556 WO(1)=WF*PYR(0)**(1D0/3D0)
33557 WO(2)=WF-WO(1)
33558 ENDIF
33559
33560C...Initial values for rank, flavour, pT and W+.
33561 DO 220 ISTR=1,NSTR
33562 180 I=N
33563 MSTU(90)=MSTU91
33564 IRANK=0
33565 KFL1=KFLO(ISTR)
33566 PX1=PXO(ISTR)
33567 PY1=PYO(ISTR)
33568 W=WO(ISTR)
33569
33570C...New hadron. Generate flavour and hadron species.
33571 190 I=I+1
33572 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
33573 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
33574 IF(MSTU(21).GE.1) RETURN
33575 ENDIF
33576 IRANK=IRANK+1
33577 K(I,1)=1
33578 K(I,3)=IP1
33579 K(I,4)=0
33580 K(I,5)=0
33581 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
33582 IF(K(I,2).EQ.0) GOTO 180
33583 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
33584 IF(PYR(0).GT.PARJ(19)) GOTO 200
33585 ENDIF
33586
33587C...Find hadron mass. Generate four-momentum.
33588 P(I,5)=PYMASS(K(I,2))
33589 CALL PYPTDI(KFL1,PX2,PY2)
33590 P(I,1)=PX1+PX2
33591 P(I,2)=PY1+PY2
33592 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
33593 CALL PYZDIS(KFL1,KFL2,PR,Z)
33594 MZSAV=0
33595 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
33596 MZSAV=1
33597 MSTU(90)=MSTU(90)+1
33598 MSTU(90+MSTU(90))=I
33599 PARU(90+MSTU(90))=Z
33600 ENDIF
33601 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
33602 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
33603 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
33604 & P(I,3).LE.0.001D0) THEN
33605 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
33606 P(I,3)=0.0001D0
33607 P(I,4)=SQRT(PR)
33608 Z=P(I,4)/W
33609 ENDIF
33610
33611C...Remaining flavour and momentum.
33612 KFL1=-KFL2
33613 PX1=-PX2
33614 PY1=-PY2
33615 W=(1D0-Z)*W
33616 DO 210 J=1,5
33617 V(I,J)=0D0
33618 210 CONTINUE
33619
33620C...Check if pL acceptable. Go back for new hadron if enough energy.
33621 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
33622 I=I-1
33623 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
33624 ENDIF
33625 IF(W.GT.PARJ(31)) GOTO 190
33626 N=I
33627 220 CONTINUE
33628 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
33629 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
33630
33631C...Rotate jet to new direction.
33632 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
33633 PHI=PYANGL(P(IP1,1),P(IP1,2))
33634 MSTU(33)=1
33635 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
33636 K(K(IP1,3),4)=NSAV1+1
33637 K(K(IP1,3),5)=N
33638
33639C...End of jet generation loop. Skip conservation in some cases.
33640 230 CONTINUE
33641 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
33642 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
33643
33644C...Subtract off produced hadron flavours, finished if zero.
33645 DO 240 I=NSAV+NJET+1,N
33646 KFA=IABS(K(I,2))
33647 KFLA=MOD(KFA/1000,10)
33648 KFLB=MOD(KFA/100,10)
33649 KFLC=MOD(KFA/10,10)
33650 IF(KFLA.EQ.0) THEN
33651 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
33652 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
33653 ELSE
33654 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
33655 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
33656 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
33657 ENDIF
33658 240 CONTINUE
33659 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33660 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33661 IF(NREQ.EQ.0) GOTO 320
33662
33663C...Take away flavour of low-momentum particles until enough freedom.
33664 NREM=0
33665 250 IREM=0
33666 P2MIN=PECM**2
33667 DO 260 I=NSAV+NJET+1,N
33668 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
33669 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
33670 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
33671 260 CONTINUE
33672 IF(IREM.EQ.0) GOTO 150
33673 K(IREM,1)=7
33674 KFA=IABS(K(IREM,2))
33675 KFLA=MOD(KFA/1000,10)
33676 KFLB=MOD(KFA/100,10)
33677 KFLC=MOD(KFA/10,10)
33678 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
33679 IF(K(IREM,1).EQ.8) GOTO 250
33680 IF(KFLA.EQ.0) THEN
33681 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
33682 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
33683 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
33684 ELSE
33685 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
33686 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
33687 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
33688 ENDIF
33689 NREM=NREM+1
33690 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33691 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33692 IF(NREQ.GT.NREM) GOTO 250
33693 DO 270 I=NSAV+NJET+1,N
33694 IF(K(I,1).EQ.8) K(I,1)=1
33695 270 CONTINUE
33696
33697C...Find combination of existing and new flavours for hadron.
33698 280 NFET=2
33699 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
33700 IF(NREQ.LT.NREM) NFET=1
33701 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
33702 DO 290 J=1,NFET
33703 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
33704 KFLF(J)=ISIGN(1,NFL(1))
33705 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
33706 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
33707 290 CONTINUE
33708 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
33709 &GOTO 280
33710 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
33711 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
33712 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
33713 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
33714 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
33715 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
33716 IF(NFET.LE.2) KFLF(3)=0
33717 IF(KFLF(3).NE.0) THEN
33718 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
33719 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
33720 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
33721 & KFLFC=KFLFC+ISIGN(2,KFLFC)
33722 ELSE
33723 KFLFC=KFLF(1)
33724 ENDIF
33725 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
33726 IF(KF.EQ.0) GOTO 280
33727 DO 300 J=1,MAX(2,NFET)
33728 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
33729 300 CONTINUE
33730
33731C...Store hadron at random among free positions.
33732 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
33733 DO 310 I=NSAV+NJET+1,N
33734 IF(K(I,1).EQ.7) NPOS=NPOS-1
33735 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
33736 K(I,1)=1
33737 K(I,2)=KF
33738 P(I,5)=PYMASS(K(I,2))
33739 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33740 310 CONTINUE
33741 NREM=NREM-1
33742 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33743 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33744 IF(NREM.GT.0) GOTO 280
33745
33746C...Compensate for missing momentum in global scheme (3 options).
33747 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
33748 DO 340 J=1,3
33749 PSI(J)=0D0
33750 DO 330 I=NSAV+NJET+1,N
33751 PSI(J)=PSI(J)+P(I,J)
33752 330 CONTINUE
33753 340 CONTINUE
33754 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
33755 PWS=0D0
33756 DO 350 I=NSAV+NJET+1,N
33757 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
33758 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33759 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33760 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
33761 350 CONTINUE
33762 DO 370 I=NSAV+NJET+1,N
33763 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
33764 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33765 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33766 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
33767 DO 360 J=1,3
33768 P(I,J)=P(I,J)-PSI(J)*PW/PWS
33769 360 CONTINUE
33770 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33771 370 CONTINUE
33772
33773C...Compensate for missing momentum withing each jet separately.
33774 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
33775 DO 390 I=N+1,N+NJET
33776 K(I,1)=0
33777 DO 380 J=1,5
33778 P(I,J)=0D0
33779 380 CONTINUE
33780 390 CONTINUE
33781 DO 410 I=NSAV+NJET+1,N
33782 IR1=K(I,3)
33783 IR2=N+IR1-NSAV
33784 K(IR2,1)=K(IR2,1)+1
33785 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33786 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33787 DO 400 J=1,3
33788 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
33789 400 CONTINUE
33790 P(IR2,4)=P(IR2,4)+P(I,4)
33791 P(IR2,5)=P(IR2,5)+PLS
33792 410 CONTINUE
33793 PSS=0D0
33794 DO 420 I=N+1,N+NJET
33795 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
33796 420 CONTINUE
33797 DO 440 I=NSAV+NJET+1,N
33798 IR1=K(I,3)
33799 IR2=N+IR1-NSAV
33800 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33801 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33802 DO 430 J=1,3
33803 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
33804 & PLS*P(IR1,J)
33805 430 CONTINUE
33806 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33807 440 CONTINUE
33808 ENDIF
33809
33810C...Scale momenta for energy conservation.
33811 IF(MOD(MSTJ(3),5).NE.0) THEN
33812 PMS=0D0
33813 PES=0D0
33814 PQS=0D0
33815 DO 450 I=NSAV+NJET+1,N
33816 PMS=PMS+P(I,5)
33817 PES=PES+P(I,4)
33818 PQS=PQS+P(I,5)**2/P(I,4)
33819 450 CONTINUE
33820 IF(PMS.GE.PECM) GOTO 150
33821 NECO=0
33822 460 NECO=NECO+1
33823 PFAC=(PECM-PQS)/(PES-PQS)
33824 PES=0D0
33825 PQS=0D0
33826 DO 480 I=NSAV+NJET+1,N
33827 DO 470 J=1,3
33828 P(I,J)=PFAC*P(I,J)
33829 470 CONTINUE
33830 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33831 PES=PES+P(I,4)
33832 PQS=PQS+P(I,5)**2/P(I,4)
33833 480 CONTINUE
33834 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
33835 ENDIF
33836
33837C...Origin of produced particles and parton daughter pointers.
33838 490 DO 500 I=NSAV+NJET+1,N
33839 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
33840 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
33841 500 CONTINUE
33842 DO 510 I=NSAV+1,NSAV+NJET
33843 I1=K(I,3)
33844 K(I1,1)=K(I1,1)+10
33845 IF(MSTU(16).NE.2) THEN
33846 K(I1,4)=NSAV+1
33847 K(I1,5)=NSAV+1
33848 ELSE
33849 K(I1,4)=K(I1,4)-NJET+1
33850 K(I1,5)=K(I1,5)-NJET+1
33851 IF(K(I1,5).LT.K(I1,4)) THEN
33852 K(I1,4)=0
33853 K(I1,5)=0
33854 ENDIF
33855 ENDIF
33856 510 CONTINUE
33857
33858C...Document independent fragmentation system. Remove copy of jets.
33859 NSAV=NSAV+1
33860 K(NSAV,1)=11
33861 K(NSAV,2)=93
33862 K(NSAV,3)=IP
33863 K(NSAV,4)=NSAV+1
33864 K(NSAV,5)=N-NJET+1
33865 DO 520 J=1,4
33866 P(NSAV,J)=DPS(J)
33867 V(NSAV,J)=V(IP,J)
33868 520 CONTINUE
33869 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33870 V(NSAV,5)=0D0
33871 DO 540 I=NSAV+NJET,N
33872 DO 530 J=1,5
33873 K(I-NJET+1,J)=K(I,J)
33874 P(I-NJET+1,J)=P(I,J)
33875 V(I-NJET+1,J)=V(I,J)
33876 530 CONTINUE
33877 540 CONTINUE
33878 N=N-NJET+1
33879 DO 550 IZ=MSTU90+1,MSTU(90)
33880 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
33881 550 CONTINUE
33882
33883C...Boost back particle system. Set production vertices.
33884 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
33885 &DPS(2)/DPS(4),DPS(3)/DPS(4))
33886 DO 570 I=NSAV+1,N
33887 DO 560 J=1,4
33888 V(I,J)=V(IP,J)
33889 560 CONTINUE
33890 570 CONTINUE
33891
33892 RETURN
33893 END
33894
33895C*********************************************************************
33896
33897C...PYDECY
33898C...Handles the decay of unstable particles.
33899
33900 SUBROUTINE PYDECY(IP)
33901
33902C...Double precision and integer declarations.
33903 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33904 INTEGER PYK,PYCHGE,PYCOMP
33905C...Commonblocks.
33906 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33907 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33908 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33909 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
33910 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
33911C...Local arrays.
33912 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
33913 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
33914 CHARACTER CIDC*4
33915 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
33916
33917C...Functions: momentum in two-particle decays and four-product.
33918 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
33919 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
33920
33921C...Initial values.
33922 NTRY=0
33923 NSAV=N
33924 KFA=IABS(K(IP,2))
33925 KFS=ISIGN(1,K(IP,2))
33926 KC=PYCOMP(KFA)
33927 MSTJ(92)=0
33928
33929C...Choose lifetime and determine decay vertex.
33930 IF(K(IP,1).EQ.5) THEN
33931 V(IP,5)=0D0
33932 ELSEIF(K(IP,1).NE.4) THEN
33933 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
33934 ENDIF
33935 DO 100 J=1,4
33936 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
33937 100 CONTINUE
33938
33939C...Determine whether decay allowed or not.
33940 MOUT=0
33941 IF(MSTJ(22).EQ.2) THEN
33942 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
33943 ELSEIF(MSTJ(22).EQ.3) THEN
33944 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
33945 ELSEIF(MSTJ(22).EQ.4) THEN
33946 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
33947 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
33948 ENDIF
33949 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
33950 K(IP,1)=4
33951 RETURN
33952 ENDIF
33953
33954C...Interface to external tau decay library (for tau polarization).
33955 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
33956
33957C...Starting values for pointers and momenta.
33958 ITAU=IP
33959 DO 110 J=1,4
33960 PTAU(J)=P(ITAU,J)
33961 PCMTAU(J)=P(ITAU,J)
33962 110 CONTINUE
33963
33964C...Iterate to find position and code of mother of tau.
33965 IMTAU=ITAU
33966 120 IMTAU=K(IMTAU,3)
33967
33968 IF(IMTAU.EQ.0) THEN
33969C...If no known origin then impossible to do anything further.
33970 KFORIG=0
33971 IORIG=0
33972
33973 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
33974C...If tau -> tau + gamma then add gamma energy and loop.
33975 IF(K(K(IMTAU,4),2).EQ.22) THEN
33976 DO 130 J=1,4
33977 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
33978 130 CONTINUE
33979 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
33980 DO 140 J=1,4
33981 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
33982 140 CONTINUE
33983 ENDIF
33984 GOTO 120
33985
33986 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
33987C...If coming from weak decay of hadron then W is not stored in record,
33988C...but can be reconstructed by adding neutrino momentum.
33989 KFORIG=-ISIGN(24,K(ITAU,2))
33990 IORIG=0
33991 DO 160 II=K(IMTAU,4),K(IMTAU,5)
33992 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
33993 DO 150 J=1,4
33994 PCMTAU(J)=PCMTAU(J)+P(II,J)
33995 150 CONTINUE
33996 ENDIF
33997 160 CONTINUE
33998
33999 ELSE
34000C...If coming from resonance decay then find latest copy of this
34001C...resonance (may not completely agree).
34002 KFORIG=K(IMTAU,2)
34003 IORIG=IMTAU
34004 DO 170 II=IMTAU+1,IP-1
34005 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
34006 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
34007 170 CONTINUE
34008 DO 180 J=1,4
34009 PCMTAU(J)=P(IORIG,J)
34010 180 CONTINUE
34011 ENDIF
34012
34013C...Boost tau to rest frame of production process (where known)
34014C...and rotate it to sit along +z axis.
34015 DO 190 J=1,3
34016 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
34017 190 CONTINUE
34018 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
34019 & -DBETAU(2),-DBETAU(3))
34020 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
34021 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
34022 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
34023 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
34024
34025C...Call tau decay routine (if meaningful) and fill extra info.
34026 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34027 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
34028 DO 200 II=NSAV+1,NSAV+NDECAY
34029 K(II,1)=1
34030 K(II,3)=IP
34031 K(II,4)=0
34032 K(II,5)=0
34033 200 CONTINUE
34034 N=NSAV+NDECAY
34035 ENDIF
34036
34037C...Boost back decay tau and decay products.
34038 DO 210 J=1,4
34039 P(ITAU,J)=PTAU(J)
34040 210 CONTINUE
34041 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34042 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
34043 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
34044 & DBETAU(2),DBETAU(3))
34045
34046C...Skip past ordinary tau decay treatment.
34047 MMAT=0
34048 MBST=0
34049 ND=0
34050 GOTO 630
34051 ENDIF
34052 ENDIF
34053
34054C...B-Bbar mixing: flip sign of meson appropriately.
34055 MMIX=0
34056 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
34057 XBBMIX=PARJ(76)
34058 IF(KFA.EQ.531) XBBMIX=PARJ(77)
34059 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
34060 IF(MMIX.EQ.1) KFS=-KFS
34061 ENDIF
34062
34063C...Check existence of decay channels. Particle/antiparticle rules.
34064 KCA=KC
34065 IF(MDCY(KC,2).GT.0) THEN
34066 MDMDCY=MDME(MDCY(KC,2),2)
34067 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
34068 ENDIF
34069 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
34070 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
34071 RETURN
34072 ENDIF
34073 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
34074 IF(KCHG(KC,3).EQ.0) THEN
34075 KFSP=1
34076 KFSN=0
34077 IF(PYR(0).GT.0.5D0) KFS=-KFS
34078 ELSEIF(KFS.GT.0) THEN
34079 KFSP=1
34080 KFSN=0
34081 ELSE
34082 KFSP=0
34083 KFSN=1
34084 ENDIF
34085
34086C...Sum branching ratios of allowed decay channels.
34087 220 NOPE=0
34088 BRSU=0D0
34089 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
34090 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34091 & KFSN*MDME(IDL,1).NE.3) GOTO 230
34092 IF(MDME(IDL,2).GT.100) GOTO 230
34093 NOPE=NOPE+1
34094 BRSU=BRSU+BRAT(IDL)
34095 230 CONTINUE
34096 IF(NOPE.EQ.0) THEN
34097 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
34098 RETURN
34099 ENDIF
34100
34101C...Select decay channel among allowed ones.
34102 240 RBR=BRSU*PYR(0)
34103 IDL=MDCY(KCA,2)-1
34104 250 IDL=IDL+1
34105 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34106 &KFSN*MDME(IDL,1).NE.3) THEN
34107 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34108 ELSEIF(MDME(IDL,2).GT.100) THEN
34109 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34110 ELSE
34111 IDC=IDL
34112 RBR=RBR-BRAT(IDL)
34113 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
34114 ENDIF
34115
34116C...Start readout of decay channel: matrix element, reset counters.
34117 MMAT=MDME(IDC,2)
34118 260 NTRY=NTRY+1
34119 IF(MOD(NTRY,200).EQ.0) THEN
34120 WRITE(CIDC,'(I4)') IDC
34121 CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
34122 & CIDC)
34123 GOTO 240
34124 ENDIF
34125 IF(NTRY.GT.1000) THEN
34126 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34127 IF(MSTU(21).GE.1) RETURN
34128 ENDIF
34129 I=N
34130 NP=0
34131 NQ=0
34132 MBST=0
34133 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
34134 DO 270 J=1,4
34135 PV(1,J)=0D0
34136 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
34137 270 CONTINUE
34138 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
34139 PV(1,5)=P(IP,5)
34140 PS=0D0
34141 PSQ=0D0
34142 MREM=0
34143 MHADDY=0
34144 IF(KFA.GT.80) MHADDY=1
34145C.. Random flavour and popcorn system memory.
34146 IRNDMO=0
34147 JTMO=0
34148 MSTU(121)=0
34149 MSTU(125)=10
34150
34151C...Read out decay products. Convert to standard flavour code.
34152 JTMAX=5
34153 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
34154 DO 280 JT=1,JTMAX
34155 IF(JT.LE.5) KP=KFDP(IDC,JT)
34156 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
34157 IF(KP.EQ.0) GOTO 280
34158 KPA=IABS(KP)
34159 KCP=PYCOMP(KPA)
34160 IF(KPA.GT.80) MHADDY=1
34161 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
34162 KFP=KP
34163 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
34164 KFP=KFS*KP
34165 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
34166 KFP=-KFS*MOD(KFA/10,10)
34167 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
34168 KFP=KFS*(100*MOD(KFA/10,100)+3)
34169 ELSEIF(KPA.EQ.81) THEN
34170 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
34171 ELSEIF(KP.EQ.82) THEN
34172 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
34173 IF(KFP.EQ.0) GOTO 260
34174 KFP=-KFP
34175 IRNDMO=1
34176 MSTJ(93)=1
34177 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
34178 ELSEIF(KP.EQ.-82) THEN
34179 KFP=MSTU(124)
34180 ENDIF
34181 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
34182
34183C...Add decay product to event record or to quark flavour list.
34184 KFPA=IABS(KFP)
34185 KQP=KCHG(KCP,2)
34186 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
34187 NQ=NQ+1
34188 KFLO(NQ)=KFP
34189C...set rndmflav popcorn system pointer
34190 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
34191 MSTJ(93)=2
34192 PSQ=PSQ+PYMASS(KFLO(NQ))
34193 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
34194 & MOD(NQ,2).EQ.1) THEN
34195 NQ=NQ-1
34196 PS=PS-P(I,5)
34197 K(I,1)=1
34198 KFI=K(I,2)
34199 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
34200 IF(K(I,2).EQ.0) GOTO 260
34201 MSTJ(93)=1
34202 P(I,5)=PYMASS(K(I,2))
34203 PS=PS+P(I,5)
34204 ELSE
34205 I=I+1
34206 NP=NP+1
34207 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
34208 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
34209 K(I,1)=1+MOD(NQ,2)
34210 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
34211 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
34212 K(I,2)=KFP
34213 K(I,3)=IP
34214 K(I,4)=0
34215 K(I,5)=0
34216 P(I,5)=PYMASS(KFP)
34217 PS=PS+P(I,5)
34218 ENDIF
34219 280 CONTINUE
34220
34221C...Check masses for resonance decays.
34222 IF(MHADDY.EQ.0) THEN
34223 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
34224 ENDIF
34225
34226C...Choose decay multiplicity in phase space model.
34227 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
34228 PSP=PS
34229 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
34230 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
34231 300 NTRY=NTRY+1
34232C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
34233 IF(IRNDMO.EQ.0) THEN
34234 MSTU(121)=0
34235 JTMO=0
34236 ELSEIF(IRNDMO.EQ.1) THEN
34237 IRNDMO=2
34238 ELSE
34239 GOTO 260
34240 ENDIF
34241 IF(NTRY.GT.1000) THEN
34242 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34243 IF(MSTU(21).GE.1) RETURN
34244 ENDIF
34245 IF(MMAT.LE.20) THEN
34246 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
34247 & SIN(PARU(2)*PYR(0))
34248 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
34249 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
34250 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
34251 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
34252 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
34253 ELSE
34254 ND=MMAT-20
34255 ENDIF
34256C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
34257 MSTU(125)=ND-NQ/2
34258 IF(MSTU(121).GT.MSTU(125)) GOTO 300
34259
34260C...Form hadrons from flavour content.
34261 DO 310 JT=1,4
34262 KFL1(JT)=KFLO(JT)
34263 310 CONTINUE
34264 IF(ND.EQ.NP+NQ/2) GOTO 330
34265 DO 320 I=N+NP+1,N+ND-NQ/2
34266C.. Stick to started popcorn system, else pick side at random
34267 JT=JTMO
34268 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
34269 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
34270 IF(K(I,2).EQ.0) GOTO 300
34271 MSTU(125)=MSTU(125)-1
34272 JTMO=0
34273 IF(MSTU(121).GT.0) JTMO=JT
34274 KFL1(JT)=-KFL2
34275 320 CONTINUE
34276 330 JT=2
34277 JT2=3
34278 JT3=4
34279 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
34280 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
34281 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
34282 IF(JT.EQ.3) JT2=2
34283 IF(JT.EQ.4) JT3=2
34284 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
34285 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
34286 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
34287 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
34288
34289C...Check that sum of decay product masses not too large.
34290 PS=PSP
34291 DO 340 I=N+NP+1,N+ND
34292 K(I,1)=1
34293 K(I,3)=IP
34294 K(I,4)=0
34295 K(I,5)=0
34296 P(I,5)=PYMASS(K(I,2))
34297 PS=PS+P(I,5)
34298 340 CONTINUE
34299 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
34300
34301C...Rescale energy to subtract off spectator quark mass.
34302 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
34303 & .AND.NP.GE.3) THEN
34304 PS=PS-P(N+NP,5)
34305 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
34306 DO 350 J=1,5
34307 P(N+NP,J)=PQT*PV(1,J)
34308 PV(1,J)=(1D0-PQT)*PV(1,J)
34309 350 CONTINUE
34310 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34311 ND=NP-1
34312 MREM=1
34313
34314C...Fully specified final state: check mass broadening effects.
34315 ELSE
34316 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
34317 ND=NP
34318 ENDIF
34319
34320C...Determine position of grandmother, number of sisters.
34321 NM=0
34322 KFAS=0
34323 MSGN=0
34324 IF(MMAT.EQ.3) THEN
34325 IM=K(IP,3)
34326 IF(IM.LT.0.OR.IM.GE.IP) IM=0
34327 IF(IM.NE.0) KFAM=IABS(K(IM,2))
34328 IF(IM.NE.0) THEN
34329 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
34330 IF(K(IL,3).EQ.IM) NM=NM+1
34331 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
34332 360 CONTINUE
34333 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
34334 & MOD(KFAM/1000,10).NE.0) NM=0
34335 IF(NM.EQ.2) THEN
34336 KFAS=IABS(K(ISIS,2))
34337 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
34338 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
34339 ENDIF
34340 ENDIF
34341 ENDIF
34342
34343C...Kinematics of one-particle decays.
34344 IF(ND.EQ.1) THEN
34345 DO 370 J=1,4
34346 P(N+1,J)=P(IP,J)
34347 370 CONTINUE
34348 GOTO 630
34349 ENDIF
34350
34351C...Calculate maximum weight ND-particle decay.
34352 PV(ND,5)=P(N+ND,5)
34353 IF(ND.GE.3) THEN
34354 WTMAX=1D0/WTCOR(ND-2)
34355 PMAX=PV(1,5)-PS+P(N+ND,5)
34356 PMIN=0D0
34357 DO 380 IL=ND-1,1,-1
34358 PMAX=PMAX+P(N+IL,5)
34359 PMIN=PMIN+P(N+IL+1,5)
34360 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
34361 380 CONTINUE
34362 ENDIF
34363
34364C...Find virtual gamma mass in Dalitz decay.
34365 390 IF(ND.EQ.2) THEN
34366 ELSEIF(MMAT.EQ.2) THEN
34367 PMES=4D0*PMAS(11,1)**2
34368 PMRHO2=PMAS(131,1)**2
34369 PGRHO2=PMAS(131,2)**2
34370 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
34371 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
34372 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
34373 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
34374 IF(WT.LT.PYR(0)) GOTO 400
34375 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
34376
34377C...M-generator gives weight. If rejected, try again.
34378 ELSE
34379 410 RORD(1)=1D0
34380 DO 440 IL1=2,ND-1
34381 RSAV=PYR(0)
34382 DO 420 IL2=IL1-1,1,-1
34383 IF(RSAV.LE.RORD(IL2)) GOTO 430
34384 RORD(IL2+1)=RORD(IL2)
34385 420 CONTINUE
34386 430 RORD(IL2+1)=RSAV
34387 440 CONTINUE
34388 RORD(ND)=0D0
34389 WT=1D0
34390 DO 450 IL=ND-1,1,-1
34391 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
34392 & (PV(1,5)-PS)
34393 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34394 450 CONTINUE
34395 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
34396 ENDIF
34397
34398C...Perform two-particle decays in respective CM frame.
34399 460 DO 480 IL=1,ND-1
34400 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34401 UE(3)=2D0*PYR(0)-1D0
34402 PHI=PARU(2)*PYR(0)
34403 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
34404 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
34405 DO 470 J=1,3
34406 P(N+IL,J)=PA*UE(J)
34407 PV(IL+1,J)=-PA*UE(J)
34408 470 CONTINUE
34409 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
34410 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
34411 480 CONTINUE
34412
34413C...Lorentz transform decay products to lab frame.
34414 DO 490 J=1,4
34415 P(N+ND,J)=PV(ND,J)
34416 490 CONTINUE
34417 DO 530 IL=ND-1,1,-1
34418 DO 500 J=1,3
34419 BE(J)=PV(IL,J)/PV(IL,4)
34420 500 CONTINUE
34421 GA=PV(IL,4)/PV(IL,5)
34422 DO 520 I=N+IL,N+ND
34423 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34424 DO 510 J=1,3
34425 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34426 510 CONTINUE
34427 P(I,4)=GA*(P(I,4)+BEP)
34428 520 CONTINUE
34429 530 CONTINUE
34430
34431C...Check that no infinite loop in matrix element weight.
34432 NTRY=NTRY+1
34433 IF(NTRY.GT.800) GOTO 560
34434
34435C...Matrix elements for omega and phi decays.
34436 IF(MMAT.EQ.1) THEN
34437 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
34438 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
34439 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
34440 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
34441
34442C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
34443 ELSEIF(MMAT.EQ.2) THEN
34444 FOUR12=FOUR(N+1,N+2)
34445 FOUR13=FOUR(N+1,N+3)
34446 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
34447 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
34448 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
34449
34450C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
34451C...V vector), of form cos**2(theta02) in V1 rest frame, and for
34452C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
34453 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
34454 FOUR10=FOUR(IP,IM)
34455 FOUR12=FOUR(IP,N+1)
34456 FOUR02=FOUR(IM,N+1)
34457 PMS1=P(IP,5)**2
34458 PMS0=P(IM,5)**2
34459 PMS2=P(N+1,5)**2
34460 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
34461 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
34462 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
34463 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
34464 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
34465 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
34466
34467C...Matrix element for "onium" -> g + g + g or gamma + g + g.
34468 ELSEIF(MMAT.EQ.4) THEN
34469 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34470 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
34471 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
34472 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
34473 & ((1D0-HX3)/(HX1*HX2))**2
34474 IF(WT.LT.2D0*PYR(0)) GOTO 390
34475 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
34476 & GOTO 390
34477
34478C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
34479 ELSEIF(MMAT.EQ.41) THEN
34480 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34481 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
34482 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
34483
34484C...Matrix elements for weak decays (only semileptonic for c and b)
34485 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34486 & .AND.ND.EQ.3) THEN
34487 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
34488 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
34489 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34490 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
34491 DO 550 J=1,4
34492 P(N+NP+1,J)=0D0
34493 DO 540 IS=N+3,N+NP
34494 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
34495 540 CONTINUE
34496 550 CONTINUE
34497 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
34498 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
34499 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34500 ENDIF
34501
34502C...Scale back energy and reattach spectator.
34503 560 IF(MREM.EQ.1) THEN
34504 DO 570 J=1,5
34505 PV(1,J)=PV(1,J)/(1D0-PQT)
34506 570 CONTINUE
34507 ND=ND+1
34508 MREM=0
34509 ENDIF
34510
34511C...Low invariant mass for system with spectator quark gives particle,
34512C...not two jets. Readjust momenta accordingly.
34513 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
34514 MSTJ(93)=1
34515 PM2=PYMASS(K(N+2,2))
34516 MSTJ(93)=1
34517 PM3=PYMASS(K(N+3,2))
34518 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
34519 & (PARJ(32)+PM2+PM3)**2) GOTO 630
34520 K(N+2,1)=1
34521 KFTEMP=K(N+2,2)
34522 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
34523 IF(K(N+2,2).EQ.0) GOTO 260
34524 P(N+2,5)=PYMASS(K(N+2,2))
34525 PS=P(N+1,5)+P(N+2,5)
34526 PV(2,5)=P(N+2,5)
34527 MMAT=0
34528 ND=2
34529 GOTO 460
34530 ELSEIF(MMAT.EQ.44) THEN
34531 MSTJ(93)=1
34532 PM3=PYMASS(K(N+3,2))
34533 MSTJ(93)=1
34534 PM4=PYMASS(K(N+4,2))
34535 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
34536 & (PARJ(32)+PM3+PM4)**2) GOTO 600
34537 K(N+3,1)=1
34538 KFTEMP=K(N+3,2)
34539 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
34540 IF(K(N+3,2).EQ.0) GOTO 260
34541 P(N+3,5)=PYMASS(K(N+3,2))
34542 DO 580 J=1,3
34543 P(N+3,J)=P(N+3,J)+P(N+4,J)
34544 580 CONTINUE
34545 P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
34546 HA=P(N+1,4)**2-P(N+2,4)**2
34547 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
34548 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
34549 & (P(N+1,3)-P(N+2,3))**2
34550 HD=(PV(1,4)-P(N+3,4))**2
34551 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
34552 HF=HD*HC-HB**2
34553 HG=HD*HC-HA*HB
34554 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
34555 DO 590 J=1,3
34556 PCOR=HH*(P(N+1,J)-P(N+2,J))
34557 P(N+1,J)=P(N+1,J)+PCOR
34558 P(N+2,J)=P(N+2,J)-PCOR
34559 590 CONTINUE
34560 P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
34561 P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
34562 ND=ND-1
34563 ENDIF
34564
34565C...Check invariant mass of W jets. May give one particle or start over.
34566 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34567 &.AND.IABS(K(N+1,2)).LT.10) THEN
34568 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
34569 MSTJ(93)=1
34570 PM1=PYMASS(K(N+1,2))
34571 MSTJ(93)=1
34572 PM2=PYMASS(K(N+2,2))
34573 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
34574 KFLDUM=INT(1.5D0+PYR(0))
34575 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
34576 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
34577 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
34578 PSM=PYMASS(KF1)+PYMASS(KF2)
34579 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
34580 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
34581 IF(MMAT.EQ.48) GOTO 390
34582 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
34583 K(N+1,1)=1
34584 KFTEMP=K(N+1,2)
34585 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
34586 IF(K(N+1,2).EQ.0) GOTO 260
34587 P(N+1,5)=PYMASS(K(N+1,2))
34588 K(N+2,2)=K(N+3,2)
34589 P(N+2,5)=P(N+3,5)
34590 PS=P(N+1,5)+P(N+2,5)
34591 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34592 PV(2,5)=P(N+3,5)
34593 MMAT=0
34594 ND=2
34595 GOTO 460
34596 ENDIF
34597
34598C...Phase space decay of partons from W decay.
34599 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
34600 KFLO(1)=K(N+1,2)
34601 KFLO(2)=K(N+2,2)
34602 K(N+1,1)=K(N+3,1)
34603 K(N+1,2)=K(N+3,2)
34604 DO 620 J=1,5
34605 PV(1,J)=P(N+1,J)+P(N+2,J)
34606 P(N+1,J)=P(N+3,J)
34607 620 CONTINUE
34608 PV(1,5)=PMR
34609 N=N+1
34610 NP=0
34611 NQ=2
34612 PS=0D0
34613 MSTJ(93)=2
34614 PSQ=PYMASS(KFLO(1))
34615 MSTJ(93)=2
34616 PSQ=PSQ+PYMASS(KFLO(2))
34617 MMAT=11
34618 GOTO 290
34619 ENDIF
34620
34621C...Boost back for rapidly moving particle.
34622 630 N=N+ND
34623 IF(MBST.EQ.1) THEN
34624 DO 640 J=1,3
34625 BE(J)=P(IP,J)/P(IP,4)
34626 640 CONTINUE
34627 GA=P(IP,4)/P(IP,5)
34628 DO 660 I=NSAV+1,N
34629 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34630 DO 650 J=1,3
34631 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34632 650 CONTINUE
34633 P(I,4)=GA*(P(I,4)+BEP)
34634 660 CONTINUE
34635 ENDIF
34636
34637C...Fill in position of decay vertex.
34638 DO 680 I=NSAV+1,N
34639 DO 670 J=1,4
34640 V(I,J)=VDCY(J)
34641 670 CONTINUE
34642 V(I,5)=0D0
34643 680 CONTINUE
34644
34645C...Set up for parton shower evolution from jets.
34646 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
34647 K(NSAV+1,1)=3
34648 K(NSAV+2,1)=3
34649 K(NSAV+3,1)=3
34650 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34651 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34652 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34653 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34654 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34655 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34656 MSTJ(92)=-(NSAV+1)
34657 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
34658 K(NSAV+2,1)=3
34659 K(NSAV+3,1)=3
34660 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34661 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
34662 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
34663 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34664 MSTJ(92)=NSAV+2
34665 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34666 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
34667 K(NSAV+1,1)=3
34668 K(NSAV+2,1)=3
34669 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34670 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
34671 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
34672 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34673 MSTJ(92)=NSAV+1
34674 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34675 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
34676 MSTJ(92)=NSAV+1
34677 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
34678 & THEN
34679 K(NSAV+1,1)=3
34680 K(NSAV+2,1)=3
34681 K(NSAV+3,1)=3
34682 KCP=PYCOMP(K(NSAV+1,2))
34683 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
34684 JCON=4
34685 IF(KQP.LT.0) JCON=5
34686 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
34687 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
34688 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
34689 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
34690 MSTJ(92)=NSAV+1
34691 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
34692 K(NSAV+1,1)=3
34693 K(NSAV+3,1)=3
34694 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
34695 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34696 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34697 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
34698 MSTJ(92)=NSAV+1
34699 ENDIF
34700
34701C...Mark decayed particle; special option for B-Bbar mixing.
34702 IF(K(IP,1).EQ.5) K(IP,1)=15
34703 IF(K(IP,1).LE.10) K(IP,1)=11
34704 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
34705 K(IP,4)=NSAV+1
34706 K(IP,5)=N
34707
34708 RETURN
34709 END
34710
34711C*********************************************************************
34712
34713C...PYDCYK
34714C...Handles flavour production in the decay of unstable particles
34715C...and small string clusters.
34716
34717 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
34718
34719C...Double precision and integer declarations.
34720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34721 INTEGER PYK,PYCHGE,PYCOMP
34722C...Commonblocks.
34723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34725 SAVE /PYDAT1/,/PYDAT2/
34726
34727
34728C.. Call PYKFDI directly if no popcorn option is on
34729 IF(MSTJ(12).LT.2) THEN
34730 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34731 MSTU(124)=KFL3
34732 RETURN
34733 ENDIF
34734
34735 KFL3=0
34736 KF=0
34737 IF(KFL1.EQ.0) RETURN
34738 KF1A=IABS(KFL1)
34739 KF2A=IABS(KFL2)
34740
34741 NSTO=130
34742 NMAX=MIN(MSTU(125),10)
34743
34744C.. Identify rank 0 cluster qq
34745 IRANK=1
34746 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
34747
34748 IF(KF2A.GT.0)THEN
34749C.. Join jets: Fails if store not empty
34750 IF(MSTU(121).GT.0) THEN
34751 MSTU(121)=0
34752 RETURN
34753 ENDIF
34754 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34755 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
34756C.. Pick popcorn meson from store, return same qq, decrease store
34757 KF=MSTU(NSTO+MSTU(121))
34758 KFL3=-KFL1
34759 MSTU(121)=MSTU(121)-1
34760 ELSE
34761C.. Generate new flavour. Then done if no diquark is generated
34762 100 CALL PYKFDI(KFL1,0,KFL3,KF)
34763 IF(MSTU(121).EQ.-1) GOTO 100
34764 MSTU(124)=KFL3
34765 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
34766
34767C.. Simple case if no dynamical popcorn suppressions are considered
34768 IF(MSTJ(12).LT.4) THEN
34769 IF(MSTU(121).EQ.0) RETURN
34770 NMES=1
34771 KFPREV=-KFL3
34772 CALL PYKFDI(KFPREV,0,KFL3,KFM)
34773C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
34774 IF(IABS(KFL3).LE.10)THEN
34775 KFL3=-KFPREV
34776 RETURN
34777 ENDIF
34778 GOTO 120
34779 ENDIF
34780
34781C test output qq against fake Gamma, then return if no popcorn.
34782 GB=2D0
34783 IF(IRANK.NE.0)THEN
34784 CALL PYZDIS(1,2103,5D0,Z)
34785 GB=3D0*(1D0-Z)/Z
34786 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
34787 MSTU(121)=0
34788 GOTO 100
34789 ENDIF
34790 ENDIF
34791 IF(MSTU(121).EQ.0) RETURN
34792
34793C..Set store size memory. Pick fake dynamical variables of qq.
34794 NMES=MSTU(121)
34795 CALL PYPTDI(1,PX3,PY3)
34796 X=1D0
34797 POPM=0D0
34798 G=GB
34799 POPG=GB
34800
34801C.. Pick next popcorn meson, test with fake dynamical variables
34802 110 KFPREV=-KFL3
34803 PX1=-PX3
34804 PY1=-PY3
34805 CALL PYKFDI(KFPREV,0,KFL3,KFM)
34806 IF(MSTU(121).EQ.-1) GOTO 100
34807 CALL PYPTDI(KFL3,PX3,PY3)
34808 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
34809 CALL PYZDIS(KFPREV,KFL3,PM,Z)
34810 G=(1D0-Z)*(G+PM/Z)
34811 X=(1D0-Z)*X
34812
34813 PTST=1D0
34814 GTST=1D0
34815 RTST=PYR(0)
34816 IF(MSTJ(12).GT.4)THEN
34817 POPMN=SQRT((1D0-X)*(G/X-GB))
34818 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
34819 PTST=EXP((POPM-POPMN)*PARF(193))
34820 POPM=POPMN
34821 ENDIF
34822 IF(IRANK.NE.0)THEN
34823 POPGN=X*GB
34824 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
34825 POPG=POPGN
34826 ENDIF
34827 IF(RTST.GT.PTST*GTST)THEN
34828 MSTU(121)=0
34829 IF(RTST.GT.PTST) MSTU(121)=-1
34830 GOTO 100
34831 ENDIF
34832
34833C.. Store meson
34834 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
34835 IF(MSTU(121).GT.0) GOTO 110
34836
34837C.. Test accepted system size. If OK set global popcorn size variable.
34838 IF(NMES.GT.NMAX)THEN
34839 KF=0
34840 KFL3=0
34841 RETURN
34842 ENDIF
34843 MSTU(121)=NMES
34844 ENDIF
34845
34846 RETURN
34847 END
34848
34849C********************************************************************
34850
34851C...PYKFDI
34852C...Generates a new flavour pair and combines off a hadron
34853
34854 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
34855
34856C...Double precision and integer declarations.
34857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34858 INTEGER PYK,PYCHGE,PYCOMP
34859C...Commonblocks.
34860 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34861 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34862 SAVE /PYDAT1/,/PYDAT2/
34863C...Local arrays.
34864 DIMENSION PD(7)
34865
34866 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
34867
34868C...Default flavour values. Input consistency checks.
34869 KF1A=IABS(KFL1)
34870 KF2A=IABS(KFL2)
34871 KFL3=0
34872 KF=0
34873 IF(KF1A.EQ.0) RETURN
34874 IF(KF2A.NE.0)THEN
34875 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
34876 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
34877 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
34878 ENDIF
34879
34880C...Check if tabulated flavour probabilities are to be used.
34881 IF(MSTJ(15).EQ.1) THEN
34882 IF(MSTJ(12).GE.5) CALL PYERRM(29,
34883 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
34884 & ' together with MSTJ(12)>=5 modification')
34885 KTAB1=-1
34886 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
34887 KFL1A=MOD(KF1A/1000,10)
34888 KFL1B=MOD(KF1A/100,10)
34889 KFL1S=MOD(KF1A,10)
34890 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
34891 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
34892 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
34893 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
34894 KTAB2=0
34895 IF(KF2A.NE.0) THEN
34896 KTAB2=-1
34897 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
34898 KFL2A=MOD(KF2A/1000,10)
34899 KFL2B=MOD(KF2A/100,10)
34900 KFL2S=MOD(KF2A,10)
34901 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
34902 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
34903 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
34904 ENDIF
34905 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
34906 ENDIF
34907
34908C.. Recognize rank 0 diquark case
34909 100 IRANK=1
34910 KFDIQ=MAX(KF1A,KF2A)
34911 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
34912
34913C.. Join two flavours to meson or baryon. Test for popcorn.
34914 IF(KF2A.GT.0)THEN
34915 MBARY=0
34916 IF(KFDIQ.GT.10) THEN
34917 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
34918 & CALL PYNMES(KFDIQ)
34919 IF(MSTU(121).NE.0) RETURN
34920 MBARY=2
34921 ENDIF
34922 KFQOLD=KF1A
34923 KFQVER=KF2A
34924 GOTO 130
34925 ENDIF
34926
34927C.. Separate incoming flavours, curtain flavour consistency check
34928 KFIN=KFL1
34929 KFQOLD=KF1A
34930 KFQPOP=KF1A/10000
34931 IF(KF1A.GT.10)THEN
34932 KFIN=-KFL1
34933 KFL1A=MOD(KF1A/1000,10)
34934 KFL1B=MOD(KF1A/100,10)
34935 IF(IRANK.EQ.0)THEN
34936 QAWT=1D0
34937 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
34938 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
34939 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
34940 ENDIF
34941 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN
34942 KFQOLD=KFL1A+KFL1B-KFQPOP
34943 ENDIF
34944
34945C...Meson/baryon choice. Set number of mesons if starting a popcorn
34946C...system.
34947 110 MBARY=0
34948 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
34949 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
34950 MBARY=1
34951 CALL PYNMES(0)
34952 ENDIF
34953 ELSEIF(KF1A.GT.10)THEN
34954 MBARY=2
34955 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
34956 IF(MSTU(121).GT.0) MBARY=-1
34957 ENDIF
34958
34959C..x->H+q: Choose single vertex quark. Jump to form hadron.
34960 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
34961 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
34962 KFL3=ISIGN(KFQVER,-KFIN)
34963 GOTO 130
34964 ENDIF
34965
34966C..x->H+qq: (IDW=proper PARF position for diquark weights)
34967 IDW=160
34968C.. q->B+qq: Get curtain quark, different weights for q->B+B and
34969C.. q->B+M+...
34970 IF(MBARY.EQ.1)THEN
34971 IF(MSTU(121).EQ.0) IDW=150
34972 SQWT=PARF(IDW+1)
34973 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
34974 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
34975C.. Shift to s-curtain parameters if needed
34976 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
34977 PARF(194)=PARF(138)*PARF(139)
34978 PARF(193)=PARJ(8)+PARJ(9)
34979 ENDIF
34980 ENDIF
34981
34982C.. x->H+qq: Get vertex quark
34983 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
34984 IDW=MSTU(122)
34985 MSTU(121)=MSTU(121)-1
34986 IF(IDW.EQ.170) THEN
34987 IF(MSTU(121).EQ.0)THEN
34988 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
34989 ELSE
34990 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
34991 ENDIF
34992 ELSE
34993 IF(MSTU(121).EQ.0)THEN
34994 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
34995 ELSE
34996 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
34997 ENDIF
34998 ENDIF
34999 IPOS=200+30*IPOS+1
35000
35001 IMES=-1
35002 RMES=PYR(0)*PARF(194)
35003 120 IMES=IMES+1
35004 RMES=RMES-PARF(IPOS+IMES)
35005 IF(IMES.EQ.30) THEN
35006 MSTU(121)=-1
35007 KF=-111
35008 RETURN
35009 ENDIF
35010 IF(RMES.GT.0D0) GOTO 120
35011 KMUL=IMES/5
35012 KFJ=2*KMUL+1
35013 IF(KMUL.EQ.2) KFJ=10003
35014 IF(KMUL.EQ.3) KFJ=10001
35015 IF(KMUL.EQ.4) KFJ=20003
35016 IF(KMUL.EQ.5) KFJ=5
35017 IDIAG=0
35018 KFQVER=MOD(IMES,5)+1
35019 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
35020 IF(KFQVER.GT.3)THEN
35021 IDIAG=KFQVER-3
35022 KFQVER=KFQOLD
35023 ENDIF
35024 ELSE
35025 IF(MBARY.EQ.-1) IDW=170
35026 SQWT=PARF(IDW+2)
35027 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
35028 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
35029 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
35030 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
35031 KFQVER=KFQPOP
35032 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
35033 ENDIF
35034 ENDIF
35035
35036C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
35037 KFLDS=3
35038 IF(KFQPOP.NE.KFQVER)THEN
35039 SWT=PARF(IDW+7)
35040 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
35041 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
35042 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
35043 ENDIF
35044 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
35045 & +10000*KFQPOP
35046 KFL3=ISIGN(KFDIQ,KFIN)
35047
35048C..x->M+y: flavour for meson.
35049 130 IF(MBARY.LE.0)THEN
35050 KFLA=MAX(KFQOLD,KFQVER)
35051 KFLB=MIN(KFQOLD,KFQVER)
35052 KFS=ISIGN(1,KFL1)
35053 IF(KFLA.NE.KFQOLD) KFS=-KFS
35054C... Form meson, with spin and flavour mixing for diagonal states.
35055 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35056 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
35057 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
35058 RETURN
35059 ENDIF
35060 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
35061 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
35062 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
35063 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
35064 IF(PYR(0).LT.PARJ(14)) KMUL=2
35065 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
35066 RMUL=PYR(0)
35067 IF(RMUL.LT.PARJ(15)) KMUL=3
35068 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
35069 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
35070 ENDIF
35071 KFLS=3
35072 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
35073 IF(KMUL.EQ.5) KFLS=5
35074 IF(KFLA.NE.KFLB)THEN
35075 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
35076 ELSE
35077 RMIX=PYR(0)
35078 IMIX=2*KFLA+10*KMUL
35079 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
35080 & INT(RMIX+PARF(IMIX)))+KFLS
35081 IF(KFLA.GE.4) KF=110*KFLA+KFLS
35082 ENDIF
35083 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
35084 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
35085
35086C..Optional extra suppression of eta and eta'.
35087C..Allow shift to qq->B+q in old version (set IRANK to 0)
35088 IF(KF.EQ.221.OR.KF.EQ.331)THEN
35089 IF(PYR(0).GT.PARJ(25+KF/300))THEN
35090 IF(KF2A.GT.0) GOTO 130
35091 IF(MSTJ(12).LT.4) IRANK=0
35092 GOTO 110
35093 ENDIF
35094 ENDIF
35095 MSTU(121)=0
35096
35097C.. x->B+y: Flavour for baryon
35098 ELSE
35099 KFLA=KFQVER
35100 IF(KF1A.LE.10) KFLA=KFQOLD
35101 KFLB=MOD(KFDIQ/1000,10)
35102 KFLC=MOD(KFDIQ/100,10)
35103 KFLDS=MOD(KFDIQ,10)
35104 KFLD=MAX(KFLA,KFLB,KFLC)
35105 KFLF=MIN(KFLA,KFLB,KFLC)
35106 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35107
35108C... SU(6) factors for formation of baryon.
35109 KBARY=3
35110 KDMAX=5
35111 KFLG=KFLB
35112 IF(KFLB.NE.KFLC)THEN
35113 KBARY=2*KFLDS-1
35114 KDMAX=1+KFLDS/2
35115 IF(KFLB.GT.2) KDMAX=KDMAX+2
35116 ENDIF
35117 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
35118 KBARY=KBARY+1
35119 KFLG=KFLA
35120 ENDIF
35121
35122 SU6MAX=PARF(140+KDMAX)
35123 SU6DEC=PARJ(18)
35124 SU6S =PARF(146)
35125 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
35126 SU6MAX=1D0
35127 SU6DEC=1D0
35128 SU6S =1D0
35129 ENDIF
35130 SU6OCT=PARF(60+KBARY)
35131 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
35132 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
35133 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
35134 ELSE
35135 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
35136 ENDIF
35137 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
35138
35139C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
35140 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
35141 MSTU(121)=0
35142 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
35143 GOTO 110
35144 ENDIF
35145
35146C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
35147 KSIG=1
35148 KFLS=2
35149 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
35150 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
35151 KSIG=KFLDS/3
35152 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
35153 ENDIF
35154 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
35155 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
35156 ENDIF
35157 RETURN
35158
35159C...Use tabulated probabilities to select new flavour and hadron.
35160 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
35161 KT3L=1
35162 KT3U=6
35163 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
35164 KT3L=1
35165 KT3U=6
35166 ELSEIF(KTAB2.EQ.0) THEN
35167 KT3L=1
35168 KT3U=22
35169 ELSE
35170 KT3L=KTAB2
35171 KT3U=KTAB2
35172 ENDIF
35173 RFL=0D0
35174 DO 160 KTS=0,2
35175 DO 150 KT3=KT3L,KT3U
35176 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
35177 150 CONTINUE
35178 160 CONTINUE
35179 RFL=PYR(0)*RFL
35180 DO 180 KTS=0,2
35181 KTABS=KTS
35182 DO 170 KT3=KT3L,KT3U
35183 KTAB3=KT3
35184 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
35185 IF(RFL.LE.0D0) GOTO 190
35186 170 CONTINUE
35187 180 CONTINUE
35188 190 CONTINUE
35189
35190C...Reconstruct flavour of produced quark/diquark.
35191 IF(KTAB3.LE.6) THEN
35192 KFL3A=KTAB3
35193 KFL3B=0
35194 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
35195 ELSE
35196 KFL3A=1
35197 IF(KTAB3.GE.8) KFL3A=2
35198 IF(KTAB3.GE.11) KFL3A=3
35199 IF(KTAB3.GE.16) KFL3A=4
35200 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
35201 KFL3=1000*KFL3A+100*KFL3B+1
35202 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
35203 & KFL3+2
35204 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
35205 ENDIF
35206
35207C...Reconstruct meson code.
35208 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
35209 &KFL3B.NE.0)) THEN
35210 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35211 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
35212 KF=110+2*KTABS+1
35213 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
35214 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35215 & 25*KTABS)) KF=330+2*KTABS+1
35216 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
35217 KFLA=MAX(KTAB1,KTAB3)
35218 KFLB=MIN(KTAB1,KTAB3)
35219 KFS=ISIGN(1,KFL1)
35220 IF(KFLA.NE.KF1A) KFS=-KFS
35221 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35222 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
35223 KFS=ISIGN(1,KFL1)
35224 IF(KFL1A.EQ.KFL3A) THEN
35225 KFLA=MAX(KFL1B,KFL3B)
35226 KFLB=MIN(KFL1B,KFL3B)
35227 IF(KFLA.NE.KFL1B) KFS=-KFS
35228 ELSEIF(KFL1A.EQ.KFL3B) THEN
35229 KFLA=KFL3A
35230 KFLB=KFL1B
35231 KFS=-KFS
35232 ELSEIF(KFL1B.EQ.KFL3A) THEN
35233 KFLA=KFL1A
35234 KFLB=KFL3B
35235 ELSEIF(KFL1B.EQ.KFL3B) THEN
35236 KFLA=MAX(KFL1A,KFL3A)
35237 KFLB=MIN(KFL1A,KFL3A)
35238 IF(KFLA.NE.KFL1A) KFS=-KFS
35239 ELSE
35240 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
35241 GOTO 100
35242 ENDIF
35243 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35244
35245C...Reconstruct baryon code.
35246 ELSE
35247 IF(KTAB1.GE.7) THEN
35248 KFLA=KFL3A
35249 KFLB=KFL1A
35250 KFLC=KFL1B
35251 ELSE
35252 KFLA=KFL1A
35253 KFLB=KFL3A
35254 KFLC=KFL3B
35255 ENDIF
35256 KFLD=MAX(KFLA,KFLB,KFLC)
35257 KFLF=MIN(KFLA,KFLB,KFLC)
35258 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35259 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
35260 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
35261 ENDIF
35262
35263C...Check that constructed flavour code is an allowed one.
35264 IF(KFL2.NE.0) KFL3=0
35265 KC=PYCOMP(KF)
35266 IF(KC.EQ.0) THEN
35267 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
35268 & 'failed')
35269 GOTO 100
35270 ENDIF
35271
35272 RETURN
35273 END
35274
35275C*********************************************************************
35276
35277C...PYNMES
35278C...Generates number of popcorn mesons and stores some relevant
35279C...parameters.
35280
35281 SUBROUTINE PYNMES(KFDIQ)
35282
35283C...Double precision and integer declarations.
35284 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35285 INTEGER PYK,PYCHGE,PYCOMP
35286C...Commonblocks.
35287 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35288 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35289 SAVE /PYDAT1/,/PYDAT2/
35290
35291 MSTU(121)=0
35292 IF(MSTJ(12).LT.2) RETURN
35293
35294C..Old version: Get 1 or 0 popcorn mesons
35295 IF(MSTJ(12).LT.5)THEN
35296 POPWT=PARF(131)
35297 IF(KFDIQ.NE.0) THEN
35298 KFDIQA=IABS(KFDIQ)
35299 KFA=MOD(KFDIQA/1000,10)
35300 KFB=MOD(KFDIQA/100,10)
35301 KFS=MOD(KFDIQA,10)
35302 POPWT=PARF(132)
35303 IF(KFA.EQ.3) POPWT=PARF(133)
35304 IF(KFB.EQ.3) POPWT=PARF(134)
35305 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
35306 ENDIF
35307 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
35308 RETURN
35309 ENDIF
35310
35311C..New version: Store popcorn- or rank 0 diquark parameters
35312 MSTU(122)=170
35313 PARF(193)=PARJ(8)
35314 PARF(194)=PARF(139)
35315 IF(KFDIQ.NE.0) THEN
35316 MSTU(122)=180
35317 PARF(193)=PARJ(10)
35318 PARF(194)=PARF(140)
35319 ENDIF
35320 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
35321 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
35322 & '(PYNMES:) Neglecting too large popcorn possibility')
35323 RETURN
35324 ENDIF
35325
35326C..New version: Get number of popcorn mesons
35327 100 RTST=PYR(0)
35328 MSTU(121)=-1
35329 110 MSTU(121)=MSTU(121)+1
35330 RTST=RTST/PARF(194)
35331 IF(RTST.LT.1D0) GOTO 110
35332 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT.
35333 & (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100
35334 RETURN
35335 END
35336
35337C*********************************************************************
35338
35339C...PYKFIN
35340C...Precalculates a set of diquark and popcorn weights.
35341C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1)
35342
35343 SUBROUTINE PYKFIN
35344
35345C...Double precision and integer declarations.
35346 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35347 INTEGER PYK,PYCHGE,PYCOMP
35348C...Commonblocks.
35349 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35350 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35351 SAVE /PYDAT1/,/PYDAT2/
35352
35353 DIMENSION SU6(12),SU6M(7)
35354
35355 MSTU(123)=1
35356C..Curtain tunneling factor T(D,q)/T(ud0,u).
35357 IF(MSTJ(12).GE.5) THEN
35358 PMUD0=PYMASS(2101)
35359 PMUD1=PYMASS(2103)-PMUD0
35360 PMUS0=PYMASS(3201)-PMUD0
35361 PMUS1=PYMASS(3203)-PMUS0-PMUD0
35362 PMSS1=PYMASS(3303)-PMUS0-PMUD0
35363 PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
35364 PARF(152)=EXP(-PARJ(8)*PMUS0)
35365 PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151)
35366 PARF(154)=EXP(-PARJ(8)*PMUD1)
35367 PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151)
35368 PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152)
35369 PARF(157)=PARF(154)
35370 ELSE
35371 PAR2M=SQRT(PARJ(2))
35372 PAR3M=SQRT(PARJ(3))
35373 PAR4M=SQRT(PARJ(4))
35374 PARF(151)=PAR2M*PAR3M
35375 PARF(152)=PAR3M
35376 PARF(153)=PAR2M*PARJ(3)*PAR4M
35377 PARF(154)=PAR4M
35378 PARF(155)=PAR4M*PARF(151)
35379 PARF(156)=PAR4M*PARF(152)
35380 PARF(157)=PAR4M
35381 ENDIF
35382
35383C.. Total tunneling factor tau(D,q)=T*vertex*spin.
35384 PARF(161)=PARF(151)
35385 PARF(162)=PARJ(2)*PARF(152)
35386 PARF(163)=PARJ(2)*6D0*PARF(153)
35387 PARF(164)=6D0*PARF(154)
35388 PARF(165)=3D0*PARF(155)
35389 PARF(166)=PARJ(2)*3D0*PARF(156)
35390 PARF(167)=3D0*PARF(157)
35391
35392 DO 100 I=1,7
35393 PARF(150+I)=PARF(150+I)*PARF(160+I)
35394 100 CONTINUE
35395
35396C..Modified SU(6) factors.
35397 PARF(146)=1D0
35398 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
35399 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
35400 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
35401 DO 110 I=1,6
35402 SU6(I)=PARF(60+I)
35403 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
35404 110 CONTINUE
35405 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
35406 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
35407 DO 120 I=1,6
35408 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
35409 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
35410 120 CONTINUE
35411
35412C..Total diquark quark*SU(6).
35413 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
35414 PARF(171)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
35415 PARF(172)=PARF(171)
35416 PARF(173)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
35417 PARF(174)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
35418 PARF(175)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
35419 PARF(176)=PARF(175)
35420 PARF(177)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
35421
35422C..SU(6)max q q' s,c,b
35423 SU6MUD =MAX(SU6(1) , SU6(8) )
35424 SU6M(7)=MAX(SU6(5) , SU6(12))
35425 SU6M(1)=MAX(SU6(7) ,SU6(2),SU6MUD )
35426 SU6M(4)=MAX(SU6(3) ,SU6(4),SU6(10))
35427 SU6M(5)=MAX(SU6(11),SU6(6),SU6M(7))
35428 SU6M(2)=SU6M(1)
35429 SU6M(3)=SU6M(4)
35430 SU6M(6)=SU6M(5)
35431
35432 IF(MSTJ(12).GE.5)THEN
35433C..New version: tau for rank 0 diquark.
35434 PARF(181)=EXP(-PARJ(10)*PMUS0)
35435 PARF(182)=PARJ(2)*PARF(181)
35436 PARF(183)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*PARF(181)
35437 PARF(184)=3D0*EXP(-PARJ(10)*PMUD1)
35438 PARF(185)=3D0*EXP(-PARJ(10)*PMUS1)*PARF(181)
35439 PARF(186)=PARJ(2)*PARF(185)
35440 PARF(187)=2D0*PARF(184)
35441
35442C..New version: s/u curtain ratios.
35443 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35444 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35445 WU=1D0+PARF(187)+PARF(182)+PARF(186)+PARF(184)
35446 PARF(136)=(2D0*(PARF(181)+PARF(185))+PARF(183))/WU
35447 PARF(137)=(PARF(181)+PARF(185))*
35448 & (2D0+PARF(183)/(2D0*PARF(185)))/WU
35449 ELSE
35450C..Old version: Shuffle PARJ(7) into tau
35451 PARF(162)=PARF(162)*PARJ(7)
35452 PARF(163)=PARF(163)*PARJ(7)
35453 PARF(166)=PARF(166)*PARJ(7)
35454
35455C..Old version: s/u curtain ratios.
35456 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35457 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35458 PARF(136)=PARF(135)*PARJ(6)*PARF(161)/PARF(162)
35459 PARF(137)=(1D0+PARF(167))*(2D0+PARF(162))/WU
35460 ENDIF
35461
35462C..Combine SU(6), SU(6)max, tau and T into proper products
35463 DO 140 I=1,7
35464 PARF(180+I)=PARF(180+I)*PARF(170+I)
35465 PARF(170+I)=PARF(170+I)*PARF(160+I)
35466 PARF(160+I)=PARF(160+I)*SU6M(I)/SU6MUD
35467 PARF(150+I)=PARF(150+I)*SU6M(I)/SU6MUD
35468 140 CONTINUE
35469
35470C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
35471 PARF(141)=SU6MUD
35472 PARF(142)=SU6M(7)
35473 PARF(143)=SU6M(1)
35474 PARF(144)=SU6M(5)
35475 PARF(145)=SU6M(3)
35476
35477 IF(MSTJ(12).LT.5)THEN
35478C.. Old version: Resulting popcorn weights.
35479 PARF(138)=PARJ(6)
35480 WS=PARF(135)*PARF(138)
35481 WQ=WU*PARJ(5)/3D0
35482 PARF(132)=WQ*PARF(167)/PARF(157)
35483 PARF(133)=WQ*(PARF(166)/PARF(156)+WS*PARF(165)/PARF(155))/2D0
35484 PARF(134)=WQ*WS*PARF(163)/PARF(153)
35485 PARF(131)=WQ*((1D0+PARF(167))*(1D0+PARF(162)+WS*PARF(161))+
35486 & PARF(164)+WS*PARF(163)/2D0)/
35487 & ((1D0+PARF(157))*(1D0+2D0*PARF(152))+PARF(154)+PARF(153)/2D0)
35488 ELSE
35489C..New version: Store weights for popcorn mesons,
35490C..get prel. popcorn weights.
35491 DO 150 IPOS=201,1400
35492 PARF(IPOS)=0D0
35493 150 CONTINUE
35494 DO 160 I=138,140
35495 PARF(I)=0D0
35496 160 CONTINUE
35497 IPOS=200
35498 PARF(193)=PARJ(8)
35499 DO 240 MR=170,180,10
35500 IF(MR.EQ.180) PARF(193)=PARJ(10)
35501 SQWT=2D0*(PARF(MR+2)+PARF(MR+6))/(1D0+PARF(MR+7)+PARF(MR+4))
35502 QQWT=PARF(MR+4)/(1D0+PARF(MR+7)+PARF(MR+4))
35503 DO 230 NMES=0,1
35504 IF(NMES.EQ.1) SQWT=PARJ(2)
35505 DO 220 KFQPOP=1,4
35506 IF(MR.EQ.170.AND.KFQPOP.GT.3) GOTO 220
35507 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
35508 SQWT=PARF(MR+3)/(PARF(MR+1)+PARF(MR+5))
35509 QQWT=0.5D0
35510 IF(MR.EQ.170) PARF(193)=PARJ(8)+PARJ(9)
35511 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/PARF(185)+1D0)/2D0
35512 ENDIF
35513 DO 210 KFQOLD =1,5
35514 IF(MR.EQ.170.AND.KFQOLD.GT.3) GOTO 210
35515 IF(MR*NMES.EQ.170.AND.KFQPOP.EQ.1) GOTO 210
35516 IF(MR*NMES.EQ.180.AND.KFQPOP.NE.1) GOTO 210
35517 WTTOT=0D0
35518 WTFAIL=0D0
35519 DO 190 KMUL=0,5
35520 PJWT=PARJ(12+KMUL)
35521 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
35522 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
35523 IF(PJWT.LE.0D0) GOTO 190
35524 IF(PJWT.GT.1D0) PJWT=1D0
35525 IMES=5*KMUL
35526 IMIX=2*KFQOLD+10*KMUL
35527 KFJ=2*KMUL+1
35528 IF(KMUL.EQ.2) KFJ=10003
35529 IF(KMUL.EQ.3) KFJ=10001
35530 IF(KMUL.EQ.4) KFJ=20003
35531 IF(KMUL.EQ.5) KFJ=5
35532 DO 180 KFQVER =1,3
35533 KFLA=MAX(KFQOLD,KFQVER)
35534 KFLB=MIN(KFQOLD,KFQVER)
35535 SWT=PARJ(11+KFLA/3+KFLA/4)
35536 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
35537 SWT=SWT*PJWT
35538 QWT=SQWT/(2D0+SQWT)
35539 IF(KFQVER.LT.3)THEN
35540 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
35541 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
35542 ENDIF
35543 IF(KFQVER.NE.KFQOLD)THEN
35544 IMES=IMES+1
35545 KFM=100*KFLA+10*KFLB+KFJ
35546 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35547 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
35548 WTTOT=WTTOT+PARF(IPOS+IMES)
35549 ELSE
35550 DO 170 ID=3,5
35551 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
35552 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
35553 IF(ID.EQ.5) DWT=PARF(IMIX)
35554 KFM=110*(ID-2)+KFJ
35555 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35556 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
35557 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
35558 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
35559 PARF(IPOS+5*KMUL+ID)=
35560 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
35561 ENDIF
35562 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
35563 170 CONTINUE
35564 ENDIF
35565 180 CONTINUE
35566 190 CONTINUE
35567 DO 200 IMES=1,30
35568 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
35569 200 CONTINUE
35570 IF(MR.EQ.180) PARF(140)=
35571 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
35572 IF(MR.EQ.170) PARF(139-KFQPOP/3)=
35573 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
35574 IPOS=IPOS+30
35575 210 CONTINUE
35576 220 CONTINUE
35577 230 CONTINUE
35578 240 CONTINUE
35579 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
35580 MSTU(121)=0
35581
35582 PARF(186)=PARF(186)/PARF(182)
35583 PARF(185)=PARF(185)/PARF(181)
35584 ENDIF
35585
35586C..Recombine diquark weights to flavour and spin ratios
35587 DO 250 I=150,170,10
35588 WSWQ=(2D0*(PARF(I+1)+PARF(I+5))+PARF(I+3))/
35589 & (1D0+PARF(I+7)+PARF(I+4)+PARF(I+2)+PARF(I+6))
35590 WSSWSQ=PARF(I+3)/(PARF(I+1)+PARF(I+5))
35591 WQSWQQ=2D0*(PARF(I+2)+PARF(I+6))/(1D0+PARF(I+7)+PARF(I+4))
35592 WUUWQQ=PARF(I+4)/(1D0+PARF(I+7)+PARF(I+4))
35593 PARF(I+5)=PARF(I+5)/PARF(I+1)
35594 PARF(I+6)=PARF(I+6)/PARF(I+2)
35595 PARF(I+1)=WSWQ
35596 PARF(I+2)=WQSWQQ
35597 PARF(I+3)=WSSWSQ
35598 PARF(I+4)=WUUWQQ
35599 250 CONTINUE
35600 RETURN
35601 END
35602
35603C*********************************************************************
35604
35605C...PYPTDI
35606C...Generates transverse momentum according to a Gaussian.
35607
35608 SUBROUTINE PYPTDI(KFL,PX,PY)
35609
35610C...Double precision and integer declarations.
35611 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35612 INTEGER PYK,PYCHGE,PYCOMP
35613C...Commonblocks.
35614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35615 SAVE /PYDAT1/
35616
35617C...Generate p_T and azimuthal angle, gives p_x and p_y.
35618 KFLA=IABS(KFL)
35619 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
35620 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
35621 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
35622 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
35623 PHI=PARU(2)*PYR(0)
35624 PX=PT*COS(PHI)
35625 PY=PT*SIN(PHI)
35626
35627 RETURN
35628 END
35629
35630C*********************************************************************
35631
35632C...PYZDIS
35633C...Generates the longitudinal splitting variable z.
35634
35635 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
35636
35637C...Double precision and integer declarations.
35638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35639 INTEGER PYK,PYCHGE,PYCOMP
35640C...Commonblocks.
35641 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35642 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35643 SAVE /PYDAT1/,/PYDAT2/
35644
35645C...Check if heavy flavour fragmentation.
35646 KFLA=IABS(KFL1)
35647 KFLB=IABS(KFL2)
35648 KFLH=KFLA
35649 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
35650
35651C...Lund symmetric scaling function: determine parameters of shape.
35652 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
35653 &MSTJ(11).GE.4) THEN
35654 FA=PARJ(41)
35655 IF(MSTJ(91).EQ.1) FA=PARJ(43)
35656 IF(KFLB.GE.10) FA=FA+PARJ(45)
35657 FBB=PARJ(42)
35658 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
35659 FB=FBB*PR
35660 FC=1D0
35661 IF(KFLA.GE.10) FC=FC-PARJ(45)
35662 IF(KFLB.GE.10) FC=FC+PARJ(45)
35663 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
35664 FRED=PARJ(46)
35665 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
35666 FC=FC+FRED*FBB*PARF(100+KFLH)**2
35667 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
35668 FRED=PARJ(46)
35669 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
35670 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
35671 ENDIF
35672 MC=1
35673 IF(ABS(FC-1D0).GT.0.01D0) MC=2
35674
35675C...Determine position of maximum. Special cases for a = 0 or a = c.
35676 IF(FA.LT.0.02D0) THEN
35677 MA=1
35678 ZMAX=1D0
35679 IF(FC.GT.FB) ZMAX=FB/FC
35680 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
35681 MA=2
35682 ZMAX=FB/(FB+FC)
35683 ELSE
35684 MA=3
35685 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
35686 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
35687 ENDIF
35688
35689C...Subdivide z range if distribution very peaked near endpoint.
35690 MMAX=2
35691 IF(ZMAX.LT.0.1D0) THEN
35692 MMAX=1
35693 ZDIV=2.75D0*ZMAX
35694 IF(MC.EQ.1) THEN
35695 FINT=1D0-LOG(ZDIV)
35696 ELSE
35697 ZDIVC=ZDIV**(1D0-FC)
35698 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
35699 ENDIF
35700 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
35701 MMAX=3
35702 FSCB=SQRT(4D0+(FC/FB)**2)
35703 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
35704 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
35705 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
35706 FINT=1D0+FB*(1D0-ZDIV)
35707 ENDIF
35708
35709C...Choice of z, preweighted for peaks at low or high z.
35710 100 Z=PYR(0)
35711 FPRE=1D0
35712 IF(MMAX.EQ.1) THEN
35713 IF(FINT*PYR(0).LE.1D0) THEN
35714 Z=ZDIV*Z
35715 ELSEIF(MC.EQ.1) THEN
35716 Z=ZDIV**Z
35717 FPRE=ZDIV/Z
35718 ELSE
35719 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
35720 FPRE=(ZDIV/Z)**FC
35721 ENDIF
35722 ELSEIF(MMAX.EQ.3) THEN
35723 IF(FINT*PYR(0).LE.1D0) THEN
35724 Z=ZDIV+LOG(Z)/FB
35725 FPRE=EXP(FB*(Z-ZDIV))
35726 ELSE
35727 Z=ZDIV+Z*(1D0-ZDIV)
35728 ENDIF
35729 ENDIF
35730
35731C...Weighting according to correct formula.
35732 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
35733 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
35734 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
35735 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
35736 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
35737
35738C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
35739 ELSE
35740 FC=PARJ(50+MAX(1,KFLH))
35741 IF(MSTJ(91).EQ.1) FC=PARJ(59)
35742 110 Z=PYR(0)
35743 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
35744 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
35745 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
35746 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
35747 & GOTO 110
35748 ELSE
35749 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
35750 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
35751 ENDIF
35752 ENDIF
35753
35754 RETURN
35755 END
35756
35757C*********************************************************************
35758
35759C...PYSHOW
35760C...Generates timelike parton showers from given partons.
35761
35762 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
35763
35764C...Double precision and integer declarations.
35765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35766 INTEGER PYK,PYCHGE,PYCOMP
35767C...Commonblocks.
35768 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
35769 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35770 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35771 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
35772C...Local arrays.
35773 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
35774 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
35775 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
35776 &ISII(2)
35777
35778C...Initialization of cutoff masses etc.
35779 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
35780 &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
35781 DO 100 IFL=0,40
35782 KSH(IFL)=0
35783 100 CONTINUE
35784 KSH(21)=1
35785 PMTH(1,21)=PYMASS(21)
35786 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
35787 PMTH(3,21)=2D0*PMTH(2,21)
35788 PMTH(4,21)=PMTH(3,21)
35789 PMTH(5,21)=PMTH(3,21)
35790 PMTH(1,22)=PYMASS(22)
35791 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
35792 PMTH(3,22)=2D0*PMTH(2,22)
35793 PMTH(4,22)=PMTH(3,22)
35794 PMTH(5,22)=PMTH(3,22)
35795 PMQTH1=PARJ(82)
35796 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
35797 PMQTH2=PMTH(2,21)
35798 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
35799 DO 110 IFL=1,8
35800 KSH(IFL)=1
35801 PMTH(1,IFL)=PYMASS(IFL)
35802 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
35803 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
35804 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
35805 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
35806 110 CONTINUE
35807 DO 120 IFL=11,17,2
35808 IF(MSTJ(41).GE.2) KSH(IFL)=1
35809 PMTH(1,IFL)=PYMASS(IFL)
35810 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)
35811 PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
35812 PMTH(4,IFL)=PMTH(3,IFL)
35813 PMTH(5,IFL)=PMTH(3,IFL)
35814 120 CONTINUE
35815 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
35816 ALAMS=PARJ(81)**2
35817 ALFM=LOG(PT2MIN/ALAMS)
35818
35819C...Store positions of shower initiating partons.
35820 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
35821 NPA=1
35822 IPA(1)=IP1
35823 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
35824 & MSTU(32))) THEN
35825 NPA=2
35826 IPA(1)=IP1
35827 IPA(2)=IP2
35828 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
35829 & .AND.IP2.GE.-3) THEN
35830 NPA=IABS(IP2)
35831 DO 130 I=1,NPA
35832 IPA(I)=IP1+I-1
35833 130 CONTINUE
35834 ELSE
35835 CALL PYERRM(12,
35836 & '(PYSHOW:) failed to reconstruct showering system')
35837 IF(MSTU(21).GE.1) RETURN
35838 ENDIF
35839
35840C...Check on phase space available for emission.
35841 IREJ=0
35842 DO 140 J=1,5
35843 PS(J)=0D0
35844 140 CONTINUE
35845 PM=0D0
35846 DO 160 I=1,NPA
35847 KFLA(I)=IABS(K(IPA(I),2))
35848 PMA(I)=P(IPA(I),5)
35849C...Special cutoff masses for t, l, h with variable masses.
35850 IFLA=KFLA(I)
35851 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
35852 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
35853 PMTH(1,IFLA)=PMA(I)
35854 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
35855 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
35856 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
35857 & PMTH(2,21)
35858 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
35859 & PMTH(2,22)
35860 ENDIF
35861 IF(KFLA(I).LE.40) THEN
35862 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
35863 ENDIF
35864 PM=PM+PMA(I)
35865 IF(KFLA(I).GT.40) THEN
35866 IREJ=IREJ+1
35867 ELSE
35868 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
35869 ENDIF
35870 DO 150 J=1,4
35871 PS(J)=PS(J)+P(IPA(I),J)
35872 150 CONTINUE
35873 160 CONTINUE
35874 IF(IREJ.EQ.NPA) RETURN
35875 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
35876 IF(NPA.EQ.1) PS(5)=PS(4)
35877 IF(PS(5).LE.PM+PMQTH1) RETURN
35878
35879C...Check if 3-jet matrix elements to be used.
35880 M3JC=0
35881 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
35882 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
35883 & KFLA(2).LE.8) M3JC=1
35884 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
35885 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
35886 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
35887 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
35888 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
35889 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
35890 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
35891 M3JCM=0
35892 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
35893 M3JCM=1
35894 QME=(2D0*PMTH(1,KFLA(1))/PS(5))**2
35895 ENDIF
35896 ENDIF
35897
35898C...Find if interference with initial state partons.
35899 MIIS=0
35900 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
35901 IF(MIIS.NE.0) THEN
35902 DO 180 I=1,2
35903 KCII(I)=0
35904 KCA=PYCOMP(KFLA(I))
35905 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
35906 NIIS(I)=0
35907 IF(KCII(I).NE.0) THEN
35908 DO 170 J=1,2
35909 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
35910 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
35911 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
35912 NIIS(I)=NIIS(I)+1
35913 IIIS(I,NIIS(I))=ICSI
35914 ENDIF
35915 170 CONTINUE
35916 ENDIF
35917 180 CONTINUE
35918 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
35919 ENDIF
35920
35921C...Boost interfering initial partons to rest frame
35922C...and reconstruct their polar and azimuthal angles.
35923 IF(MIIS.NE.0) THEN
35924 DO 200 I=1,2
35925 DO 190 J=1,5
35926 K(N+I,J)=K(IPA(I),J)
35927 P(N+I,J)=P(IPA(I),J)
35928 V(N+I,J)=0D0
35929 190 CONTINUE
35930 200 CONTINUE
35931 DO 220 I=3,2+NIIS(1)
35932 DO 210 J=1,5
35933 K(N+I,J)=K(IIIS(1,I-2),J)
35934 P(N+I,J)=P(IIIS(1,I-2),J)
35935 V(N+I,J)=0D0
35936 210 CONTINUE
35937 220 CONTINUE
35938 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
35939 DO 230 J=1,5
35940 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
35941 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
35942 V(N+I,J)=0D0
35943 230 CONTINUE
35944 240 CONTINUE
35945 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
35946 & -PS(2)/PS(4),-PS(3)/PS(4))
35947 PHI=PYANGL(P(N+1,1),P(N+1,2))
35948 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
35949 THE=PYANGL(P(N+1,3),P(N+1,1))
35950 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
35951 DO 250 I=3,2+NIIS(1)
35952 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
35953 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
35954 250 CONTINUE
35955 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
35956 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
35957 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
35958 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
35959 260 CONTINUE
35960 ENDIF
35961
35962C...Define imagined single initiator of shower for parton system.
35963 NS=N
35964 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
35965 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
35966 IF(MSTU(21).GE.1) RETURN
35967 ENDIF
35968 IF(NPA.GE.2) THEN
35969 K(N+1,1)=11
35970 K(N+1,2)=21
35971 K(N+1,3)=0
35972 K(N+1,4)=0
35973 K(N+1,5)=0
35974 P(N+1,1)=0D0
35975 P(N+1,2)=0D0
35976 P(N+1,3)=0D0
35977 P(N+1,4)=PS(5)
35978 P(N+1,5)=PS(5)
35979 V(N+1,5)=PS(5)**2
35980 N=N+1
35981 ENDIF
35982
35983C...Loop over partons that may branch.
35984 NEP=NPA
35985 IM=NS
35986 IF(NPA.EQ.1) IM=NS-1
35987 270 IM=IM+1
35988 IF(N.GT.NS) THEN
35989 IF(IM.GT.N) GOTO 510
35990 KFLM=IABS(K(IM,2))
35991 IF(KFLM.GT.40) GOTO 270
35992 IF(KSH(KFLM).EQ.0) GOTO 270
35993 IFLM=KFLM
35994 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
35995 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
35996 IGM=K(IM,3)
35997 ELSE
35998 IGM=-1
35999 ENDIF
36000 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
36001 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36002 IF(MSTU(21).GE.1) RETURN
36003 ENDIF
36004
36005C...Position of aunt (sister to branching parton).
36006C...Origin and flavour of daughters.
36007 IAU=0
36008 IF(IGM.GT.0) THEN
36009 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
36010 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
36011 ENDIF
36012 IF(IGM.GE.0) THEN
36013 K(IM,4)=N+1
36014 DO 280 I=1,NEP
36015 K(N+I,3)=IM
36016 280 CONTINUE
36017 ELSE
36018 K(N+1,3)=IPA(1)
36019 ENDIF
36020 IF(IGM.LE.0) THEN
36021 DO 290 I=1,NEP
36022 K(N+I,2)=K(IPA(I),2)
36023 290 CONTINUE
36024 ELSEIF(KFLM.NE.21) THEN
36025 K(N+1,2)=K(IM,2)
36026 K(N+2,2)=K(IM,5)
36027 ELSEIF(K(IM,5).EQ.21) THEN
36028 K(N+1,2)=21
36029 K(N+2,2)=21
36030 ELSE
36031 K(N+1,2)=K(IM,5)
36032 K(N+2,2)=-K(IM,5)
36033 ENDIF
36034
36035C...Reset flags on daughers and tries made.
36036 DO 300 IP=1,NEP
36037 K(N+IP,1)=3
36038 K(N+IP,4)=0
36039 K(N+IP,5)=0
36040 KFLD(IP)=IABS(K(N+IP,2))
36041 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
36042 ITRY(IP)=0
36043 ISL(IP)=0
36044 ISI(IP)=0
36045 IF(KFLD(IP).LE.40) THEN
36046 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
36047 ENDIF
36048 300 CONTINUE
36049 ISLM=0
36050
36051C...Maximum virtuality of daughters.
36052 IF(IGM.LE.0) THEN
36053 DO 310 I=1,NPA
36054 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
36055 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
36056 P(N+I,5)=MIN(QMAX,PS(5))
36057 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
36058 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
36059 310 CONTINUE
36060 ELSE
36061 IF(MSTJ(43).LE.2) PEM=V(IM,2)
36062 IF(MSTJ(43).GE.3) PEM=P(IM,4)
36063 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
36064 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
36065 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
36066 ENDIF
36067 DO 320 I=1,NEP
36068 PMSD(I)=P(N+I,5)
36069 IF(ISI(I).EQ.1) THEN
36070 IFLD=KFLD(I)
36071 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36072 & ISIGN(2,K(N+I,2))
36073 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
36074 ENDIF
36075 V(N+I,5)=P(N+I,5)**2
36076 320 CONTINUE
36077
36078C...Choose one of the daughters for evolution.
36079 330 INUM=0
36080 IF(NEP.EQ.1) INUM=1
36081 DO 340 I=1,NEP
36082 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
36083 340 CONTINUE
36084 DO 350 I=1,NEP
36085 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
36086 IFLD=KFLD(I)
36087 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36088 & ISIGN(2,K(N+I,2))
36089 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
36090 ENDIF
36091 350 CONTINUE
36092 IF(INUM.EQ.0) THEN
36093 RMAX=0D0
36094 DO 360 I=1,NEP
36095 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
36096 RPM=P(N+I,5)/PMSD(I)
36097 IFLD=KFLD(I)
36098 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36099 & ISIGN(2,K(N+I,2))
36100 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
36101 RMAX=RPM
36102 INUM=I
36103 ENDIF
36104 ENDIF
36105 360 CONTINUE
36106 ENDIF
36107
36108C...Store information on choice of evolving daughter.
36109 INUM=MAX(1,INUM)
36110 IEP(1)=N+INUM
36111 DO 370 I=2,NEP
36112 IEP(I)=IEP(I-1)+1
36113 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
36114 370 CONTINUE
36115 DO 380 I=1,NEP
36116 KFL(I)=IABS(K(IEP(I),2))
36117 380 CONTINUE
36118 ITRY(INUM)=ITRY(INUM)+1
36119 IF(ITRY(INUM).GT.200) THEN
36120 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
36121 IF(MSTU(21).GE.1) RETURN
36122 ENDIF
36123 Z=0.5D0
36124 IF(KFL(1).GT.40) GOTO 430
36125 IF(KSH(KFL(1)).EQ.0) GOTO 430
36126 IFL=KFL(1)
36127 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
36128 &ISIGN(2,K(IEP(1),2))
36129 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
36130
36131C...Select side for interference with initial state partons.
36132 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
36133 III=IEP(1)-NS-1
36134 ISII(III)=0
36135 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
36136 ISII(III)=1
36137 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
36138 IF(PYR(0).GT.0.5D0) ISII(III)=1
36139 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
36140 ISII(III)=1
36141 IF(PYR(0).GT.0.5D0) ISII(III)=2
36142 ENDIF
36143 ENDIF
36144
36145C...Calculate allowed z range.
36146 IF(NEP.EQ.1) THEN
36147 PMED=PS(4)
36148 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36149 PMED=P(IM,5)
36150 ELSE
36151 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
36152 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
36153 ENDIF
36154 IF(MOD(MSTJ(43),2).EQ.1) THEN
36155 ZC=PMTH(2,21)/PMED
36156 ZCE=PMTH(2,22)/PMED
36157 ELSE
36158 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
36159 IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2
36160 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,22)/PMED)**2)))
36161 IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2
36162 ENDIF
36163 ZC=MIN(ZC,0.491D0)
36164 ZCE=MIN(ZCE,0.491D0)
36165 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
36166 &MIN(ZC,ZCE).GT.0.49D0)) THEN
36167 P(IEP(1),5)=PMTH(1,IFL)
36168 V(IEP(1),5)=P(IEP(1),5)**2
36169 GOTO 430
36170 ENDIF
36171
36172C...Integral of Altarelli-Parisi z kernel for QCD.
36173 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
36174 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*(0.5D0-ZC)
36175 ELSEIF(MSTJ(49).EQ.0) THEN
36176 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
36177
36178C...Integral of Altarelli-Parisi z kernel for scalar gluon.
36179 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
36180 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
36181 ELSEIF(MSTJ(49).EQ.1) THEN
36182 FBR=(1D0-2D0*ZC)/3D0
36183 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
36184
36185C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
36186 ELSEIF(KFL(1).EQ.21) THEN
36187 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
36188 ELSE
36189 FBR=2D0*LOG((1D0-ZC)/ZC)
36190 ENDIF
36191
36192C...Reset QCD probability for lepton.
36193 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
36194
36195C...Integral of Altarelli-Parisi kernel for photon emission.
36196 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36197 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
36198 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
36199 ENDIF
36200
36201C...Inner veto algorithm starts. Find maximum mass for evolution.
36202 390 PMS=V(IEP(1),5)
36203 IF(IGM.GE.0) THEN
36204 PM2=0D0
36205 DO 400 I=2,NEP
36206 PM=P(IEP(I),5)
36207 IF(KFL(I).LE.40) THEN
36208 IFLI=KFL(I)
36209 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
36210 & ISIGN(2,K(IEP(I),2))
36211 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
36212 ENDIF
36213 PM2=PM2+PM
36214 400 CONTINUE
36215 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
36216 ENDIF
36217
36218C...Select mass for daughter in QCD evolution.
36219 B0=27D0/6D0
36220 DO 410 IFF=4,MSTJ(45)
36221 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
36222 410 CONTINUE
36223 IF(FBR.LT.1D-3) THEN
36224 PMSQCD=0D0
36225 ELSEIF(MSTJ(44).LE.0) THEN
36226 PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
36227 ELSEIF(MSTJ(44).EQ.1) THEN
36228 PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
36229 ELSE
36230 PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
36231 ENDIF
36232 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
36233 V(IEP(1),5)=PMSQCD
36234 MCE=1
36235
36236C...Select mass for daughter in QED evolution.
36237 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36238 PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
36239 IF(ZCE.GT.0.49D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
36240 & PMTH(2,IFL)**2
36241 IF(PMSQED.GT.PMSQCD) THEN
36242 V(IEP(1),5)=PMSQED
36243 MCE=2
36244 ENDIF
36245 ENDIF
36246
36247C...Check whether daughter mass below cutoff.
36248 P(IEP(1),5)=SQRT(V(IEP(1),5))
36249 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
36250 P(IEP(1),5)=PMTH(1,IFL)
36251 V(IEP(1),5)=P(IEP(1),5)**2
36252 GOTO 430
36253 ENDIF
36254
36255C...Select z value of branching: q -> qgamma.
36256 IF(MCE.EQ.2) THEN
36257 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
36258 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36259 K(IEP(1),5)=22
36260
36261C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
36262 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
36263 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36264 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36265 K(IEP(1),5)=21
36266 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN
36267 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36268 IF(PYR(0).GT.0.5D0) Z=1D0-Z
36269 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
36270 K(IEP(1),5)=21
36271 ELSEIF(MSTJ(49).NE.1) THEN
36272 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36273 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
36274 KFLB=1+INT(MSTJ(45)*PYR(0))
36275 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36276 IF(PMQ.GE.1D0) GOTO 390
36277 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
36278 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.
36279 & PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
36280 K(IEP(1),5)=KFLB
36281
36282C...Ditto for scalar gluon model.
36283 ELSEIF(KFL(1).NE.21) THEN
36284 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
36285 K(IEP(1),5)=21
36286 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
36287 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36288 K(IEP(1),5)=21
36289 ELSE
36290 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36291 KFLB=1+INT(MSTJ(45)*PYR(0))
36292 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36293 IF(PMQ.GE.1D0) GOTO 390
36294 K(IEP(1),5)=KFLB
36295 ENDIF
36296 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
36297 IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
36298 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
36299 ENDIF
36300
36301C...Check if z consistent with chosen m.
36302 IF(KFL(1).EQ.21) THEN
36303 KFLGD1=IABS(K(IEP(1),5))
36304 KFLGD2=KFLGD1
36305 ELSE
36306 KFLGD1=KFL(1)
36307 KFLGD2=IABS(K(IEP(1),5))
36308 ENDIF
36309 IF(NEP.EQ.1) THEN
36310 PED=PS(4)
36311 ELSEIF(NEP.GE.3) THEN
36312 PED=P(IEP(1),4)
36313 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36314 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
36315 ELSE
36316 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
36317 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
36318 ENDIF
36319 IF(MOD(MSTJ(43),2).EQ.1) THEN
36320 IFLGD1=KFLGD1
36321 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
36322 PMQTH3=0.5D0*PARJ(82)
36323 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36324 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
36325 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
36326 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36327 & 4D0*PMQ1*PMQ2)))
36328 ZH=1D0+PMQ1-PMQ2
36329 ELSE
36330 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
36331 ZH=1D0
36332 ENDIF
36333 ZL=0.5D0*(ZH-ZD)
36334 ZU=0.5D0*(ZH+ZD)
36335 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
36336 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
36337 &(1D0-ZU)))
36338 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36339
36340C...Width suppression for q -> q + g.
36341 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
36342 IF(IGM.EQ.0) THEN
36343 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
36344 ELSE
36345 EGLU=PMED*(1D0-Z)
36346 ENDIF
36347 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
36348 IF(MSTJ(40).EQ.1) THEN
36349 IF(CHI.LT.PYR(0)) GOTO 390
36350 ELSEIF(MSTJ(40).EQ.2) THEN
36351 IF(1D0-CHI.LT.PYR(0)) GOTO 390
36352 ENDIF
36353 ENDIF
36354
36355C...Three-jet matrix element correction.
36356 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
36357 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
36358 X2=1D0-V(IEP(1),5)/V(NS+1,5)
36359 X3=(1D0-X1)+(1D0-X2)
36360 IF(MCE.EQ.2) THEN
36361 KI1=K(IPA(INUM),2)
36362 KI2=K(IPA(3-INUM),2)
36363 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
36364 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
36365 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
36366 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
36367 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
36368 ELSEIF(MSTJ(49).NE.1) THEN
36369 WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
36370 & (1D0-X2)/X3*(X2/(2D0-X1))**2
36371 WME=X1**2+X2**2
36372 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2-
36373 & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+
36374 & (1D0-X1)/MAX(1D-7,1D0-X2))
36375 ELSE
36376 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
36377 WME=X3**2
36378 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
36379 & PARJ(171)
36380 ENDIF
36381 IF(WME.LT.PYR(0)*WSHOW) GOTO 390
36382
36383C...Impose angular ordering by rejection of nonordered emission.
36384 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
36385 MAOM=1
36386 ZM=V(IM,1)
36387 IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1)
36388 THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
36389 IAOM=IM
36390 420 IF(K(IAOM,5).EQ.22) THEN
36391 IAOM=K(IAOM,3)
36392 IF(K(IAOM,3).LE.NS) MAOM=0
36393 IF(MAOM.EQ.1) GOTO 420
36394 ENDIF
36395 IF(MAOM.EQ.1) THEN
36396 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
36397 IF(THE2ID.LT.THE2IM) GOTO 390
36398 ENDIF
36399 ENDIF
36400
36401C...Impose user-defined maximum angle at first branching.
36402 IF(MSTJ(48).EQ.1) THEN
36403 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
36404 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
36405 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36406 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
36407 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36408 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36409 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
36410 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36411 IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390
36412 ENDIF
36413 ENDIF
36414
36415C...Impose angular constraint in first branching from interference
36416C...with initial state partons.
36417 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
36418 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
36419 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
36420 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
36421 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
36422 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
36423 ENDIF
36424 ENDIF
36425
36426C...End of inner veto algorithm. Check if only one leg evolved so far.
36427 430 V(IEP(1),1)=Z
36428 ISL(1)=0
36429 ISL(2)=0
36430 IF(NEP.EQ.1) GOTO 460
36431 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
36432 DO 440 I=1,NEP
36433 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
36434 IF(KSH(KFLD(I)).EQ.1) THEN
36435 IFLD=KFLD(I)
36436 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36437 & ISIGN(2,K(N+I,2))
36438 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
36439 ENDIF
36440 ENDIF
36441 440 CONTINUE
36442
36443C...Check if chosen multiplet m1,m2,z1,z2 is physical.
36444 IF(NEP.EQ.3) THEN
36445 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
36446 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
36447 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
36448 PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
36449 & PA1S**2-PA2S**2-PA3S**2)/PA1S
36450 IF(PTS.LE.0D0) GOTO 330
36451 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
36452 DO 450 I1=N+1,N+2
36453 KFLDA=IABS(K(I1,2))
36454 IF(KFLDA.GT.40) GOTO 450
36455 IF(KSH(KFLDA).EQ.0) GOTO 450
36456 IFLDA=KFLDA
36457 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
36458 & ISIGN(2,K(I1,2))
36459 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
36460 IF(KFLDA.EQ.21) THEN
36461 KFLGD1=IABS(K(I1,5))
36462 KFLGD2=KFLGD1
36463 ELSE
36464 KFLGD1=KFLDA
36465 KFLGD2=IABS(K(I1,5))
36466 ENDIF
36467 I2=2*N+3-I1
36468 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36469 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
36470 ELSE
36471 IF(I1.EQ.N+1) ZM=V(IM,1)
36472 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
36473 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
36474 & 4D0*V(N+1,5)*V(N+2,5))
36475 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
36476 ENDIF
36477 IF(MOD(MSTJ(43),2).EQ.1) THEN
36478 PMQTH3=0.5D0*PARJ(82)
36479 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36480 IFLGD1=KFLGD1
36481 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
36482 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
36483 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
36484 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36485 & 4D0*PMQ1*PMQ2)))
36486 ZH=1D0+PMQ1-PMQ2
36487 ELSE
36488 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
36489 ZH=1D0
36490 ENDIF
36491 ZL=0.5D0*(ZH-ZD)
36492 ZU=0.5D0*(ZH+ZD)
36493 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
36494 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
36495 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
36496 & ZL*(1D0-ZU)))
36497 IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36498 450 CONTINUE
36499 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
36500 ISL(3-ISLM)=0
36501 ISLM=3-ISLM
36502 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
36503 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
36504 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
36505 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
36506 IF(ISL(1).EQ.1) ISL(2)=0
36507 IF(ISL(1).EQ.0) ISLM=1
36508 IF(ISL(2).EQ.0) ISLM=2
36509 ENDIF
36510 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
36511 ENDIF
36512 IFLD1=KFLD(1)
36513 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
36514 &ISIGN(2,K(N+1,2))
36515 IFLD2=KFLD(2)
36516 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
36517 &ISIGN(2,K(N+2,2))
36518 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
36519 &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
36520 PMQ1=V(N+1,5)/V(IM,5)
36521 PMQ2=V(N+2,5)/V(IM,5)
36522 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
36523 & 4D0*PMQ1*PMQ2)))
36524 ZH=1D0+PMQ1-PMQ2
36525 ZL=0.5D0*(ZH-ZD)
36526 ZU=0.5D0*(ZH+ZD)
36527 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
36528 ENDIF
36529
36530C...Accepted branch. Construct four-momentum for initial partons.
36531 460 MAZIP=0
36532 MAZIC=0
36533 IF(NEP.EQ.1) THEN
36534 P(N+1,1)=0D0
36535 P(N+1,2)=0D0
36536 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
36537 & P(N+1,5))))
36538 P(N+1,4)=P(IPA(1),4)
36539 V(N+1,2)=P(N+1,4)
36540 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
36541 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
36542 P(N+1,1)=0D0
36543 P(N+1,2)=0D0
36544 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
36545 P(N+1,4)=PED1
36546 P(N+2,1)=0D0
36547 P(N+2,2)=0D0
36548 P(N+2,3)=-P(N+1,3)
36549 P(N+2,4)=P(IM,5)-PED1
36550 V(N+1,2)=P(N+1,4)
36551 V(N+2,2)=P(N+2,4)
36552 ELSEIF(NEP.EQ.3) THEN
36553 P(N+1,1)=0D0
36554 P(N+1,2)=0D0
36555 P(N+1,3)=SQRT(MAX(0D0,PA1S))
36556 P(N+2,1)=SQRT(PTS)
36557 P(N+2,2)=0D0
36558 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
36559 P(N+3,1)=-P(N+2,1)
36560 P(N+3,2)=0D0
36561 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
36562 V(N+1,2)=P(N+1,4)
36563 V(N+2,2)=P(N+2,4)
36564 V(N+3,2)=P(N+3,4)
36565
36566C...Construct transverse momentum for ordinary branching in shower.
36567 ELSE
36568 ZM=V(IM,1)
36569 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
36570 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
36571 IF(PZM.LE.0D0) THEN
36572 PTS=0D0
36573 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
36574 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
36575 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
36576 ELSE
36577 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
36578 ENDIF
36579 PT=SQRT(MAX(0D0,PTS))
36580
36581C...Find coefficient of azimuthal asymmetry due to gluon polarization.
36582 HAZIP=0D0
36583 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
36584 & .AND.IAU.NE.0) THEN
36585 IF(K(IGM,3).NE.0) MAZIP=1
36586 ZAU=V(IGM,1)
36587 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
36588 IF(MAZIP.EQ.0) ZAU=0D0
36589 IF(K(IGM,2).NE.21) THEN
36590 HAZIP=2D0*ZAU/(1D0+ZAU**2)
36591 ELSE
36592 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
36593 ENDIF
36594 IF(K(N+1,2).NE.21) THEN
36595 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
36596 ELSE
36597 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
36598 ENDIF
36599 ENDIF
36600
36601C...Find coefficient of azimuthal asymmetry due to soft gluon
36602C...interference.
36603 HAZIC=0D0
36604 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
36605 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
36606 IF(K(IGM,3).NE.0) MAZIC=N+1
36607 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
36608 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36609 & ZM.GT.0.5D0) MAZIC=N+2
36610 IF(K(IAU,2).EQ.22) MAZIC=0
36611 ZS=ZM
36612 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
36613 ZGM=V(IGM,1)
36614 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
36615 IF(MAZIC.EQ.0) ZGM=1D0
36616 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
36617 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
36618 HAZIC=MIN(0.95D0,HAZIC)
36619 ENDIF
36620 ENDIF
36621
36622C...Construct kinematics for ordinary branching in shower.
36623 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
36624 IF(MOD(MSTJ(43),2).EQ.1) THEN
36625 P(N+1,4)=PEM*V(IM,1)
36626 ELSE
36627 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
36628 & SQRT(PMLS)*ZM)/V(IM,5)
36629 ENDIF
36630 PHI=PARU(2)*PYR(0)
36631 P(N+1,1)=PT*COS(PHI)
36632 P(N+1,2)=PT*SIN(PHI)
36633 IF(PZM.GT.0D0) THEN
36634 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
36635 & 2D0*PEM*P(N+1,4))/PZM
36636 ELSE
36637 P(N+1,3)=0D0
36638 ENDIF
36639 P(N+2,1)=-P(N+1,1)
36640 P(N+2,2)=-P(N+1,2)
36641 P(N+2,3)=PZM-P(N+1,3)
36642 P(N+2,4)=PEM-P(N+1,4)
36643 IF(MSTJ(43).LE.2) THEN
36644 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
36645 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
36646 ENDIF
36647 ENDIF
36648
36649C...Rotate and boost daughters.
36650 IF(IGM.GT.0) THEN
36651 IF(MSTJ(43).LE.2) THEN
36652 BEX=P(IGM,1)/P(IGM,4)
36653 BEY=P(IGM,2)/P(IGM,4)
36654 BEZ=P(IGM,3)/P(IGM,4)
36655 GA=P(IGM,4)/P(IGM,5)
36656 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
36657 & P(IM,4))
36658 ELSE
36659 BEX=0D0
36660 BEY=0D0
36661 BEZ=0D0
36662 GA=1D0
36663 GABEP=0D0
36664 ENDIF
36665 THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
36666 & (P(IM,2)+GABEP*BEY)**2))
36667 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
36668 DO 480 I=N+1,N+2
36669 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
36670 & SIN(THE)*COS(PHI)*P(I,3)
36671 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
36672 & SIN(THE)*SIN(PHI)*P(I,3)
36673 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
36674 DP(4)=P(I,4)
36675 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
36676 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
36677 P(I,1)=DP(1)+DGABP*BEX
36678 P(I,2)=DP(2)+DGABP*BEY
36679 P(I,3)=DP(3)+DGABP*BEZ
36680 P(I,4)=GA*(DP(4)+DBP)
36681 480 CONTINUE
36682 ENDIF
36683
36684C...Weight with azimuthal distribution, if required.
36685 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
36686 DO 490 J=1,3
36687 DPT(1,J)=P(IM,J)
36688 DPT(2,J)=P(IAU,J)
36689 DPT(3,J)=P(N+1,J)
36690 490 CONTINUE
36691 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
36692 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
36693 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
36694 DO 500 J=1,3
36695 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
36696 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
36697 500 CONTINUE
36698 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
36699 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
36700 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
36701 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
36702 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
36703 IF(MAZIP.NE.0) THEN
36704 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
36705 & GOTO 470
36706 ENDIF
36707 IF(MAZIC.NE.0) THEN
36708 IF(MAZIC.EQ.N+2) CAD=-CAD
36709 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
36710 & .LT.PYR(0)) GOTO 470
36711 ENDIF
36712 ENDIF
36713 ENDIF
36714
36715C...Azimuthal anisotropy due to interference with initial state partons.
36716 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
36717 &K(N+2,2).EQ.21)) THEN
36718 III=IM-NS-1
36719 IF(ISII(III).GE.1) THEN
36720 IAZIID=N+1
36721 IF(K(N+1,2).NE.21) IAZIID=N+2
36722 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36723 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
36724 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
36725 IF(III.EQ.2) THEIID=PARU(1)-THEIID
36726 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
36727 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
36728 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
36729 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
36730 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
36731 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
36732 & .LT.PYR(0)) GOTO 470
36733 ENDIF
36734 ENDIF
36735
36736C...Continue loop over partons that may branch, until none left.
36737 IF(IGM.GE.0) K(IM,1)=14
36738 N=N+NEP
36739 NEP=2
36740 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36741 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36742 IF(MSTU(21).GE.1) N=NS
36743 IF(MSTU(21).GE.1) RETURN
36744 ENDIF
36745 GOTO 270
36746
36747C...Set information on imagined shower initiator.
36748 510 IF(NPA.GE.2) THEN
36749 K(NS+1,1)=11
36750 K(NS+1,2)=94
36751 K(NS+1,3)=IP1
36752 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
36753 K(NS+1,4)=NS+2
36754 K(NS+1,5)=NS+1+NPA
36755 IIM=1
36756 ELSE
36757 IIM=0
36758 ENDIF
36759
36760C...Reconstruct string drawing information.
36761 DO 520 I=NS+1+IIM,N
36762 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
36763 K(I,1)=1
36764 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
36765 & IABS(K(I,2)).LE.18) THEN
36766 K(I,1)=1
36767 ELSEIF(K(I,1).LE.10) THEN
36768 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
36769 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
36770 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
36771 ID1=MOD(K(I,4),MSTU(5))
36772 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
36773 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
36774 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36775 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
36776 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36777 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
36778 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
36779 K(ID2,5)=K(ID2,5)+MSTU(5)*I
36780 ELSE
36781 ID1=MOD(K(I,4),MSTU(5))
36782 ID2=ID1+1
36783 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36784 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
36785 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
36786 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36787 K(ID1,5)=K(ID1,5)+MSTU(5)*I
36788 ELSE
36789 K(ID1,4)=0
36790 K(ID1,5)=0
36791 ENDIF
36792 K(ID2,4)=0
36793 K(ID2,5)=0
36794 ENDIF
36795 520 CONTINUE
36796
36797C...Transformation from CM frame.
36798 IF(NPA.GE.2) THEN
36799 BEX=PS(1)/PS(4)
36800 BEY=PS(2)/PS(4)
36801 BEZ=PS(3)/PS(4)
36802 GA=PS(4)/PS(5)
36803 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
36804 & /(1D0+GA)-P(IPA(1),4))
36805 ELSE
36806 BEX=0D0
36807 BEY=0D0
36808 BEZ=0D0
36809 GABEP=0D0
36810 ENDIF
36811 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
36812 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
36813 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
36814 IF(NPA.EQ.3) THEN
36815 CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
36816 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
36817 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
36818 & GABEP*BEY))
36819 MSTU(33)=1
36820 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
36821 ENDIF
36822 MSTU(33)=1
36823 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
36824
36825C...Decay vertex of shower.
36826 DO 540 I=NS+1,N
36827 DO 530 J=1,5
36828 V(I,J)=V(IP1,J)
36829 530 CONTINUE
36830 540 CONTINUE
36831
36832C...Delete trivial shower, else connect initiators.
36833 IF(N.EQ.NS+NPA+IIM) THEN
36834 N=NS
36835 ELSE
36836 DO 550 IP=1,NPA
36837 K(IPA(IP),1)=14
36838 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
36839 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
36840 K(NS+IIM+IP,3)=IPA(IP)
36841 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
36842 IF(K(NS+IIM+IP,1).NE.1) THEN
36843 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
36844 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
36845 ENDIF
36846 550 CONTINUE
36847 ENDIF
36848
36849 RETURN
36850 END
36851
36852C*********************************************************************
36853
36854C...PYBOEI
36855C...Modifies an event so as to approximately take into account
36856C...Bose-Einstein effects according to a simple phenomenological
36857C...parametrization.
36858
36859 SUBROUTINE PYBOEI(NSAV)
36860
36861C...Double precision and integer declarations.
36862 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36863 INTEGER PYK,PYCHGE,PYCOMP
36864C...Commonblocks.
36865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
36866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36867 SAVE /PYJETS/,/PYDAT1/
36868C...Local arrays and data.
36869 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
36870 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
36871
36872C...Boost event to overall CM frame. Calculate CM energy.
36873 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
36874 DO 100 J=1,4
36875 DPS(J)=0D0
36876 100 CONTINUE
36877 DO 120 I=1,N
36878 KFA=IABS(K(I,2))
36879 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
36880 & .AND.K(I,3).GT.0) THEN
36881 KFMA=IABS(K(K(I,3),2))
36882 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
36883 ENDIF
36884 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
36885 DO 110 J=1,4
36886 DPS(J)=DPS(J)+P(I,J)
36887 110 CONTINUE
36888 120 CONTINUE
36889 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
36890 &-DPS(3)/DPS(4))
36891 PECM=0D0
36892 DO 130 I=1,N
36893 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
36894 130 CONTINUE
36895
36896C...Reserve copy of particles by species at end of record.
36897 NBE(0)=N+MSTU(3)
36898 DO 160 IBE=1,MIN(9,MSTJ(52))
36899 NBE(IBE)=NBE(IBE-1)
36900 DO 150 I=NSAV+1,N
36901 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
36902 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
36903 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
36904 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
36905 RETURN
36906 ENDIF
36907 NBE(IBE)=NBE(IBE)+1
36908 K(NBE(IBE),1)=I
36909 DO 140 J=1,3
36910 P(NBE(IBE),J)=0D0
36911 140 CONTINUE
36912 150 CONTINUE
36913 160 CONTINUE
36914 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
36915
36916C...Tabulate integral for subsequent momentum shift.
36917 DO 220 IBE=1,MIN(9,MSTJ(52))
36918 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
36919 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
36920 & .LE.1) GOTO 180
36921 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
36922 & NBE(7)-NBE(6)).LE.1) GOTO 180
36923 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
36924 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
36925 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
36926 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
36927 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
36928 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
36929 IF(MSTJ(51).EQ.1) THEN
36930 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
36931 BEEX=EXP(0.5D0*QDEL/PARJ(93))
36932 BERT=EXP(-QDEL/PARJ(93))
36933 ELSE
36934 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
36935 ENDIF
36936 DO 170 IBIN=1,NBIN
36937 QBIN=QDEL*(IBIN-0.5D0)
36938 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
36939 IF(MSTJ(51).EQ.1) THEN
36940 BEEX=BEEX*BERT
36941 BEI(IBIN)=BEI(IBIN)*BEEX
36942 ELSE
36943 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
36944 ENDIF
36945 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
36946 170 CONTINUE
36947
36948C...Loop through particle pairs and find old relative momentum.
36949 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
36950 I1=K(I1M,1)
36951 DO 200 I2M=I1M+1,NBE(IBE)
36952 I2=K(I2M,1)
36953 Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
36954 & (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
36955 & (P(I1,5)+P(I2,5))**2)
36956 QOLD=SQRT(Q2OLD)
36957
36958C...Calculate new relative momentum.
36959 IF(QOLD.LT.1D-3*QDEL) THEN
36960 GOTO 200
36961 ELSEIF(QOLD.LE.QDEL) THEN
36962 QMOV=QOLD/3D0
36963 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
36964 RBIN=QOLD/QDEL
36965 IBIN=RBIN
36966 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
36967 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
36968 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
36969 ELSE
36970 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
36971 ENDIF
36972 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
36973
36974C...Calculate and save shift to be performed on three-momenta.
36975 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
36976 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
36977 HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
36978 DO 190 J=1,3
36979 PD=HA*(P(I2,J)-P(I1,J))
36980 P(I1M,J)=P(I1M,J)+PD
36981 P(I2M,J)=P(I2M,J)-PD
36982 190 CONTINUE
36983 200 CONTINUE
36984 210 CONTINUE
36985 220 CONTINUE
36986
36987C...Shift momenta and recalculate energies.
36988 DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
36989 I=K(IM,1)
36990 DO 230 J=1,3
36991 P(I,J)=P(I,J)+P(IM,J)
36992 230 CONTINUE
36993 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
36994 240 CONTINUE
36995
36996C...Rescale all momenta for energy conservation.
36997 PES=0D0
36998 PQS=0D0
36999 DO 250 I=1,N
37000 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
37001 PES=PES+P(I,4)
37002 PQS=PQS+P(I,5)**2/P(I,4)
37003 250 CONTINUE
37004 FAC=(PECM-PQS)/(PES-PQS)
37005 DO 270 I=1,N
37006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
37007 DO 260 J=1,3
37008 P(I,J)=FAC*P(I,J)
37009 260 CONTINUE
37010 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37011 270 CONTINUE
37012
37013C...Boost back to correct reference frame.
37014 280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
37015 DO 290 I=1,N
37016 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
37017 290 CONTINUE
37018
37019 RETURN
37020 END
37021
37022C*********************************************************************
37023
37024C...PYMASS
37025C...Gives the mass of a particle/parton.
37026
37027 FUNCTION PYMASS(KF)
37028
37029C...Double precision and integer declarations.
37030 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37031 INTEGER PYK,PYCHGE,PYCOMP
37032C...Commonblocks.
37033 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37034 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37035 SAVE /PYDAT1/,/PYDAT2/
37036
37037C...Reset variables. Compressed code. Special case for popcorn diquarks.
37038 PYMASS=0D0
37039 KFA=IABS(KF)
37040 KC=PYCOMP(KF)
37041 IF(KC.EQ.0) THEN
37042 MSTJ(93)=0
37043 RETURN
37044 ENDIF
37045
37046C...Guarantee use of constituent masses for internal checks.
37047 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
37048 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
37049 PARF(106)=PMAS(6,1)
37050 PARF(107)=PMAS(7,1)
37051 PARF(108)=PMAS(8,1)
37052 IF(KFA.LE.10) THEN
37053 PYMASS=PARF(100+KFA)
37054 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
37055 ELSEIF(MSTJ(93).EQ.1) THEN
37056 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
37057 ELSE
37058 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
37059 ENDIF
37060
37061C...Other masses can be read directly off table.
37062 ELSE
37063 PYMASS=PMAS(KC,1)
37064 ENDIF
37065
37066C...Optional mass broadening according to truncated Breit-Wigner
37067C...(either in m or in m^2).
37068 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
37069 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
37070 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
37071 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
37072 ELSE
37073 PM0=PYMASS
37074 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
37075 & (PM0*PMAS(KC,2)))
37076 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
37077 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
37078 & (PMUPP-PMLOW)*PYR(0))))
37079 ENDIF
37080 ENDIF
37081 MSTJ(93)=0
37082
37083 RETURN
37084 END
37085
37086C*********************************************************************
37087
37088C...PYNAME
37089C...Gives the particle/parton name as a character string.
37090
37091 SUBROUTINE PYNAME(KF,CHAU)
37092
37093C...Double precision and integer declarations.
37094 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37095 INTEGER PYK,PYCHGE,PYCOMP
37096C...Commonblocks.
37097 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37098 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37099 COMMON/PYDAT4/CHAF(500,2)
37100 CHARACTER CHAF*16
37101 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
37102C...Local character variable.
37103 CHARACTER CHAU*16
37104
37105C...Read out code with distinction particle/antiparticle.
37106 CHAU=' '
37107 KC=PYCOMP(KF)
37108 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
37109
37110
37111 RETURN
37112 END
37113
37114C*********************************************************************
37115
37116C...PYCHGE
37117C...Gives three times the charge for a particle/parton.
37118
37119 FUNCTION PYCHGE(KF)
37120
37121C...Double precision and integer declarations.
37122 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37123 INTEGER PYK,PYCHGE,PYCOMP
37124C...Commonblocks.
37125 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37126 SAVE /PYDAT2/
37127
37128C...Read out charge and change sign for antiparticle.
37129 PYCHGE=0
37130 KC=PYCOMP(KF)
37131 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
37132
37133 RETURN
37134 END
37135
37136C*********************************************************************
37137
37138C...PYCOMP
37139C...Compress the standard KF codes for use in mass and decay arrays;
37140C...also checks whether a given code actually is defined.
37141
37142 FUNCTION PYCOMP(KF)
37143
37144C...Double precision and integer declarations.
37145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37146 INTEGER PYK,PYCHGE,PYCOMP
37147C...Commonblocks.
37148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37149 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37150 SAVE /PYDAT1/,/PYDAT2/
37151C...Local arrays and saved data.
37152 DIMENSION KFORD(100:500),KCORD(101:500)
37153 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
37154
37155C...Whenever necessary reorder codes for faster search.
37156 IF(MSTU(20).EQ.0) THEN
37157 NFORD=100
37158 KFORD(100)=0
37159 DO 120 I=101,500
37160 KFA=KCHG(I,4)
37161 IF(KFA.LE.100) GOTO 120
37162 NFORD=NFORD+1
37163 DO 100 I1=NFORD-1,0,-1
37164 IF(KFA.GE.KFORD(I1)) GOTO 110
37165 KFORD(I1+1)=KFORD(I1)
37166 KCORD(I1+1)=KCORD(I1)
37167 100 CONTINUE
37168 110 KFORD(I1+1)=KFA
37169 KCORD(I1+1)=I
37170 120 CONTINUE
37171 MSTU(20)=1
37172 KFLAST=0
37173 KCLAST=0
37174 ENDIF
37175
37176C...Fast action if same code as in latest call.
37177 IF(KF.EQ.KFLAST) THEN
37178 PYCOMP=KCLAST
37179 RETURN
37180 ENDIF
37181
37182C...Starting values. Remove internal diquark flags.
37183 PYCOMP=0
37184 KFA=IABS(KF)
37185 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
37186 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
37187
37188C...Simple cases: direct translation.
37189 IF(KFA.GT.KFORD(NFORD)) THEN
37190 ELSEIF(KFA.LE.100) THEN
37191 PYCOMP=KFA
37192
37193C...Else binary search.
37194 ELSE
37195 IMIN=100
37196 IMAX=NFORD+1
37197 130 IAVG=(IMIN+IMAX)/2
37198 IF(KFORD(IAVG).GT.KFA) THEN
37199 IMAX=IAVG
37200 IF(IMAX.GT.IMIN+1) GOTO 130
37201 ELSEIF(KFORD(IAVG).LT.KFA) THEN
37202 IMIN=IAVG
37203 IF(IMAX.GT.IMIN+1) GOTO 130
37204 ELSE
37205 PYCOMP=KCORD(IAVG)
37206 ENDIF
37207 ENDIF
37208
37209C...Check if antiparticle allowed.
37210 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
37211 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
37212 ENDIF
37213
37214C...Save codes for possible future fast action.
37215 KFLAST=KF
37216 KCLAST=PYCOMP
37217
37218 RETURN
37219 END
37220
37221C*********************************************************************
37222
37223C...PYERRM
37224C...Informs user of errors in program execution.
37225
37226 SUBROUTINE PYERRM(MERR,CHMESS)
37227
37228C...Double precision and integer declarations.
37229 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37230 INTEGER PYK,PYCHGE,PYCOMP
37231C...Commonblocks.
37232 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37233 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37234 SAVE /PYJETS/,/PYDAT1/
37235C...Local character variable.
37236 CHARACTER CHMESS*(*)
37237
37238C...Write first few warnings, then be silent.
37239 IF(MERR.LE.10) THEN
37240 MSTU(27)=MSTU(27)+1
37241 MSTU(28)=MERR
37242 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
37243 & MERR,MSTU(31),CHMESS
37244
37245C...Write first few errors, then be silent or stop program.
37246 ELSEIF(MERR.LE.20) THEN
37247 MSTU(23)=MSTU(23)+1
37248 MSTU(24)=MERR-10
37249 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
37250 & MERR-10,MSTU(31),CHMESS
37251 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
37252 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
37253 WRITE(MSTU(11),5200)
37254 IF(MERR.NE.17) CALL PYLIST(2)
37255 STOP
37256 ENDIF
37257
37258C...Stop program in case of irreparable error.
37259 ELSE
37260 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
37261 STOP
37262 ENDIF
37263
37264C...Formats for output.
37265 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
37266 &' PYEXEC calls:'/5X,A)
37267 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
37268 &' PYEXEC calls:'/5X,A)
37269 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
37270 &'event!')
37271 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
37272 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
37273
37274 RETURN
37275 END
37276
37277C*********************************************************************
37278
37279C...PYALEM
37280C...Calculates the running alpha_electromagnetic.
37281
37282 FUNCTION PYALEM(Q2)
37283
37284C...Double precision and integer declarations.
37285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37286 INTEGER PYK,PYCHGE,PYCOMP
37287C...Commonblocks.
37288 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37289 SAVE /PYDAT1/
37290
37291C...Calculate real part of photon vacuum polarization.
37292C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
37293C...For hadrons use parametrization of H. Burkhardt et al.
37294C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
37295 AEMPI=PARU(101)/(3D0*PARU(1))
37296 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
37297 RPIGG=0D0
37298 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
37299 RPIGG=0D0
37300 ELSEIF(MSTU(101).EQ.2) THEN
37301 RPIGG=1D0-PARU(101)/PARU(103)
37302 ELSEIF(Q2.LT.0.09D0) THEN
37303 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
37304 ELSEIF(Q2.LT.9D0) THEN
37305 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
37306 & 0.00238D0*LOG(1D0+3.927D0*Q2)
37307 ELSEIF(Q2.LT.1D4) THEN
37308 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
37309 & 0.00299D0*LOG(1D0+Q2)
37310 ELSE
37311 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
37312 & 0.00293D0*LOG(1D0+Q2)
37313 ENDIF
37314
37315C...Calculate running alpha_em.
37316 PYALEM=PARU(101)/(1D0-RPIGG)
37317 PARU(108)=PYALEM
37318
37319 RETURN
37320 END
37321
37322C*********************************************************************
37323
37324C...PYALPS
37325C...Gives the value of alpha_strong.
37326
37327 FUNCTION PYALPS(Q2)
37328
37329C...Double precision and integer declarations.
37330 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37331 INTEGER PYK,PYCHGE,PYCOMP
37332C...Commonblocks.
37333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37335 SAVE /PYDAT1/,/PYDAT2/
37336
37337C...Constant alpha_strong trivial. Pick artificial Lambda.
37338 IF(MSTU(111).LE.0) THEN
37339 PYALPS=PARU(111)
37340 MSTU(118)=MSTU(112)
37341 PARU(117)=0.2D0
37342 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
37343 & ((33D0-2D0*MSTU(112))*PARU(111)))
37344 PARU(118)=PARU(111)
37345 RETURN
37346 ENDIF
37347
37348C...Find effective Q2, number of flavours and Lambda.
37349 Q2EFF=Q2
37350 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
37351 NF=MSTU(112)
37352 ALAM2=PARU(112)**2
37353 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
37354 Q2THR=PARU(113)*PMAS(NF,1)**2
37355 IF(Q2EFF.LT.Q2THR) THEN
37356 NF=NF-1
37357 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
37358 GOTO 100
37359 ENDIF
37360 ENDIF
37361 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
37362 Q2THR=PARU(113)*PMAS(NF+1,1)**2
37363 IF(Q2EFF.GT.Q2THR) THEN
37364 NF=NF+1
37365 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
37366 GOTO 110
37367 ENDIF
37368 ENDIF
37369 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
37370 PARU(117)=SQRT(ALAM2)
37371
37372C...Evaluate first or second order alpha_strong.
37373 B0=(33D0-2D0*NF)/6D0
37374 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
37375 IF(MSTU(111).EQ.1) THEN
37376 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
37377 ELSE
37378 B1=(153D0-19D0*NF)/6D0
37379 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
37380 & (B0**2*ALGQ)))
37381 ENDIF
37382 MSTU(118)=NF
37383 PARU(118)=PYALPS
37384
37385 RETURN
37386 END
37387
37388C*********************************************************************
37389
37390C...PYANGL
37391C...Reconstructs an angle from given x and y coordinates.
37392
37393 FUNCTION PYANGL(X,Y)
37394
37395C...Double precision and integer declarations.
37396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37397 INTEGER PYK,PYCHGE,PYCOMP
37398C...Commonblocks.
37399 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37400 SAVE /PYDAT1/
37401
37402 PYANGL=0D0
37403 R=SQRT(X**2+Y**2)
37404 IF(R.LT.1D-20) RETURN
37405 IF(ABS(X)/R.LT.0.8D0) THEN
37406 PYANGL=SIGN(ACOS(X/R),Y)
37407 ELSE
37408 PYANGL=ASIN(Y/R)
37409 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
37410 PYANGL=PARU(1)-PYANGL
37411 ELSEIF(X.LT.0D0) THEN
37412 PYANGL=-PARU(1)-PYANGL
37413 ENDIF
37414 ENDIF
37415
37416 RETURN
37417 END
37418
37419C*********************************************************************
37420
37421C...PYR
37422C...Generates random numbers uniformly distributed between
37423C...0 and 1, excluding the endpoints.
37424
37425**sr renamed for use of internal dpmjet3 random number generator
37426 FUNCTION XPYR(IDUMMY)
37427**
37428
37429C...Double precision and integer declarations.
37430 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37431 INTEGER PYK,PYCHGE,PYCOMP
37432C...Commonblocks.
37433 COMMON/PYDATR/MRPY(6),RRPY(100)
37434 SAVE /PYDATR/
37435C...Equivalence between commonblock and local variables.
37436 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
37437 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
37438 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
37439
37440C...Initialize generation from given seed.
37441 IF(MRPY2.EQ.0) THEN
37442 IJ=MOD(MRPY1/30082,31329)
37443 KL=MOD(MRPY1,30082)
37444 I=MOD(IJ/177,177)+2
37445 J=MOD(IJ,177)+2
37446 K=MOD(KL/169,178)+1
37447 L=MOD(KL,169)
37448 DO 110 II=1,97
37449 S=0D0
37450 T=0.5D0
37451 DO 100 JJ=1,48
37452 M=MOD(MOD(I*J,179)*K,179)
37453 I=J
37454 J=K
37455 K=M
37456 L=MOD(53*L+1,169)
37457 IF(MOD(L*M,64).GE.32) S=S+T
37458 T=0.5D0*T
37459 100 CONTINUE
37460 RRPY(II)=S
37461 110 CONTINUE
37462 TWOM24=1D0
37463 DO 120 I24=1,24
37464 TWOM24=0.5D0*TWOM24
37465 120 CONTINUE
37466 RRPY98=362436D0*TWOM24
37467 RRPY99=7654321D0*TWOM24
37468 RRPY00=16777213D0*TWOM24
37469 MRPY2=1
37470 MRPY3=0
37471 MRPY4=97
37472 MRPY5=33
37473 ENDIF
37474
37475C...Generate next random number.
37476 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
37477 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37478 RRPY(MRPY4)=RUNI
37479 MRPY4=MRPY4-1
37480 IF(MRPY4.EQ.0) MRPY4=97
37481 MRPY5=MRPY5-1
37482 IF(MRPY5.EQ.0) MRPY5=97
37483 RRPY98=RRPY98-RRPY99
37484 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
37485 RUNI=RUNI-RRPY98
37486 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37487 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
37488
37489C...Update counters. Random number to output.
37490 MRPY3=MRPY3+1
37491 IF(MRPY3.EQ.1000000000) THEN
37492 MRPY2=MRPY2+1
37493 MRPY3=0
37494 ENDIF
37495 PYR=RUNI
37496
37497 RETURN
37498 END
37499
37500C*********************************************************************
37501
37502C...PYRGET
37503C...Dumps the state of the random number generator on a file
37504C...for subsequent startup from this state onwards.
37505
37506 SUBROUTINE PYRGET(LFN,MOVE)
37507
37508C...Double precision and integer declarations.
37509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37510 INTEGER PYK,PYCHGE,PYCOMP
37511C...Commonblocks.
37512 COMMON/PYDATR/MRPY(6),RRPY(100)
37513 SAVE /PYDATR/
37514C...Local character variable.
37515 CHARACTER CHERR*8
37516
37517C...Backspace required number of records (or as many as there are).
37518 IF(MOVE.LT.0) THEN
37519 NBCK=MIN(MRPY(6),-MOVE)
37520 DO 100 IBCK=1,NBCK
37521 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
37522 100 CONTINUE
37523 MRPY(6)=MRPY(6)-NBCK
37524 ENDIF
37525
37526C...Unformatted write on unit LFN.
37527 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37528 &(RRPY(I2),I2=1,100)
37529 MRPY(6)=MRPY(6)+1
37530 RETURN
37531
37532C...Write error.
37533 110 WRITE(CHERR,'(I8)') IERR
37534 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
37535 &CHERR)
37536
37537 RETURN
37538 END
37539
37540C*********************************************************************
37541
37542C...PYRSET
37543C...Reads a state of the random number generator from a file
37544C...for subsequent generation from this state onwards.
37545
37546 SUBROUTINE PYRSET(LFN,MOVE)
37547
37548C...Double precision and integer declarations.
37549 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37550 INTEGER PYK,PYCHGE,PYCOMP
37551C...Commonblocks.
37552 COMMON/PYDATR/MRPY(6),RRPY(100)
37553 SAVE /PYDATR/
37554C...Local character variable.
37555 CHARACTER CHERR*8
37556
37557C...Backspace required number of records (or as many as there are).
37558 IF(MOVE.LT.0) THEN
37559 NBCK=MIN(MRPY(6),-MOVE)
37560 DO 100 IBCK=1,NBCK
37561 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
37562 100 CONTINUE
37563 MRPY(6)=MRPY(6)-NBCK
37564 ENDIF
37565
37566C...Unformatted read from unit LFN.
37567 NFOR=1+MAX(0,MOVE)
37568 DO 110 IFOR=1,NFOR
37569 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37570 & (RRPY(I2),I2=1,100)
37571 110 CONTINUE
37572 MRPY(6)=MRPY(6)+NFOR
37573 RETURN
37574
37575C...Write error.
37576 120 WRITE(CHERR,'(I8)') IERR
37577 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
37578 &CHERR)
37579
37580 RETURN
37581 END
37582
37583C*********************************************************************
37584
37585C...PYROBO
37586C...Performs rotations and boosts.
37587
37588 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
37589
37590C...Double precision and integer declarations.
37591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37592 INTEGER PYK,PYCHGE,PYCOMP
37593C...Commonblocks.
37594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37596 SAVE /PYJETS/,/PYDAT1/
37597C...Local arrays.
37598 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
37599
37600C...Find and check range of rotation/boost.
37601 IMIN=IMI
37602 IF(IMIN.LE.0) IMIN=1
37603 IF(MSTU(1).GT.0) IMIN=MSTU(1)
37604 IMAX=IMA
37605 IF(IMAX.LE.0) IMAX=N
37606 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37607 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
37608 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
37609 RETURN
37610 ENDIF
37611
37612C...Optional resetting of V (when not set before.)
37613 IF(MSTU(33).NE.0) THEN
37614 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
37615 DO 100 J=1,5
37616 V(I,J)=0D0
37617 100 CONTINUE
37618 110 CONTINUE
37619 MSTU(33)=0
37620 ENDIF
37621
37622C...Rotate, typically from z axis to direction (theta,phi).
37623 IF(THE**2+PHI**2.GT.1D-20) THEN
37624 ROT(1,1)=COS(THE)*COS(PHI)
37625 ROT(1,2)=-SIN(PHI)
37626 ROT(1,3)=SIN(THE)*COS(PHI)
37627 ROT(2,1)=COS(THE)*SIN(PHI)
37628 ROT(2,2)=COS(PHI)
37629 ROT(2,3)=SIN(THE)*SIN(PHI)
37630 ROT(3,1)=-SIN(THE)
37631 ROT(3,2)=0D0
37632 ROT(3,3)=COS(THE)
37633 DO 140 I=IMIN,IMAX
37634 IF(K(I,1).LE.0) GOTO 140
37635 DO 120 J=1,3
37636 PR(J)=P(I,J)
37637 VR(J)=V(I,J)
37638 120 CONTINUE
37639 DO 130 J=1,3
37640 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
37641 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
37642 130 CONTINUE
37643 140 CONTINUE
37644 ENDIF
37645
37646C...Boost, typically from rest to momentum/energy=beta.
37647 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
37648 DBX=BEX
37649 DBY=BEY
37650 DBZ=BEZ
37651 DB=SQRT(DBX**2+DBY**2+DBZ**2)
37652 EPS1=1D0-1D-12
37653 IF(DB.GT.EPS1) THEN
37654C...Rescale boost vector if too close to unity.
37655 CALL PYERRM(3,'(PYROBO:) boost vector too large')
37656 DBX=DBX*(EPS1/DB)
37657 DBY=DBY*(EPS1/DB)
37658 DBZ=DBZ*(EPS1/DB)
37659 DB=EPS1
37660 ENDIF
37661 DGA=1D0/SQRT(1D0-DB**2)
37662 DO 160 I=IMIN,IMAX
37663 IF(K(I,1).LE.0) GOTO 160
37664 DO 150 J=1,4
37665 DP(J)=P(I,J)
37666 DV(J)=V(I,J)
37667 150 CONTINUE
37668 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
37669 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
37670 P(I,1)=DP(1)+DGABP*DBX
37671 P(I,2)=DP(2)+DGABP*DBY
37672 P(I,3)=DP(3)+DGABP*DBZ
37673 P(I,4)=DGA*(DP(4)+DBP)
37674 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
37675 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
37676 V(I,1)=DV(1)+DGABV*DBX
37677 V(I,2)=DV(2)+DGABV*DBY
37678 V(I,3)=DV(3)+DGABV*DBZ
37679 V(I,4)=DGA*(DV(4)+DBV)
37680 160 CONTINUE
37681 ENDIF
37682
37683 RETURN
37684 END
37685
37686C*********************************************************************
37687
37688C...PYEDIT
37689C...Performs global manipulations on the event record, in particular
37690C...to exclude unstable or undetectable partons/particles.
37691
37692 SUBROUTINE PYEDIT(MEDIT)
37693
37694C...Double precision and integer declarations.
37695 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37696 INTEGER PYK,PYCHGE,PYCOMP
37697C...Commonblocks.
37698 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37699 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37700 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37701 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37702C...Local arrays.
37703 DIMENSION NS(2),PTS(2),PLS(2)
37704
37705C...Remove unwanted partons/particles.
37706 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
37707 IMAX=N
37708 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37709 I1=MAX(1,MSTU(1))-1
37710 DO 110 I=MAX(1,MSTU(1)),IMAX
37711 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
37712 IF(MEDIT.EQ.1) THEN
37713 IF(K(I,1).GT.10) GOTO 110
37714 ELSEIF(MEDIT.EQ.2) THEN
37715 IF(K(I,1).GT.10) GOTO 110
37716 KC=PYCOMP(K(I,2))
37717 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
37718 & GOTO 110
37719 ELSEIF(MEDIT.EQ.3) THEN
37720 IF(K(I,1).GT.10) GOTO 110
37721 KC=PYCOMP(K(I,2))
37722 IF(KC.EQ.0) GOTO 110
37723 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
37724 ELSEIF(MEDIT.EQ.5) THEN
37725 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
37726 KC=PYCOMP(K(I,2))
37727 IF(KC.EQ.0) GOTO 110
37728 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
37729 ENDIF
37730
37731C...Pack remaining partons/particles. Origin no longer known.
37732 I1=I1+1
37733 DO 100 J=1,5
37734 K(I1,J)=K(I,J)
37735 P(I1,J)=P(I,J)
37736 V(I1,J)=V(I,J)
37737 100 CONTINUE
37738 K(I1,3)=0
37739 110 CONTINUE
37740 IF(I1.LT.N) MSTU(3)=0
37741 IF(I1.LT.N) MSTU(70)=0
37742 N=I1
37743
37744C...Selective removal of class of entries. New position of retained.
37745 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
37746 I1=0
37747 DO 120 I=1,N
37748 K(I,3)=MOD(K(I,3),MSTU(5))
37749 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
37750 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
37751 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
37752 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
37753 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
37754 & K(I,2).EQ.94)) GOTO 120
37755 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
37756 I1=I1+1
37757 K(I,3)=K(I,3)+MSTU(5)*I1
37758 120 CONTINUE
37759
37760C...Find new event history information and replace old.
37761 DO 140 I=1,N
37762 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
37763 & GOTO 140
37764 ID=I
37765 130 IM=MOD(K(ID,3),MSTU(5))
37766 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
37767 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
37768 & K(IM,2).NE.94) THEN
37769 ID=IM
37770 GOTO 130
37771 ENDIF
37772 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
37773 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
37774 ID=IM
37775 GOTO 130
37776 ENDIF
37777 ENDIF
37778 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
37779 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
37780 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
37781 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
37782 & K(K(I,4),3)/MSTU(5)
37783 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
37784 & K(K(I,5),3)/MSTU(5)
37785 ELSE
37786 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
37787 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
37788 KCD=MOD(K(I,4),MSTU(5))
37789 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
37790 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
37791 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
37792 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
37793 KCD=MOD(K(I,5),MSTU(5))
37794 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
37795 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
37796 ENDIF
37797 140 CONTINUE
37798
37799C...Pack remaining entries.
37800 I1=0
37801 MSTU90=MSTU(90)
37802 MSTU(90)=0
37803 DO 170 I=1,N
37804 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
37805 I1=I1+1
37806 DO 150 J=1,5
37807 K(I1,J)=K(I,J)
37808 P(I1,J)=P(I,J)
37809 V(I1,J)=V(I,J)
37810 150 CONTINUE
37811 K(I1,3)=MOD(K(I1,3),MSTU(5))
37812 DO 160 IZ=1,MSTU90
37813 IF(I.EQ.MSTU(90+IZ)) THEN
37814 MSTU(90)=MSTU(90)+1
37815 MSTU(90+MSTU(90))=I1
37816 PARU(90+MSTU(90))=PARU(90+IZ)
37817 ENDIF
37818 160 CONTINUE
37819 170 CONTINUE
37820 IF(I1.LT.N) MSTU(3)=0
37821 IF(I1.LT.N) MSTU(70)=0
37822 N=I1
37823
37824C...Fill in some missing daughter pointers (lost in colour flow).
37825 ELSEIF(MEDIT.EQ.16) THEN
37826 DO 220 I=1,N
37827 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
37828 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
37829C...Find daughters who point to mother.
37830 DO 180 I1=I+1,N
37831 IF(K(I1,3).NE.I) THEN
37832 ELSEIF(K(I,4).EQ.0) THEN
37833 K(I,4)=I1
37834 ELSE
37835 K(I,5)=I1
37836 ENDIF
37837 180 CONTINUE
37838 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
37839 IF(K(I,4).NE.0) GOTO 220
37840C...Find daughters who point to documentation version of mother.
37841 IM=K(I,3)
37842 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
37843 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
37844 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
37845 DO 190 I1=I+1,N
37846 IF(K(I1,3).NE.IM) THEN
37847 ELSEIF(K(I,4).EQ.0) THEN
37848 K(I,4)=I1
37849 ELSE
37850 K(I,5)=I1
37851 ENDIF
37852 190 CONTINUE
37853 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
37854 IF(K(I,4).NE.0) GOTO 220
37855C...Find daughters who point to documentation daughters who,
37856C...in their turn, point to documentation mother.
37857 ID1=IM
37858 ID2=IM
37859 DO 200 I1=IM+1,I-1
37860 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
37861 ID2=I1
37862 IF(ID1.EQ.IM) ID1=I1
37863 ENDIF
37864 200 CONTINUE
37865 DO 210 I1=I+1,N
37866 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
37867 ELSEIF(K(I,4).EQ.0) THEN
37868 K(I,4)=I1
37869 ELSE
37870 K(I,5)=I1
37871 ENDIF
37872 210 CONTINUE
37873 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
37874 220 CONTINUE
37875
37876C...Save top entries at bottom of PYJETS commonblock.
37877 ELSEIF(MEDIT.EQ.21) THEN
37878 IF(2*N.GE.MSTU(4)) THEN
37879 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
37880 RETURN
37881 ENDIF
37882 DO 240 I=1,N
37883 DO 230 J=1,5
37884 K(MSTU(4)-I,J)=K(I,J)
37885 P(MSTU(4)-I,J)=P(I,J)
37886 V(MSTU(4)-I,J)=V(I,J)
37887 230 CONTINUE
37888 240 CONTINUE
37889 MSTU(32)=N
37890
37891C...Restore bottom entries of commonblock PYJETS to top.
37892 ELSEIF(MEDIT.EQ.22) THEN
37893 DO 260 I=1,MSTU(32)
37894 DO 250 J=1,5
37895 K(I,J)=K(MSTU(4)-I,J)
37896 P(I,J)=P(MSTU(4)-I,J)
37897 V(I,J)=V(MSTU(4)-I,J)
37898 250 CONTINUE
37899 260 CONTINUE
37900 N=MSTU(32)
37901
37902C...Mark primary entries at top of commonblock PYJETS as untreated.
37903 ELSEIF(MEDIT.EQ.23) THEN
37904 I1=0
37905 DO 270 I=1,N
37906 KH=K(I,3)
37907 IF(KH.GE.1) THEN
37908 IF(K(KH,1).GT.20) KH=0
37909 ENDIF
37910 IF(KH.NE.0) GOTO 280
37911 I1=I1+1
37912 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
37913 270 CONTINUE
37914 280 N=I1
37915
37916C...Place largest axis along z axis and second largest in xy plane.
37917 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
37918 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
37919 & P(MSTU(61),2)),0D0,0D0,0D0)
37920 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
37921 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
37922 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
37923 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
37924 IF(MEDIT.EQ.31) RETURN
37925
37926C...Rotate to put slim jet along +z axis.
37927 DO 290 IS=1,2
37928 NS(IS)=0
37929 PTS(IS)=0D0
37930 PLS(IS)=0D0
37931 290 CONTINUE
37932 DO 300 I=1,N
37933 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
37934 IF(MSTU(41).GE.2) THEN
37935 KC=PYCOMP(K(I,2))
37936 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
37937 & KC.EQ.18) GOTO 300
37938 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
37939 & .EQ.0) GOTO 300
37940 ENDIF
37941 IS=2D0-SIGN(0.5D0,P(I,3))
37942 NS(IS)=NS(IS)+1
37943 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
37944 300 CONTINUE
37945 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
37946 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
37947
37948C...Rotate to put second largest jet into -z,+x quadrant.
37949 DO 310 I=1,N
37950 IF(P(I,3).GE.0D0) GOTO 310
37951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
37952 IF(MSTU(41).GE.2) THEN
37953 KC=PYCOMP(K(I,2))
37954 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
37955 & KC.EQ.18) GOTO 310
37956 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
37957 & .EQ.0) GOTO 310
37958 ENDIF
37959 IS=2D0-SIGN(0.5D0,P(I,1))
37960 PLS(IS)=PLS(IS)-P(I,3)
37961 310 CONTINUE
37962 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
37963 & 0D0,0D0,0D0)
37964 ENDIF
37965
37966 RETURN
37967 END
37968
37969C*********************************************************************
37970
37971C...PYLIST
37972C...Gives program heading, or lists an event, or particle
37973C...data, or current parameter values.
37974
37975 SUBROUTINE PYLIST(MLIST)
37976
37977C...Double precision and integer declarations.
37978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37979 INTEGER PYK,PYCHGE,PYCOMP
37980C...Parameter statement to help give large particle numbers.
37981 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
37982C...Commonblocks.
37983 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37984 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37985 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37986 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
37987 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
37988C...Local arrays, character variables and data.
37989 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
37990 DIMENSION PS(6)
37991 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
37992
37993C...Initialization printout: version number and date of last change.
37994 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
37995 CALL PYLOGO
37996 MSTU(12)=0
37997 IF(MLIST.EQ.0) RETURN
37998 ENDIF
37999
38000C...List event data, including additional lines after N.
38001 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
38002 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
38003 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
38004 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
38005 LMX=12
38006 IF(MLIST.GE.2) LMX=16
38007 ISTR=0
38008 IMAX=N
38009 IF(MSTU(2).GT.0) IMAX=MSTU(2)
38010 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
38011 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
38012
38013C...Get particle name, pad it and check it is not too long.
38014 CALL PYNAME(K(I,2),CHAP)
38015 LEN=0
38016 DO 100 LEM=1,16
38017 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
38018 100 CONTINUE
38019 MDL=(K(I,1)+19)/10
38020 LDL=0
38021 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
38022 CHAC=CHAP
38023 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
38024 ELSE
38025 LDL=1
38026 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
38027 IF(LEN.EQ.0) THEN
38028 CHAC=CHDL(MDL)(1:2*LDL)//' '
38029 ELSE
38030 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
38031 & CHDL(MDL)(LDL+1:2*LDL)//' '
38032 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
38033 ENDIF
38034 ENDIF
38035
38036C...Add information on string connection.
38037 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
38038 & THEN
38039 KC=PYCOMP(K(I,2))
38040 KCC=0
38041 IF(KC.NE.0) KCC=KCHG(KC,2)
38042 IF(IABS(K(I,2)).EQ.39) THEN
38043 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
38044 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
38045 ISTR=1
38046 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
38047 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
38048 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
38049 ELSEIF(KCC.NE.0) THEN
38050 ISTR=0
38051 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
38052 ENDIF
38053 ENDIF
38054
38055C...Write data for particle/jet.
38056 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
38057 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
38058 & (P(I,J2),J2=1,5)
38059 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
38060 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
38061 & (P(I,J2),J2=1,5)
38062 ELSEIF(MLIST.EQ.1) THEN
38063 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
38064 & (P(I,J2),J2=1,5)
38065 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
38066 & K(I,1).EQ.14)) THEN
38067 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
38068 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
38069 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
38070 & (P(I,J2),J2=1,5)
38071 ELSE
38072 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
38073 & (P(I,J2),J2=1,5)
38074 ENDIF
38075 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
38076
38077C...Insert extra separator lines specified by user.
38078 IF(MSTU(70).GE.1) THEN
38079 ISEP=0
38080 DO 110 J=1,MIN(10,MSTU(70))
38081 IF(I.EQ.MSTU(70+J)) ISEP=1
38082 110 CONTINUE
38083 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
38084 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
38085 ENDIF
38086 120 CONTINUE
38087
38088C...Sum of charges and momenta.
38089 DO 130 J=1,6
38090 PS(J)=PYP(0,J)
38091 130 CONTINUE
38092 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
38093 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
38094 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
38095 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
38096 ELSEIF(MLIST.EQ.1) THEN
38097 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
38098 ELSE
38099 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
38100 ENDIF
38101
38102C...Give simple list of KF codes defined in program.
38103 ELSEIF(MLIST.EQ.11) THEN
38104 WRITE(MSTU(11),6600)
38105 DO 140 KF=1,80
38106 CALL PYNAME(KF,CHAP)
38107 CALL PYNAME(-KF,CHAN)
38108 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38109 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38110 140 CONTINUE
38111 DO 170 KFLS=1,3,2
38112 DO 160 KFLA=1,5
38113 DO 150 KFLB=1,KFLA-(3-KFLS)/2
38114 KF=1000*KFLA+100*KFLB+KFLS
38115 CALL PYNAME(KF,CHAP)
38116 CALL PYNAME(-KF,CHAN)
38117 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38118 150 CONTINUE
38119 160 CONTINUE
38120 170 CONTINUE
38121 KF=130
38122 CALL PYNAME(KF,CHAP)
38123 WRITE(MSTU(11),6700) KF,CHAP
38124 KF=310
38125 CALL PYNAME(KF,CHAP)
38126 WRITE(MSTU(11),6700) KF,CHAP
38127 DO 200 KMUL=0,5
38128 KFLS=3
38129 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
38130 IF(KMUL.EQ.5) KFLS=5
38131 KFLR=0
38132 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
38133 IF(KMUL.EQ.4) KFLR=2
38134 DO 190 KFLB=1,5
38135 DO 180 KFLC=1,KFLB-1
38136 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
38137 CALL PYNAME(KF,CHAP)
38138 CALL PYNAME(-KF,CHAN)
38139 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38140 180 CONTINUE
38141 KF=10000*KFLR+110*KFLB+KFLS
38142 CALL PYNAME(KF,CHAP)
38143 WRITE(MSTU(11),6700) KF,CHAP
38144 190 CONTINUE
38145 200 CONTINUE
38146 KF=100443
38147 CALL PYNAME(KF,CHAP)
38148 WRITE(MSTU(11),6700) KF,CHAP
38149 KF=100553
38150 CALL PYNAME(KF,CHAP)
38151 WRITE(MSTU(11),6700) KF,CHAP
38152 DO 240 KFLSP=1,3
38153 KFLS=2+2*(KFLSP/3)
38154 DO 230 KFLA=1,5
38155 DO 220 KFLB=1,KFLA
38156 DO 210 KFLC=1,KFLB
38157 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
38158 & GOTO 210
38159 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
38160 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
38161 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
38162 CALL PYNAME(KF,CHAP)
38163 CALL PYNAME(-KF,CHAN)
38164 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38165 210 CONTINUE
38166 220 CONTINUE
38167 230 CONTINUE
38168 240 CONTINUE
38169 DO 250 KF=KSUSY1+1,KSUSY1+40
38170 CALL PYNAME(KF,CHAP)
38171 CALL PYNAME(-KF,CHAN)
38172 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38173 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38174 250 CONTINUE
38175 DO 260 KF=KSUSY2+1,KSUSY2+40
38176 CALL PYNAME(KF,CHAP)
38177 CALL PYNAME(-KF,CHAN)
38178 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38179 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38180 260 CONTINUE
38181 DO 270 KF=KEXCIT+1,KEXCIT+40
38182 CALL PYNAME(KF,CHAP)
38183 CALL PYNAME(-KF,CHAN)
38184 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38185 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38186 270 CONTINUE
38187
38188C...List parton/particle data table. Check whether to be listed.
38189 ELSEIF(MLIST.EQ.12) THEN
38190 WRITE(MSTU(11),6800)
38191 DO 300 KC=1,MSTU(6)
38192 KF=KCHG(KC,4)
38193 IF(KF.EQ.0) GOTO 300
38194 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
38195 & GOTO 300
38196
38197C...Find particle name and mass. Print information.
38198 CALL PYNAME(KF,CHAP)
38199 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
38200 CALL PYNAME(-KF,CHAN)
38201 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
38202 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
38203
38204C...Particle decay: channel number, branching ratios, matrix element,
38205C...decay products.
38206 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38207 DO 280 J=1,5
38208 CALL PYNAME(KFDP(IDC,J),CHAD(J))
38209 280 CONTINUE
38210 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38211 & (CHAD(J),J=1,5)
38212 290 CONTINUE
38213 300 CONTINUE
38214
38215C...List parameter value table.
38216 ELSEIF(MLIST.EQ.13) THEN
38217 WRITE(MSTU(11),7100)
38218 DO 310 I=1,200
38219 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
38220 310 CONTINUE
38221 ENDIF
38222
38223C...Format statements for output on unit MSTU(11) (by default 6).
38224 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
38225 &5X,'KF orig p_x p_y p_z E m'/)
38226 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
38227 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38228 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
38229 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
38230 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38231 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
38232 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
38233 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
38234 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
38235 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
38236 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
38237 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
38238 5900 FORMAT(66X,5(1X,F12.3))
38239 6000 FORMAT(1X,78('='))
38240 6100 FORMAT(1X,130('='))
38241 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
38242 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
38243 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
38244 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
38245 &5F13.5)
38246 6600 FORMAT(///20X,'List of KF codes in program'/)
38247 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
38248 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
38249 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
38250 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
38251 &1X,'ME',3X,'Br.rat.',4X,'decay products')
38252 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
38253 &1X,1P,E13.5,3X,I2)
38254 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
38255 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
38256 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
38257 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
38258
38259 RETURN
38260 END
38261
38262C*********************************************************************
38263
38264C...PYLOGO
38265C...Writes a logo for the program.
38266
38267 SUBROUTINE PYLOGO
38268
38269C...Double precision and integer declarations.
38270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38271 INTEGER PYK,PYCHGE,PYCOMP
38272C...Parameter for length of information block.
38273 PARAMETER (IREFER=17)
38274C...Commonblocks.
38275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38277 SAVE /PYDAT1/,/PYPARS/
38278C...Local arrays and character variables.
38279 INTEGER IDATI(6)
38280 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
38281 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
38282
38283C...Data on months, logo, titles, and references.
38284 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
38285 &'Oct','Nov','Dec'/
38286 DATA (LOGO(J),J=1,19)/
38287 &' *......* ',
38288 &' *:::!!:::::::::::* ',
38289 &' *::::::!!::::::::::::::* ',
38290 &' *::::::::!!::::::::::::::::* ',
38291 &' *:::::::::!!:::::::::::::::::* ',
38292 &' *:::::::::!!:::::::::::::::::* ',
38293 &' *::::::::!!::::::::::::::::*! ',
38294 &' *::::::!!::::::::::::::* !! ',
38295 &' !! *:::!!:::::::::::* !! ',
38296 &' !! !* -><- * !! ',
38297 &' !! !! !! ',
38298 &' !! !! !! ',
38299 &' !! !! ',
38300 &' !! ep !! ',
38301 &' !! !! ',
38302 &' !! pp !! ',
38303 &' !! e+e- !! ',
38304 &' !! !! ',
38305 &' !! '/
38306 DATA (LOGO(J),J=20,38)/
38307 &'Welcome to the Lund Monte Carlo!',
38308 &' ',
38309 &'PPP Y Y TTTTT H H III A ',
38310 &'P P Y Y T H H I A A ',
38311 &'PPP Y T HHHHH I AAAAA',
38312 &'P Y T H H I A A',
38313 &'P Y T H H III A A',
38314 &' ',
38315 &'This is PYTHIA version x.xxx ',
38316 &'Last date of change: xx xxx 199x',
38317 &' ',
38318 &'Now is xx xxx 199x at xx:xx:xx ',
38319 &' ',
38320 &'Disclaimer: this program comes ',
38321 &'without any guarantees. Beware ',
38322 &'of errors and use common sense ',
38323 &'when interpreting results. ',
38324 &' ',
38325 &'Copyright T. Sjostrand (1997) '/
38326 DATA (REFER(J),J=1,18)/
38327 &'An archive of program versions and d',
38328 &'ocumentation is found on the web: ',
38329 &'http://www.thep.lu.se/tf2/staff/torb',
38330 &'jorn/Pythia.html ',
38331 &' ',
38332 &' ',
38333 &'When you cite this program, currentl',
38334 &'y the official reference is ',
38335 &'T. Sjostrand, Computer Physics Commu',
38336 &'n. 82 (1994) 74. ',
38337 &'The supersymmetry extensions are des',
38338 &'cribed in ',
38339 &'S. Mrenna, Computer Physics Commun. ',
38340 &'101 (1997) 232 ',
38341 &'Also remember that the program, to a',
38342 &' large extent, represents original ',
38343 &'physics research. Other publications',
38344 &' of special relevance to your '/
38345 DATA (REFER(J),J=19,2*IREFER)/
38346 &'studies may therefore deserve separa',
38347 &'te mention. ',
38348 &' ',
38349 &' ',
38350 &'Main author: Torbjorn Sjostrand; Dep',
38351 &'artment of Theoretical Physics 2, ',
38352 &' Lund University, Solvegatan 14A, S',
38353 &'-223 62 Lund, Sweden; ',
38354 &' phone: + 46 - 46 - 222 48 16; e-ma',
38355 &'il: torbjorn@thep.lu.se ',
38356 &'SUSY author: Stephen Mrenna, Argonne',
38357 &' National Laboratory, ',
38358 &' 9700 South Cass Avenue, Argonne, I',
38359 &'L 60439, USA; ',
38360 &' phone: + 1 - 630 - 252 - 7615; e-m',
38361 &'ail: mrenna@hep.anl.gov '/
38362
38363C...Check that PYDATA linked.
38364 IF(MSTP(183)/10.NE.199) THEN
38365 WRITE(MSTU(11),'(1X,A)')
38366 & 'Error: PYDATA has not been linked.'
38367 WRITE(MSTU(11),'(1X,A)') 'Execution stopped!'
38368 STOP
38369
38370C...Write current version number and current date+time.
38371 ELSE
38372 WRITE(VERS,'(I1)') MSTP(181)
38373 LOGO(28)(24:24)=VERS
38374 WRITE(SUBV,'(I3)') MSTP(182)
38375 LOGO(28)(26:28)=SUBV
38376 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
38377 WRITE(DATE,'(I2)') MSTP(185)
38378 LOGO(29)(22:23)=DATE
38379 LOGO(29)(25:27)=MONTH(MSTP(184))
38380 WRITE(YEAR,'(I4)') MSTP(183)
38381 LOGO(29)(29:32)=YEAR
38382 CALL PYTIME(IDATI)
38383 IF(IDATI(1).LE.0) THEN
38384 LOGO(31)=' '
38385 ELSE
38386 WRITE(DATE,'(I2)') IDATI(3)
38387 LOGO(31)(8:9)=DATE
38388 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
38389 WRITE(YEAR,'(I4)') IDATI(1)
38390 LOGO(31)(15:18)=YEAR
38391 WRITE(HOUR,'(I2)') IDATI(4)
38392 LOGO(31)(23:24)=HOUR
38393 WRITE(MINU,'(I2)') IDATI(5)
38394 LOGO(31)(26:27)=MINU
38395 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
38396 WRITE(SECO,'(I2)') IDATI(6)
38397 LOGO(31)(29:30)=SECO
38398 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
38399 ENDIF
38400 ENDIF
38401
38402C...Loop over lines in header. Define page feed and side borders.
38403 DO 100 ILIN=1,29+IREFER
38404 LINE=' '
38405 IF(ILIN.EQ.1) THEN
38406 LINE(1:1)='1'
38407 ELSE
38408 LINE(2:3)='**'
38409 LINE(78:79)='**'
38410 ENDIF
38411
38412C...Separator lines and logos.
38413 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
38414 LINE(4:77)='***********************************************'//
38415 & '***************************'
38416 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
38417 LINE(6:37)=LOGO(ILIN-5)
38418 LINE(44:75)=LOGO(ILIN+14)
38419 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
38420 LINE(5:40)=REFER(2*ILIN-51)
38421 LINE(41:76)=REFER(2*ILIN-50)
38422 ENDIF
38423
38424C...Write lines to appropriate unit.
38425 WRITE(MSTU(11),'(A79)') LINE
38426 100 CONTINUE
38427
38428 RETURN
38429 END
38430
38431C*********************************************************************
38432
38433C...PYUPDA
38434C...Facilitates the updating of particle and decay data
38435C...by allowing it to be done in an external file.
38436
38437 SUBROUTINE PYUPDA(MUPDA,LFN)
38438
38439C...Double precision and integer declarations.
38440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38441 INTEGER PYK,PYCHGE,PYCOMP
38442C...Commonblocks.
38443 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38444 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38445 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38446 COMMON/PYDAT4/CHAF(500,2)
38447 CHARACTER CHAF*16
38448 COMMON/PYINT4/MWID(500),WIDS(500,5)
38449 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
38450C...Local arrays, character variables and data.
38451 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
38452 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
38453 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
38454 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
38455 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
38456 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
38457 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
38458
38459C...Write header if not yet done.
38460 IF(MSTU(12).GE.1) CALL PYLIST(0)
38461
38462C...Write information on file for editing.
38463 IF(MUPDA.EQ.1) THEN
38464 DO 110 KC=1,500
38465 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38466 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38467 & MWID(KC),MDCY(KC,1)
38468 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38469 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38470 & (KFDP(IDC,J),J=1,5)
38471 100 CONTINUE
38472 110 CONTINUE
38473
38474C...Read complete set of information from edited file or
38475C...read partial set of new or updated information from edited file.
38476 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
38477
38478C...Reset counters.
38479 KCC=100
38480 NDC=0
38481 CHKF=' '
38482 IF(MUPDA.EQ.2) THEN
38483 DO 120 I=1,MSTU(6)
38484 KCHG(I,4)=0
38485 120 CONTINUE
38486 ELSE
38487 DO 130 KC=1,MSTU(6)
38488 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
38489 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
38490 130 CONTINUE
38491 ENDIF
38492
38493C...Begin of loop: read new line; unknown whether particle or
38494C...decay data.
38495 140 READ(LFN,5200,END=190) CHINL
38496
38497C...Identify particle code and whether already defined (for MUPDA=3).
38498 IF(CHINL(2:10).NE.' ') THEN
38499 CHKF=CHINL(2:10)
38500 READ(CHKF,5300) KF
38501 IF(MUPDA.EQ.2) THEN
38502 IF(KF.LE.100) THEN
38503 KC=KF
38504 ELSE
38505 KCC=KCC+1
38506 KC=KCC
38507 ENDIF
38508 ELSE
38509 KCREP=0
38510 IF(KF.LE.100) THEN
38511 KCREP=KF
38512 ELSE
38513 DO 150 KCR=101,KCC
38514 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
38515 150 CONTINUE
38516 ENDIF
38517C...Remove duplicate old decay data.
38518 IF(KCREP.NE.0) THEN
38519 IDCREP=MDCY(KCREP,2)
38520 NDCREP=MDCY(KCREP,3)
38521 DO 160 I=1,KCC
38522 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
38523 160 CONTINUE
38524 DO 180 I=IDCREP,NDC-NDCREP
38525 MDME(I,1)=MDME(I+NDCREP,1)
38526 MDME(I,2)=MDME(I+NDCREP,2)
38527 BRAT(I)=BRAT(I+NDCREP)
38528 DO 170 J=1,5
38529 KFDP(I,J)=KFDP(I+NDCREP,J)
38530 170 CONTINUE
38531 180 CONTINUE
38532 NDC=NDC-NDCREP
38533 KC=KCREP
38534 ELSE
38535 KCC=KCC+1
38536 KC=KCC
38537 ENDIF
38538 ENDIF
38539
38540C...Study line with particle data.
38541 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
38542 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
38543 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38544 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38545 & MWID(KC),MDCY(KC,1)
38546 MDCY(KC,2)=0
38547 MDCY(KC,3)=0
38548
38549C...Study line with decay data.
38550 ELSE
38551 NDC=NDC+1
38552 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
38553 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
38554 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
38555 MDCY(KC,3)=MDCY(KC,3)+1
38556 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
38557 & (KFDP(NDC,J),J=1,5)
38558 ENDIF
38559
38560C...End of loop; ensure that PYCOMP tables are updated.
38561 GOTO 140
38562 190 CONTINUE
38563 MSTU(20)=0
38564
38565C...Perform possible tests that new information is consistent.
38566 MSTJ24=MSTJ(24)
38567 MSTJ(24)=0
38568 DO 220 KC=1,MSTU(6)
38569 KF=KCHG(KC,4)
38570 IF(KF.EQ.0) GOTO 220
38571 WRITE(CHKF,5300) KF
38572 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
38573 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
38574 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
38575 BRSUM=0D0
38576 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38577 IF(MDME(IDC,2).GT.80) GOTO 210
38578 KQ=KCHG(KC,1)
38579 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
38580 MERR=0
38581 DO 200 J=1,5
38582 KP=KFDP(IDC,J)
38583 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
38584 IF(KP.EQ.81) KQ=0
38585 ELSEIF(PYCOMP(KP).EQ.0) THEN
38586 MERR=3
38587 ELSE
38588 KQ=KQ-PYCHGE(KP)
38589 PMS=PMS-PYMASS(KP)
38590 KPC=PYCOMP(KP)
38591 PMS=PMS-PMAS(KPC,1)
38592 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
38593 & PMAS(KPC,3))
38594 ENDIF
38595 200 CONTINUE
38596 IF(KQ.NE.0) MERR=MAX(2,MERR)
38597 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
38598 & MERR=MAX(1,MERR)
38599 IF(MERR.EQ.3) CALL PYERRM(17,
38600 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
38601 IF(MERR.EQ.2) CALL PYERRM(17,
38602 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
38603 IF(MERR.EQ.1) CALL PYERRM(7,
38604 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
38605 BRSUM=BRSUM+BRAT(IDC)
38606 210 CONTINUE
38607 WRITE(CHTMP,5500) BRSUM
38608 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
38609 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
38610 & CHTMP(9:16)//' for KF ='//CHKF)
38611 220 CONTINUE
38612 MSTJ(24)=MSTJ24
38613
38614C...Write DATA statements for inclusion in program.
38615 ELSEIF(MUPDA.EQ.4) THEN
38616
38617C...Find out how many codes and decay channels are actually used.
38618 KCC=0
38619 NDC=0
38620 DO 230 I=1,MSTU(6)
38621 IF(KCHG(I,4).NE.0) THEN
38622 KCC=I
38623 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
38624 ENDIF
38625 230 CONTINUE
38626
38627C...Initialize writing of DATA statements for inclusion in program.
38628 DO 300 IVAR=1,22
38629 NDIM=MSTU(6)
38630 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
38631 NLIN=1
38632 CHLIN=' '
38633 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
38634 LLIN=35
38635 CHOLD='START'
38636
38637C...Loop through variables for conversion to characters.
38638 DO 280 IDIM=1,NDIM
38639 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
38640 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
38641 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
38642 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
38643 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
38644 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
38645 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
38646 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
38647 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
38648 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
38649 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
38650 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
38651 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
38652 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
38653 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
38654 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
38655 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
38656 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
38657 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
38658 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
38659 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
38660 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
38661
38662C...Replace variables beyond what is properly defined.
38663 IF(IVAR.LE.4) THEN
38664 IF(IDIM.GT.KCC) CHTMP=' 0'
38665 ELSEIF(IVAR.LE.8) THEN
38666 IF(IDIM.GT.KCC) CHTMP=' 0.0'
38667 ELSEIF(IVAR.LE.11) THEN
38668 IF(IDIM.GT.KCC) CHTMP=' 0'
38669 ELSEIF(IVAR.LE.13) THEN
38670 IF(IDIM.GT.NDC) CHTMP=' 0'
38671 ELSEIF(IVAR.LE.14) THEN
38672 IF(IDIM.GT.NDC) CHTMP=' 0.0'
38673 ELSEIF(IVAR.LE.19) THEN
38674 IF(IDIM.GT.NDC) CHTMP=' 0'
38675 ELSEIF(IVAR.LE.21) THEN
38676 IF(IDIM.GT.KCC) CHTMP=' '
38677 ELSE
38678 IF(IDIM.GT.KCC) CHTMP=' 0'
38679 ENDIF
38680
38681C...Length of variable, trailing decimal zeros, quotation marks.
38682 LLOW=1
38683 LHIG=1
38684 DO 240 LL=1,16
38685 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
38686 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
38687 240 CONTINUE
38688 CHNEW=CHTMP(LLOW:LHIG)//' '
38689 LNEW=1+LHIG-LLOW
38690 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
38691 LNEW=LNEW+1
38692 250 LNEW=LNEW-1
38693 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
38694 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
38695 IF(LNEW.EQ.0) THEN
38696 CHNEW(1:3)='0D0'
38697 LNEW=3
38698 ELSE
38699 CHNEW(LNEW+1:LNEW+2)='D0'
38700 LNEW=LNEW+2
38701 ENDIF
38702 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
38703 DO 260 LL=LNEW,1,-1
38704 IF(CHNEW(LL:LL).EQ.'''') THEN
38705 CHTMP=CHNEW
38706 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
38707 LNEW=LNEW+1
38708 ENDIF
38709 260 CONTINUE
38710 LNEW=MIN(14,LNEW)
38711 CHTMP=CHNEW
38712 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
38713 LNEW=LNEW+2
38714 ENDIF
38715
38716C...Form composite character string, often including repetition counter.
38717 IF(CHNEW.NE.CHOLD) THEN
38718 NRPT=1
38719 CHOLD=CHNEW
38720 CHCOM=CHNEW
38721 LCOM=LNEW
38722 ELSE
38723 LRPT=LNEW+1
38724 IF(NRPT.GE.2) LRPT=LNEW+3
38725 IF(NRPT.GE.10) LRPT=LNEW+4
38726 IF(NRPT.GE.100) LRPT=LNEW+5
38727 IF(NRPT.GE.1000) LRPT=LNEW+6
38728 LLIN=LLIN-LRPT
38729 NRPT=NRPT+1
38730 WRITE(CHTMP,5400) NRPT
38731 LRPT=1
38732 IF(NRPT.GE.10) LRPT=2
38733 IF(NRPT.GE.100) LRPT=3
38734 IF(NRPT.GE.1000) LRPT=4
38735 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
38736 LCOM=LRPT+1+LNEW
38737 ENDIF
38738
38739C...Add characters to end of line, to new line (after storing old line),
38740C...or to new block of lines (after writing old block).
38741 IF(LLIN+LCOM.LE.70) THEN
38742 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
38743 LLIN=LLIN+LCOM+1
38744 ELSEIF(NLIN.LE.19) THEN
38745 CHLIN(LLIN+1:72)=' '
38746 CHBLK(NLIN)=CHLIN
38747 NLIN=NLIN+1
38748 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
38749 LLIN=6+LCOM+1
38750 ELSE
38751 CHLIN(LLIN:72)='/'//' '
38752 CHBLK(NLIN)=CHLIN
38753 WRITE(CHTMP,5400) IDIM-NRPT
38754 CHBLK(1)(30:33)=CHTMP(13:16)
38755 DO 270 ILIN=1,NLIN
38756 WRITE(LFN,5700) CHBLK(ILIN)
38757 270 CONTINUE
38758 NLIN=1
38759 CHLIN=' '
38760 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
38761 & ',I= , )/'//CHCOM(1:LCOM)//','
38762 WRITE(CHTMP,5400) IDIM-NRPT+1
38763 CHLIN(25:28)=CHTMP(13:16)
38764 LLIN=35+LCOM+1
38765 ENDIF
38766 280 CONTINUE
38767
38768C...Write final block of lines.
38769 CHLIN(LLIN:72)='/'//' '
38770 CHBLK(NLIN)=CHLIN
38771 WRITE(CHTMP,5400) NDIM
38772 CHBLK(1)(30:33)=CHTMP(13:16)
38773 DO 290 ILIN=1,NLIN
38774 WRITE(LFN,5700) CHBLK(ILIN)
38775 290 CONTINUE
38776 300 CONTINUE
38777 ENDIF
38778
38779C...Formats for reading and writing particle data.
38780 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
38781 5100 FORMAT(10X,2I5,F12.6,5I10)
38782 5200 FORMAT(A120)
38783 5300 FORMAT(I9)
38784 5400 FORMAT(I16)
38785 5500 FORMAT(F16.5)
38786 5600 FORMAT(F16.6)
38787 5700 FORMAT(A72)
38788
38789 RETURN
38790 END
38791
38792C*********************************************************************
38793
38794C...PYK
38795C...Provides various integer-valued event related data.
38796
38797 FUNCTION PYK(I,J)
38798
38799C...Double precision and integer declarations.
38800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38801 INTEGER PYK,PYCHGE,PYCOMP
38802C...Commonblocks.
38803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38806 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
38807
38808C...Default value. For I=0 number of entries, number of stable entries
38809C...or 3 times total charge.
38810 PYK=0
38811 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
38812 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
38813 PYK=N
38814 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
38815 DO 100 I1=1,N
38816 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
38817 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
38818 & PYCHGE(K(I1,2))
38819 100 CONTINUE
38820 ELSEIF(I.EQ.0) THEN
38821
38822C...For I > 0 direct readout of K matrix or charge.
38823 ELSEIF(J.LE.5) THEN
38824 PYK=K(I,J)
38825 ELSEIF(J.EQ.6) THEN
38826 PYK=PYCHGE(K(I,2))
38827
38828C...Status (existing/fragmented/decayed), parton/hadron separation.
38829 ELSEIF(J.LE.8) THEN
38830 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
38831 IF(J.EQ.8) PYK=PYK*K(I,2)
38832 ELSEIF(J.LE.12) THEN
38833 KFA=IABS(K(I,2))
38834 KC=PYCOMP(KFA)
38835 KQ=0
38836 IF(KC.NE.0) KQ=KCHG(KC,2)
38837 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
38838 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
38839 IF(J.EQ.11) PYK=KC
38840 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
38841
38842C...Heaviest flavour in hadron/diquark.
38843 ELSEIF(J.EQ.13) THEN
38844 KFA=IABS(K(I,2))
38845 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
38846 IF(KFA.LT.10) PYK=KFA
38847 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
38848 PYK=PYK*ISIGN(1,K(I,2))
38849
38850C...Particle history: generation, ancestor, rank.
38851 ELSEIF(J.LE.15) THEN
38852 I2=I
38853 I1=I
38854 110 PYK=PYK+1
38855 I2=I1
38856 I1=K(I1,3)
38857 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
38858 IF(J.EQ.15) PYK=I2
38859 ELSEIF(J.EQ.16) THEN
38860 KFA=IABS(K(I,2))
38861 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
38862 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
38863 I1=I
38864 120 I2=I1
38865 I1=K(I1,3)
38866 IF(I1.GT.0) THEN
38867 KFAM=IABS(K(I1,2))
38868 ILP=1
38869 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
38870 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
38871 & ILP=0
38872 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
38873 IF(ILP.EQ.1) GOTO 120
38874 ENDIF
38875 IF(K(I1,1).EQ.12) THEN
38876 DO 130 I3=I1+1,I2
38877 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
38878 & .AND.K(I3,2).NE.93) PYK=PYK+1
38879 130 CONTINUE
38880 ELSE
38881 I3=I2
38882 140 PYK=PYK+1
38883 I3=I3+1
38884 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
38885 ENDIF
38886 ENDIF
38887
38888C...Particle coming from collapsing jet system or not.
38889 ELSEIF(J.EQ.17) THEN
38890 I1=I
38891 150 PYK=PYK+1
38892 I3=I1
38893 I1=K(I1,3)
38894 I0=MAX(1,I1)
38895 KC=PYCOMP(K(I0,2))
38896 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
38897 IF(PYK.EQ.1) PYK=-1
38898 IF(PYK.GT.1) PYK=0
38899 RETURN
38900 ENDIF
38901 IF(KCHG(KC,2).EQ.0) GOTO 150
38902 IF(K(I1,1).NE.12) PYK=0
38903 IF(K(I1,1).NE.12) RETURN
38904 I2=I1
38905 160 I2=I2+1
38906 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
38907 K3M=K(I3-1,3)
38908 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
38909 K3P=K(I3+1,3)
38910 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
38911
38912C...Number of decay products. Colour flow.
38913 ELSEIF(J.EQ.18) THEN
38914 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
38915 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
38916 ELSEIF(J.LE.22) THEN
38917 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
38918 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
38919 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
38920 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
38921 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
38922 ELSE
38923 ENDIF
38924
38925 RETURN
38926 END
38927
38928C*********************************************************************
38929
38930C...PYP
38931C...Provides various real-valued event related data.
38932
38933 FUNCTION PYP(I,J)
38934
38935C...Double precision and integer declarations.
38936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38937 INTEGER PYK,PYCHGE,PYCOMP
38938C...Commonblocks.
38939 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38941 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38942 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
38943C...Local array.
38944 DIMENSION PSUM(4)
38945
38946C...Set default value. For I = 0 sum of momenta or charges,
38947C...or invariant mass of system.
38948 PYP=0D0
38949 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
38950 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
38951 DO 100 I1=1,N
38952 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
38953 100 CONTINUE
38954 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
38955 DO 120 J1=1,4
38956 PSUM(J1)=0D0
38957 DO 110 I1=1,N
38958 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
38959 & P(I1,J1)
38960 110 CONTINUE
38961 120 CONTINUE
38962 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
38963 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
38964 DO 130 I1=1,N
38965 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
38966 130 CONTINUE
38967 ELSEIF(I.EQ.0) THEN
38968
38969C...Direct readout of P matrix.
38970 ELSEIF(J.LE.5) THEN
38971 PYP=P(I,J)
38972
38973C...Charge, total momentum, transverse momentum, transverse mass.
38974 ELSEIF(J.LE.12) THEN
38975 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
38976 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
38977 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
38978 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
38979 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
38980
38981C...Theta and phi angle in radians or degrees.
38982 ELSEIF(J.LE.16) THEN
38983 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
38984 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
38985 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
38986
38987C...True rapidity, rapidity with pion mass, pseudorapidity.
38988 ELSEIF(J.LE.19) THEN
38989 PMR=0D0
38990 IF(J.EQ.17) PMR=P(I,5)
38991 IF(J.EQ.18) PMR=PYMASS(211)
38992 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
38993 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
38994 & 1D20)),P(I,3))
38995
38996C...Energy and momentum fractions (only to be used in CM frame).
38997 ELSEIF(J.LE.25) THEN
38998 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
38999 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
39000 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
39001 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
39002 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
39003 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
39004 ENDIF
39005
39006 RETURN
39007 END
39008
39009C*********************************************************************
39010
39011C...PYSPHE
39012C...Performs sphericity tensor analysis to give sphericity,
39013C...aplanarity and the related event axes.
39014
39015 SUBROUTINE PYSPHE(SPH,APL)
39016
39017C...Double precision and integer declarations.
39018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39019 INTEGER PYK,PYCHGE,PYCOMP
39020C...Commonblocks.
39021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39024 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39025C...Local arrays.
39026 DIMENSION SM(3,3),SV(3,3)
39027
39028C...Calculate matrix to be diagonalized.
39029 NP=0
39030 DO 110 J1=1,3
39031 DO 100 J2=J1,3
39032 SM(J1,J2)=0D0
39033 100 CONTINUE
39034 110 CONTINUE
39035 PS=0D0
39036 DO 140 I=1,N
39037 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39038 IF(MSTU(41).GE.2) THEN
39039 KC=PYCOMP(K(I,2))
39040 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39041 & KC.EQ.18) GOTO 140
39042 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39043 & GOTO 140
39044 ENDIF
39045 NP=NP+1
39046 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39047 PWT=1D0
39048 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
39049 & MAX(1D-10,PA)**(PARU(41)-2D0)
39050 DO 130 J1=1,3
39051 DO 120 J2=J1,3
39052 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
39053 120 CONTINUE
39054 130 CONTINUE
39055 PS=PS+PWT*PA**2
39056 140 CONTINUE
39057
39058C...Very low multiplicities (0 or 1) not considered.
39059 IF(NP.LE.1) THEN
39060 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
39061 SPH=-1D0
39062 APL=-1D0
39063 RETURN
39064 ENDIF
39065 DO 160 J1=1,3
39066 DO 150 J2=J1,3
39067 SM(J1,J2)=SM(J1,J2)/PS
39068 150 CONTINUE
39069 160 CONTINUE
39070
39071C...Find eigenvalues to matrix (third degree equation).
39072 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
39073 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
39074 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
39075 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
39076 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
39077 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
39078 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
39079 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
39080 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
39081 IF(P(N+2,4).LT.1D-5) THEN
39082 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
39083 SPH=-1D0
39084 APL=-1D0
39085 RETURN
39086 ENDIF
39087
39088C...Find first and last eigenvector by solving equation system.
39089 DO 240 I=1,3,2
39090 DO 180 J1=1,3
39091 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
39092 DO 170 J2=J1+1,3
39093 SV(J1,J2)=SM(J1,J2)
39094 SV(J2,J1)=SM(J1,J2)
39095 170 CONTINUE
39096 180 CONTINUE
39097 SMAX=0D0
39098 DO 200 J1=1,3
39099 DO 190 J2=1,3
39100 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
39101 JA=J1
39102 JB=J2
39103 SMAX=ABS(SV(J1,J2))
39104 190 CONTINUE
39105 200 CONTINUE
39106 SMAX=0D0
39107 DO 220 J3=JA+1,JA+2
39108 J1=J3-3*((J3-1)/3)
39109 RL=SV(J1,JB)/SV(JA,JB)
39110 DO 210 J2=1,3
39111 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
39112 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
39113 JC=J1
39114 SMAX=ABS(SV(J1,J2))
39115 210 CONTINUE
39116 220 CONTINUE
39117 JB1=JB+1-3*(JB/3)
39118 JB2=JB+2-3*((JB+1)/3)
39119 P(N+I,JB1)=-SV(JC,JB2)
39120 P(N+I,JB2)=SV(JC,JB1)
39121 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
39122 & SV(JA,JB)
39123 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
39124 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39125 DO 230 J=1,3
39126 P(N+I,J)=SGN*P(N+I,J)/PA
39127 230 CONTINUE
39128 240 CONTINUE
39129
39130C...Middle axis orthogonal to other two. Fill other codes.
39131 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39132 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
39133 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
39134 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
39135 DO 260 I=1,3
39136 K(N+I,1)=31
39137 K(N+I,2)=95
39138 K(N+I,3)=I
39139 K(N+I,4)=0
39140 K(N+I,5)=0
39141 P(N+I,5)=0D0
39142 DO 250 J=1,5
39143 V(I,J)=0D0
39144 250 CONTINUE
39145 260 CONTINUE
39146
39147C...Calculate sphericity and aplanarity. Select storing option.
39148 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
39149 APL=1.5D0*P(N+3,4)
39150 MSTU(61)=N+1
39151 MSTU(62)=NP
39152 IF(MSTU(43).LE.1) MSTU(3)=3
39153 IF(MSTU(43).GE.2) N=N+3
39154
39155 RETURN
39156 END
39157
39158C*********************************************************************
39159
39160C...PYTHRU
39161C...Performs thrust analysis to give thrust, oblateness
39162C...and the related event axes.
39163
39164 SUBROUTINE PYTHRU(THR,OBL)
39165
39166C...Double precision and integer declarations.
39167 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39168 INTEGER PYK,PYCHGE,PYCOMP
39169C...Commonblocks.
39170 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39172 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39173 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39174C...Local arrays.
39175 DIMENSION TDI(3),TPR(3)
39176
39177C...Take copy of particles that are to be considered in thrust analysis.
39178 NP=0
39179 PS=0D0
39180 DO 100 I=1,N
39181 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
39182 IF(MSTU(41).GE.2) THEN
39183 KC=PYCOMP(K(I,2))
39184 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39185 & KC.EQ.18) GOTO 100
39186 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39187 & GOTO 100
39188 ENDIF
39189 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
39190 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
39191 THR=-2D0
39192 OBL=-2D0
39193 RETURN
39194 ENDIF
39195 NP=NP+1
39196 K(N+NP,1)=23
39197 P(N+NP,1)=P(I,1)
39198 P(N+NP,2)=P(I,2)
39199 P(N+NP,3)=P(I,3)
39200 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39201 P(N+NP,5)=1D0
39202 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
39203 & P(N+NP,4)**(PARU(42)-1D0)
39204 PS=PS+P(N+NP,4)*P(N+NP,5)
39205 100 CONTINUE
39206
39207C...Very low multiplicities (0 or 1) not considered.
39208 IF(NP.LE.1) THEN
39209 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
39210 THR=-1D0
39211 OBL=-1D0
39212 RETURN
39213 ENDIF
39214
39215C...Loop over thrust and major. T axis along z direction in latter case.
39216 DO 320 ILD=1,2
39217 IF(ILD.EQ.2) THEN
39218 K(N+NP+1,1)=31
39219 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
39220 MSTU(33)=1
39221 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
39222 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
39223 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
39224 ENDIF
39225
39226C...Find and order particles with highest p (pT for major).
39227 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
39228 P(ILF,4)=0D0
39229 110 CONTINUE
39230 DO 160 I=N+1,N+NP
39231 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
39232 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
39233 IF(P(I,4).LE.P(ILF,4)) GOTO 140
39234 DO 120 J=1,5
39235 P(ILF+1,J)=P(ILF,J)
39236 120 CONTINUE
39237 130 CONTINUE
39238 ILF=N+NP+3
39239 140 DO 150 J=1,5
39240 P(ILF+1,J)=P(I,J)
39241 150 CONTINUE
39242 160 CONTINUE
39243
39244C...Find and order initial axes with highest thrust (major).
39245 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
39246 P(ILG,4)=0D0
39247 170 CONTINUE
39248 NC=2**(MIN(MSTU(44),NP)-1)
39249 DO 250 ILC=1,NC
39250 DO 180 J=1,3
39251 TDI(J)=0D0
39252 180 CONTINUE
39253 DO 200 ILF=1,MIN(MSTU(44),NP)
39254 SGN=P(N+NP+ILF+3,5)
39255 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
39256 DO 190 J=1,4-ILD
39257 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
39258 190 CONTINUE
39259 200 CONTINUE
39260 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
39261 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
39262 IF(TDS.LE.P(ILG,4)) GOTO 230
39263 DO 210 J=1,4
39264 P(ILG+1,J)=P(ILG,J)
39265 210 CONTINUE
39266 220 CONTINUE
39267 ILG=N+NP+MSTU(44)+4
39268 230 DO 240 J=1,3
39269 P(ILG+1,J)=TDI(J)
39270 240 CONTINUE
39271 P(ILG+1,4)=TDS
39272 250 CONTINUE
39273
39274C...Iterate direction of axis until stable maximum.
39275 P(N+NP+ILD,4)=0D0
39276 ILG=0
39277 260 ILG=ILG+1
39278 THP=0D0
39279 270 THPS=THP
39280 DO 280 J=1,3
39281 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
39282 IF(THP.GT.1D-10) TDI(J)=TPR(J)
39283 TPR(J)=0D0
39284 280 CONTINUE
39285 DO 300 I=N+1,N+NP
39286 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
39287 DO 290 J=1,4-ILD
39288 TPR(J)=TPR(J)+SGN*P(I,J)
39289 290 CONTINUE
39290 300 CONTINUE
39291 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
39292 IF(THP.GE.THPS+PARU(48)) GOTO 270
39293
39294C...Save good axis. Try new initial axis until a number of tries agree.
39295 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
39296 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
39297 IAGR=0
39298 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39299 DO 310 J=1,3
39300 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
39301 310 CONTINUE
39302 P(N+NP+ILD,4)=THP
39303 P(N+NP+ILD,5)=0D0
39304 ENDIF
39305 IAGR=IAGR+1
39306 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
39307 320 CONTINUE
39308
39309C...Find minor axis and value by orthogonality.
39310 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39311 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
39312 P(N+NP+3,2)=SGN*P(N+NP+2,1)
39313 P(N+NP+3,3)=0D0
39314 THP=0D0
39315 DO 330 I=N+1,N+NP
39316 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
39317 330 CONTINUE
39318 P(N+NP+3,4)=THP/PS
39319 P(N+NP+3,5)=0D0
39320
39321C...Fill axis information. Rotate back to original coordinate system.
39322 DO 350 ILD=1,3
39323 K(N+ILD,1)=31
39324 K(N+ILD,2)=96
39325 K(N+ILD,3)=ILD
39326 K(N+ILD,4)=0
39327 K(N+ILD,5)=0
39328 DO 340 J=1,5
39329 P(N+ILD,J)=P(N+NP+ILD,J)
39330 V(N+ILD,J)=0D0
39331 340 CONTINUE
39332 350 CONTINUE
39333 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
39334
39335C...Calculate thrust and oblateness. Select storing option.
39336 THR=P(N+1,4)
39337 OBL=P(N+2,4)-P(N+3,4)
39338 MSTU(61)=N+1
39339 MSTU(62)=NP
39340 IF(MSTU(43).LE.1) MSTU(3)=3
39341 IF(MSTU(43).GE.2) N=N+3
39342
39343 RETURN
39344 END
39345
39346C*********************************************************************
39347
39348C...PYCLUS
39349C...Subdivides the particle content of an event into jets/clusters.
39350
39351 SUBROUTINE PYCLUS(NJET)
39352
39353C...Double precision and integer declarations.
39354 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39355 INTEGER PYK,PYCHGE,PYCOMP
39356C...Commonblocks.
39357 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39358 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39359 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39360 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39361C...Local arrays and saved variables.
39362 DIMENSION PS(5)
39363 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
39364
39365C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
39366 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
39367 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
39368 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
39369 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39370 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
39371 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39372
39373C...If first time, reset. If reentering, skip preliminaries.
39374 IF(MSTU(48).LE.0) THEN
39375 NP=0
39376 DO 100 J=1,5
39377 PS(J)=0D0
39378 100 CONTINUE
39379 PSS=0D0
39380 PIMASS=PMAS(PYCOMP(211),1)
39381 ELSE
39382 NJET=NSAV
39383 IF(MSTU(43).GE.2) N=N-NJET
39384 DO 110 I=N+1,N+NJET
39385 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39386 110 CONTINUE
39387 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39388 R2ACC=PARU(44)**2
39389 ELSE
39390 R2ACC=PARU(45)*PS(5)**2
39391 ENDIF
39392 NLOOP=0
39393 GOTO 300
39394 ENDIF
39395
39396C...Find which particles are to be considered in cluster search.
39397 DO 140 I=1,N
39398 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39399 IF(MSTU(41).GE.2) THEN
39400 KC=PYCOMP(K(I,2))
39401 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39402 & KC.EQ.18) GOTO 140
39403 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39404 & GOTO 140
39405 ENDIF
39406 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
39407 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
39408 NJET=-1
39409 RETURN
39410 ENDIF
39411
39412C...Take copy of these particles, with space left for jets later on.
39413 NP=NP+1
39414 K(N+NP,3)=I
39415 DO 120 J=1,5
39416 P(N+NP,J)=P(I,J)
39417 120 CONTINUE
39418 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39419 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39420 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39421 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39422 DO 130 J=1,4
39423 PS(J)=PS(J)+P(N+NP,J)
39424 130 CONTINUE
39425 PSS=PSS+P(N+NP,5)
39426 140 CONTINUE
39427 DO 160 I=N+1,N+NP
39428 K(I+NP,3)=K(I,3)
39429 DO 150 J=1,5
39430 P(I+NP,J)=P(I,J)
39431 150 CONTINUE
39432 160 CONTINUE
39433 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
39434
39435C...Very low multiplicities not considered.
39436 IF(NP.LT.MSTU(47)) THEN
39437 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
39438 NJET=-1
39439 RETURN
39440 ENDIF
39441
39442C...Find precluster configuration. If too few jets, make harder cuts.
39443 NLOOP=0
39444 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39445 R2ACC=PARU(44)**2
39446 ELSE
39447 R2ACC=PARU(45)*PS(5)**2
39448 ENDIF
39449 RINIT=1.25D0*PARU(43)
39450 IF(NP.LE.MSTU(47)+2) RINIT=0D0
39451 170 RINIT=0.8D0*RINIT
39452 NPRE=0
39453 NREM=NP
39454 DO 180 I=N+NP+1,N+2*NP
39455 K(I,4)=0
39456 180 CONTINUE
39457
39458C...Sum up small momentum region. Jet if enough absolute momentum.
39459 IF(MSTU(46).LE.2) THEN
39460 DO 190 J=1,4
39461 P(N+1,J)=0D0
39462 190 CONTINUE
39463 DO 210 I=N+NP+1,N+2*NP
39464 IF(P(I,5).GT.2D0*RINIT) GOTO 210
39465 NREM=NREM-1
39466 K(I,4)=1
39467 DO 200 J=1,4
39468 P(N+1,J)=P(N+1,J)+P(I,J)
39469 200 CONTINUE
39470 210 CONTINUE
39471 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
39472 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
39473 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39474 IF(NREM.EQ.0) GOTO 170
39475 ENDIF
39476
39477C...Find fastest remaining particle.
39478 220 NPRE=NPRE+1
39479 PMAX=0D0
39480 DO 230 I=N+NP+1,N+2*NP
39481 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
39482 IMAX=I
39483 PMAX=P(I,5)
39484 230 CONTINUE
39485 DO 240 J=1,5
39486 P(N+NPRE,J)=P(IMAX,J)
39487 240 CONTINUE
39488 NREM=NREM-1
39489 K(IMAX,4)=NPRE
39490
39491C...Sum up precluster around it according to pT separation.
39492 IF(MSTU(46).LE.2) THEN
39493 DO 260 I=N+NP+1,N+2*NP
39494 IF(K(I,4).NE.0) GOTO 260
39495 R2=R2T(I,IMAX)
39496 IF(R2.GT.RINIT**2) GOTO 260
39497 NREM=NREM-1
39498 K(I,4)=NPRE
39499 DO 250 J=1,4
39500 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
39501 250 CONTINUE
39502 260 CONTINUE
39503 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39504
39505C...Sum up precluster around it according to mass or
39506C...Durham pT separation.
39507 ELSE
39508 270 IMIN=0
39509 R2MIN=RINIT**2
39510 DO 280 I=N+NP+1,N+2*NP
39511 IF(K(I,4).NE.0) GOTO 280
39512 IF(MSTU(46).LE.4) THEN
39513 R2=R2M(I,N+NPRE)
39514 ELSE
39515 R2=R2D(I,N+NPRE)
39516 ENDIF
39517 IF(R2.GE.R2MIN) GOTO 280
39518 IMIN=I
39519 R2MIN=R2
39520 280 CONTINUE
39521 IF(IMIN.NE.0) THEN
39522 DO 290 J=1,4
39523 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
39524 290 CONTINUE
39525 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39526 NREM=NREM-1
39527 K(IMIN,4)=NPRE
39528 GOTO 270
39529 ENDIF
39530 ENDIF
39531
39532C...Check if more preclusters to be found. Start over if too few.
39533 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39534 IF(NREM.GT.0) GOTO 220
39535 NJET=NPRE
39536
39537C...Reassign all particles to nearest jet. Sum up new jet momenta.
39538 300 TSAV=0D0
39539 PSJT=0D0
39540 310 IF(MSTU(46).LE.1) THEN
39541 DO 330 I=N+1,N+NJET
39542 DO 320 J=1,4
39543 V(I,J)=0D0
39544 320 CONTINUE
39545 330 CONTINUE
39546 DO 360 I=N+NP+1,N+2*NP
39547 R2MIN=PSS**2
39548 DO 340 IJET=N+1,N+NJET
39549 IF(P(IJET,5).LT.RINIT) GOTO 340
39550 R2=R2T(I,IJET)
39551 IF(R2.GE.R2MIN) GOTO 340
39552 IMIN=IJET
39553 R2MIN=R2
39554 340 CONTINUE
39555 K(I,4)=IMIN-N
39556 DO 350 J=1,4
39557 V(IMIN,J)=V(IMIN,J)+P(I,J)
39558 350 CONTINUE
39559 360 CONTINUE
39560 PSJT=0D0
39561 DO 380 I=N+1,N+NJET
39562 DO 370 J=1,4
39563 P(I,J)=V(I,J)
39564 370 CONTINUE
39565 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39566 PSJT=PSJT+P(I,5)
39567 380 CONTINUE
39568 ENDIF
39569
39570C...Find two closest jets.
39571 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
39572 DO 400 ITRY1=N+1,N+NJET-1
39573 DO 390 ITRY2=ITRY1+1,N+NJET
39574 IF(MSTU(46).LE.2) THEN
39575 R2=R2T(ITRY1,ITRY2)
39576 ELSEIF(MSTU(46).LE.4) THEN
39577 R2=R2M(ITRY1,ITRY2)
39578 ELSE
39579 R2=R2D(ITRY1,ITRY2)
39580 ENDIF
39581 IF(R2.GE.R2MIN) GOTO 390
39582 IMIN1=ITRY1
39583 IMIN2=ITRY2
39584 R2MIN=R2
39585 390 CONTINUE
39586 400 CONTINUE
39587
39588C...If allowed, join two closest jets and start over.
39589 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
39590 IREC=MIN(IMIN1,IMIN2)
39591 IDEL=MAX(IMIN1,IMIN2)
39592 DO 410 J=1,4
39593 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
39594 410 CONTINUE
39595 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
39596 DO 430 I=IDEL+1,N+NJET
39597 DO 420 J=1,5
39598 P(I-1,J)=P(I,J)
39599 420 CONTINUE
39600 430 CONTINUE
39601 IF(MSTU(46).GE.2) THEN
39602 DO 440 I=N+NP+1,N+2*NP
39603 IORI=N+K(I,4)
39604 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
39605 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
39606 440 CONTINUE
39607 ENDIF
39608 NJET=NJET-1
39609 GOTO 300
39610
39611C...Divide up broad jet if empty cluster in list of final ones.
39612 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
39613 DO 450 I=N+1,N+NJET
39614 K(I,5)=0
39615 450 CONTINUE
39616 DO 460 I=N+NP+1,N+2*NP
39617 K(N+K(I,4),5)=K(N+K(I,4),5)+1
39618 460 CONTINUE
39619 IEMP=0
39620 DO 470 I=N+1,N+NJET
39621 IF(K(I,5).EQ.0) IEMP=I
39622 470 CONTINUE
39623 IF(IEMP.NE.0) THEN
39624 NLOOP=NLOOP+1
39625 ISPL=0
39626 R2MAX=0D0
39627 DO 480 I=N+NP+1,N+2*NP
39628 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
39629 IJET=N+K(I,4)
39630 R2=R2T(I,IJET)
39631 IF(R2.LE.R2MAX) GOTO 480
39632 ISPL=I
39633 R2MAX=R2
39634 480 CONTINUE
39635 IF(ISPL.NE.0) THEN
39636 IJET=N+K(ISPL,4)
39637 DO 490 J=1,4
39638 P(IEMP,J)=P(ISPL,J)
39639 P(IJET,J)=P(IJET,J)-P(ISPL,J)
39640 490 CONTINUE
39641 P(IEMP,5)=P(ISPL,5)
39642 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
39643 IF(NLOOP.LE.2) GOTO 300
39644 ENDIF
39645 ENDIF
39646 ENDIF
39647
39648C...If generalized thrust has not yet converged, continue iteration.
39649 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
39650 &THEN
39651 TSAV=PSJT/PSS
39652 GOTO 310
39653 ENDIF
39654
39655C...Reorder jets according to energy.
39656 DO 510 I=N+1,N+NJET
39657 DO 500 J=1,5
39658 V(I,J)=P(I,J)
39659 500 CONTINUE
39660 510 CONTINUE
39661 DO 540 INEW=N+1,N+NJET
39662 PEMAX=0D0
39663 DO 520 ITRY=N+1,N+NJET
39664 IF(V(ITRY,4).LE.PEMAX) GOTO 520
39665 IMAX=ITRY
39666 PEMAX=V(ITRY,4)
39667 520 CONTINUE
39668 K(INEW,1)=31
39669 K(INEW,2)=97
39670 K(INEW,3)=INEW-N
39671 K(INEW,4)=0
39672 DO 530 J=1,5
39673 P(INEW,J)=V(IMAX,J)
39674 530 CONTINUE
39675 V(IMAX,4)=-1D0
39676 K(IMAX,5)=INEW
39677 540 CONTINUE
39678
39679C...Clean up particle-jet assignments and jet information.
39680 DO 550 I=N+NP+1,N+2*NP
39681 IORI=K(N+K(I,4),5)
39682 K(I,4)=IORI-N
39683 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
39684 K(IORI,4)=K(IORI,4)+1
39685 550 CONTINUE
39686 IEMP=0
39687 PSJT=0D0
39688 DO 570 I=N+1,N+NJET
39689 K(I,5)=0
39690 PSJT=PSJT+P(I,5)
39691 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
39692 DO 560 J=1,5
39693 V(I,J)=0D0
39694 560 CONTINUE
39695 IF(K(I,4).EQ.0) IEMP=I
39696 570 CONTINUE
39697
39698C...Select storing option. Output variables. Check for failure.
39699 MSTU(61)=N+1
39700 MSTU(62)=NP
39701 MSTU(63)=NPRE
39702 PARU(61)=PS(5)
39703 PARU(62)=PSJT/PSS
39704 PARU(63)=SQRT(R2MIN)
39705 IF(NJET.LE.1) PARU(63)=0D0
39706 IF(IEMP.NE.0) THEN
39707 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
39708 NJET=-1
39709 ENDIF
39710 IF(MSTU(43).LE.1) MSTU(3)=NJET
39711 IF(MSTU(43).GE.2) N=N+NJET
39712 NSAV=NJET
39713
39714 RETURN
39715 END
39716
39717C*********************************************************************
39718
39719C...PYCELL
39720C...Provides a simple way of jet finding in eta-phi-ET coordinates,
39721C...as used for calorimeters at hadron colliders.
39722
39723 SUBROUTINE PYCELL(NJET)
39724
39725C...Double precision and integer declarations.
39726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39727 INTEGER PYK,PYCHGE,PYCOMP
39728C...Commonblocks.
39729 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39730 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39731 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39732 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39733
39734C...Loop over all particles. Find cell that was hit by given particle.
39735 PTLRAT=1D0/SINH(PARU(51))**2
39736 NP=0
39737 NC=N
39738 DO 110 I=1,N
39739 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
39740 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
39741 IF(MSTU(41).GE.2) THEN
39742 KC=PYCOMP(K(I,2))
39743 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39744 & KC.EQ.18) GOTO 110
39745 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39746 & GOTO 110
39747 ENDIF
39748 NP=NP+1
39749 PT=SQRT(P(I,1)**2+P(I,2)**2)
39750 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
39751 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
39752 & (ETA/PARU(51)+1D0))))
39753 PHI=PYANGL(P(I,1),P(I,2))
39754 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
39755 & (PHI/PARU(1)+1D0))))
39756 IETPH=MSTU(52)*IETA+IPHI
39757
39758C...Add to cell already hit, or book new cell.
39759 DO 100 IC=N+1,NC
39760 IF(IETPH.EQ.K(IC,3)) THEN
39761 K(IC,4)=K(IC,4)+1
39762 P(IC,5)=P(IC,5)+PT
39763 GOTO 110
39764 ENDIF
39765 100 CONTINUE
39766 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
39767 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
39768 NJET=-2
39769 RETURN
39770 ENDIF
39771 NC=NC+1
39772 K(NC,3)=IETPH
39773 K(NC,4)=1
39774 K(NC,5)=2
39775 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
39776 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
39777 P(NC,5)=PT
39778 110 CONTINUE
39779
39780C...Smear true bin content by calorimeter resolution.
39781 IF(MSTU(53).GE.1) THEN
39782 DO 130 IC=N+1,NC
39783 PEI=P(IC,5)
39784 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
39785 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
39786 & COS(PARU(2)*PYR(0))
39787 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
39788 P(IC,5)=PEF
39789 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
39790 130 CONTINUE
39791 ENDIF
39792
39793C...Remove cells below threshold.
39794 IF(PARU(58).GT.0D0) THEN
39795 NCC=NC
39796 NC=N
39797 DO 140 IC=N+1,NCC
39798 IF(P(IC,5).GT.PARU(58)) THEN
39799 NC=NC+1
39800 K(NC,3)=K(IC,3)
39801 K(NC,4)=K(IC,4)
39802 K(NC,5)=K(IC,5)
39803 P(NC,1)=P(IC,1)
39804 P(NC,2)=P(IC,2)
39805 P(NC,5)=P(IC,5)
39806 ENDIF
39807 140 CONTINUE
39808 ENDIF
39809
39810C...Find initiator cell: the one with highest pT of not yet used ones.
39811 NJ=NC
39812 150 ETMAX=0D0
39813 DO 160 IC=N+1,NC
39814 IF(K(IC,5).NE.2) GOTO 160
39815 IF(P(IC,5).LE.ETMAX) GOTO 160
39816 ICMAX=IC
39817 ETA=P(IC,1)
39818 PHI=P(IC,2)
39819 ETMAX=P(IC,5)
39820 160 CONTINUE
39821 IF(ETMAX.LT.PARU(52)) GOTO 220
39822 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
39823 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
39824 NJET=-2
39825 RETURN
39826 ENDIF
39827 K(ICMAX,5)=1
39828 NJ=NJ+1
39829 K(NJ,4)=0
39830 K(NJ,5)=1
39831 P(NJ,1)=ETA
39832 P(NJ,2)=PHI
39833 P(NJ,3)=0D0
39834 P(NJ,4)=0D0
39835 P(NJ,5)=0D0
39836
39837C...Sum up unused cells within required distance of initiator.
39838 DO 170 IC=N+1,NC
39839 IF(K(IC,5).EQ.0) GOTO 170
39840 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
39841 DPHIA=ABS(P(IC,2)-PHI)
39842 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
39843 PHIC=P(IC,2)
39844 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
39845 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
39846 K(IC,5)=-K(IC,5)
39847 K(NJ,4)=K(NJ,4)+K(IC,4)
39848 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
39849 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
39850 P(NJ,5)=P(NJ,5)+P(IC,5)
39851 170 CONTINUE
39852
39853C...Reject cluster below minimum ET, else accept.
39854 IF(P(NJ,5).LT.PARU(53)) THEN
39855 NJ=NJ-1
39856 DO 180 IC=N+1,NC
39857 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
39858 180 CONTINUE
39859 ELSEIF(MSTU(54).LE.2) THEN
39860 P(NJ,3)=P(NJ,3)/P(NJ,5)
39861 P(NJ,4)=P(NJ,4)/P(NJ,5)
39862 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
39863 & P(NJ,4))
39864 DO 190 IC=N+1,NC
39865 IF(K(IC,5).LT.0) K(IC,5)=0
39866 190 CONTINUE
39867 ELSE
39868 DO 200 J=1,4
39869 P(NJ,J)=0D0
39870 200 CONTINUE
39871 DO 210 IC=N+1,NC
39872 IF(K(IC,5).GE.0) GOTO 210
39873 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
39874 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
39875 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
39876 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
39877 K(IC,5)=0
39878 210 CONTINUE
39879 ENDIF
39880 GOTO 150
39881
39882C...Arrange clusters in falling ET sequence.
39883 220 DO 250 I=1,NJ-NC
39884 ETMAX=0D0
39885 DO 230 IJ=NC+1,NJ
39886 IF(K(IJ,5).EQ.0) GOTO 230
39887 IF(P(IJ,5).LT.ETMAX) GOTO 230
39888 IJMAX=IJ
39889 ETMAX=P(IJ,5)
39890 230 CONTINUE
39891 K(IJMAX,5)=0
39892 K(N+I,1)=31
39893 K(N+I,2)=98
39894 K(N+I,3)=I
39895 K(N+I,4)=K(IJMAX,4)
39896 K(N+I,5)=0
39897 DO 240 J=1,5
39898 P(N+I,J)=P(IJMAX,J)
39899 V(N+I,J)=0D0
39900 240 CONTINUE
39901 250 CONTINUE
39902 NJET=NJ-NC
39903
39904C...Convert to massless or massive four-vectors.
39905 IF(MSTU(54).EQ.2) THEN
39906 DO 260 I=N+1,N+NJET
39907 ETA=P(I,3)
39908 P(I,1)=P(I,5)*COS(P(I,4))
39909 P(I,2)=P(I,5)*SIN(P(I,4))
39910 P(I,3)=P(I,5)*SINH(ETA)
39911 P(I,4)=P(I,5)*COSH(ETA)
39912 P(I,5)=0D0
39913 260 CONTINUE
39914 ELSEIF(MSTU(54).GE.3) THEN
39915 DO 270 I=N+1,N+NJET
39916 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
39917 270 CONTINUE
39918 ENDIF
39919
39920C...Information about storage.
39921 MSTU(61)=N+1
39922 MSTU(62)=NP
39923 MSTU(63)=NC-N
39924 IF(MSTU(43).LE.1) MSTU(3)=NJET
39925 IF(MSTU(43).GE.2) N=N+NJET
39926
39927 RETURN
39928 END
39929
39930C*********************************************************************
39931
39932C...PYJMAS
39933C...Determines, approximately, the two jet masses that minimize
39934C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
39935
39936 SUBROUTINE PYJMAS(PMH,PML)
39937
39938C...Double precision and integer declarations.
39939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39940 INTEGER PYK,PYCHGE,PYCOMP
39941C...Commonblocks.
39942 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39943 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39944 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39945 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39946C...Local arrays.
39947 DIMENSION SM(3,3),SAX(3),PS(3,5)
39948
39949C...Reset.
39950 NP=0
39951 DO 120 J1=1,3
39952 DO 100 J2=J1,3
39953 SM(J1,J2)=0D0
39954 100 CONTINUE
39955 DO 110 J2=1,4
39956 PS(J1,J2)=0D0
39957 110 CONTINUE
39958 120 CONTINUE
39959 PSS=0D0
39960 PIMASS=PMAS(PYCOMP(211),1)
39961
39962C...Take copy of particles that are to be considered in mass analysis.
39963 DO 170 I=1,N
39964 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
39965 IF(MSTU(41).GE.2) THEN
39966 KC=PYCOMP(K(I,2))
39967 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39968 & KC.EQ.18) GOTO 170
39969 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39970 & GOTO 170
39971 ENDIF
39972 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
39973 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
39974 PMH=-2D0
39975 PML=-2D0
39976 RETURN
39977 ENDIF
39978 NP=NP+1
39979 DO 130 J=1,5
39980 P(N+NP,J)=P(I,J)
39981 130 CONTINUE
39982 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39983 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39984 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39985
39986C...Fill information in sphericity tensor and total momentum vector.
39987 DO 150 J1=1,3
39988 DO 140 J2=J1,3
39989 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
39990 140 CONTINUE
39991 150 CONTINUE
39992 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39993 DO 160 J=1,4
39994 PS(3,J)=PS(3,J)+P(N+NP,J)
39995 160 CONTINUE
39996 170 CONTINUE
39997
39998C...Very low multiplicities (0 or 1) not considered.
39999 IF(NP.LE.1) THEN
40000 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
40001 PMH=-1D0
40002 PML=-1D0
40003 RETURN
40004 ENDIF
40005 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
40006 &PS(3,3)**2))
40007
40008C...Find largest eigenvalue to matrix (third degree equation).
40009 DO 190 J1=1,3
40010 DO 180 J2=J1,3
40011 SM(J1,J2)=SM(J1,J2)/PSS
40012 180 CONTINUE
40013 190 CONTINUE
40014 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
40015 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
40016 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
40017 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
40018 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
40019 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
40020 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
40021
40022C...Find largest eigenvector by solving equation system.
40023 DO 210 J1=1,3
40024 SM(J1,J1)=SM(J1,J1)-SMA
40025 DO 200 J2=J1+1,3
40026 SM(J2,J1)=SM(J1,J2)
40027 200 CONTINUE
40028 210 CONTINUE
40029 SMAX=0D0
40030 DO 230 J1=1,3
40031 DO 220 J2=1,3
40032 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
40033 JA=J1
40034 JB=J2
40035 SMAX=ABS(SM(J1,J2))
40036 220 CONTINUE
40037 230 CONTINUE
40038 SMAX=0D0
40039 DO 250 J3=JA+1,JA+2
40040 J1=J3-3*((J3-1)/3)
40041 RL=SM(J1,JB)/SM(JA,JB)
40042 DO 240 J2=1,3
40043 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
40044 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
40045 JC=J1
40046 SMAX=ABS(SM(J1,J2))
40047 240 CONTINUE
40048 250 CONTINUE
40049 JB1=JB+1-3*(JB/3)
40050 JB2=JB+2-3*((JB+1)/3)
40051 SAX(JB1)=-SM(JC,JB2)
40052 SAX(JB2)=SM(JC,JB1)
40053 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
40054
40055C...Divide particles into two initial clusters by hemisphere.
40056 DO 270 I=N+1,N+NP
40057 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
40058 IS=1
40059 IF(PSAX.LT.0D0) IS=2
40060 K(I,3)=IS
40061 DO 260 J=1,4
40062 PS(IS,J)=PS(IS,J)+P(I,J)
40063 260 CONTINUE
40064 270 CONTINUE
40065 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
40066 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
40067
40068C...Reassign one particle at a time; find maximum decrease of m^2 sum.
40069 280 PMD=0D0
40070 IM=0
40071 DO 290 J=1,4
40072 PS(3,J)=PS(1,J)-PS(2,J)
40073 290 CONTINUE
40074 DO 300 I=N+1,N+NP
40075 PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
40076 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
40077 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
40078 IF(PMDI.LT.PMD) THEN
40079 PMD=PMDI
40080 IM=I
40081 ENDIF
40082 300 CONTINUE
40083
40084C...Loop back if significant reduction in sum of m^2.
40085 IF(PMD.LT.-PARU(48)*PMS) THEN
40086 PMS=PMS+PMD
40087 IS=K(IM,3)
40088 DO 310 J=1,4
40089 PS(IS,J)=PS(IS,J)-P(IM,J)
40090 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
40091 310 CONTINUE
40092 K(IM,3)=3-IS
40093 GOTO 280
40094 ENDIF
40095
40096C...Final masses and output.
40097 MSTU(61)=N+1
40098 MSTU(62)=NP
40099 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
40100 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
40101 PMH=MAX(PS(1,5),PS(2,5))
40102 PML=MIN(PS(1,5),PS(2,5))
40103
40104 RETURN
40105 END
40106
40107C*********************************************************************
40108
40109C...PYFOWO
40110C...Calculates the first few Fox-Wolfram moments.
40111
40112 SUBROUTINE PYFOWO(H10,H20,H30,H40)
40113
40114C...Double precision and integer declarations.
40115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40116 INTEGER PYK,PYCHGE,PYCOMP
40117C...Commonblocks.
40118 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40119 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40120 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40121 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40122
40123C...Copy momenta for particles and calculate H0.
40124 NP=0
40125 H0=0D0
40126 HD=0D0
40127 DO 110 I=1,N
40128 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
40129 IF(MSTU(41).GE.2) THEN
40130 KC=PYCOMP(K(I,2))
40131 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40132 & KC.EQ.18) GOTO 110
40133 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40134 & GOTO 110
40135 ENDIF
40136 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
40137 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
40138 H10=-1D0
40139 H20=-1D0
40140 H30=-1D0
40141 H40=-1D0
40142 RETURN
40143 ENDIF
40144 NP=NP+1
40145 DO 100 J=1,3
40146 P(N+NP,J)=P(I,J)
40147 100 CONTINUE
40148 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40149 H0=H0+P(N+NP,4)
40150 HD=HD+P(N+NP,4)**2
40151 110 CONTINUE
40152 H0=H0**2
40153
40154C...Very low multiplicities (0 or 1) not considered.
40155 IF(NP.LE.1) THEN
40156 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
40157 H10=-1D0
40158 H20=-1D0
40159 H30=-1D0
40160 H40=-1D0
40161 RETURN
40162 ENDIF
40163
40164C...Calculate H1 - H4.
40165 H10=0D0
40166 H20=0D0
40167 H30=0D0
40168 H40=0D0
40169 DO 130 I1=N+1,N+NP
40170 DO 120 I2=I1+1,N+NP
40171 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40172 & (P(I1,4)*P(I2,4))
40173 H10=H10+P(I1,4)*P(I2,4)*CTHE
40174 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
40175 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
40176 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
40177 & 0.375D0)
40178 120 CONTINUE
40179 130 CONTINUE
40180
40181C...Calculate H1/H0 - H4/H0. Output.
40182 MSTU(61)=N+1
40183 MSTU(62)=NP
40184 H10=(HD+2D0*H10)/H0
40185 H20=(HD+2D0*H20)/H0
40186 H30=(HD+2D0*H30)/H0
40187 H40=(HD+2D0*H40)/H0
40188
40189 RETURN
40190 END
40191
40192C*********************************************************************
40193
40194C...PYTABU
40195C...Evaluates various properties of an event, with statistics
40196C...accumulated during the course of the run and
40197C...printed at the end.
40198
40199 SUBROUTINE PYTABU(MTABU)
40200
40201C...Double precision and integer declarations.
40202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40203 INTEGER PYK,PYCHGE,PYCOMP
40204C...Commonblocks.
40205 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40206 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40207 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40208 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
40209 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
40210C...Local arrays, character variables, saved variables and data.
40211 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
40212 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
40213 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
40214 &KFDM(8),KFDC(200,0:8),NPDC(200)
40215 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
40216 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
40217 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
40218 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
40219 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
40220 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
40221 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
40222 &NEVDC/0/,NKFDC/0/,NREDC/0/
40223
40224C...Reset statistics on initial parton state.
40225 IF(MTABU.EQ.10) THEN
40226 NEVIS=0
40227 NKFIS=0
40228
40229C...Identify and order flavour content of initial state.
40230 ELSEIF(MTABU.EQ.11) THEN
40231 NEVIS=NEVIS+1
40232 KFM1=2*IABS(MSTU(161))
40233 IF(MSTU(161).GT.0) KFM1=KFM1-1
40234 KFM2=2*IABS(MSTU(162))
40235 IF(MSTU(162).GT.0) KFM2=KFM2-1
40236 KFMN=MIN(KFM1,KFM2)
40237 KFMX=MAX(KFM1,KFM2)
40238 DO 100 I=1,NKFIS
40239 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
40240 IKFIS=-I
40241 GOTO 110
40242 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
40243 & KFMX.LT.KFIS(I,2))) THEN
40244 IKFIS=I
40245 GOTO 110
40246 ENDIF
40247 100 CONTINUE
40248 IKFIS=NKFIS+1
40249 110 IF(IKFIS.LT.0) THEN
40250 IKFIS=-IKFIS
40251 ELSE
40252 IF(NKFIS.GE.100) RETURN
40253 DO 130 I=NKFIS,IKFIS,-1
40254 KFIS(I+1,1)=KFIS(I,1)
40255 KFIS(I+1,2)=KFIS(I,2)
40256 DO 120 J=0,10
40257 NPIS(I+1,J)=NPIS(I,J)
40258 120 CONTINUE
40259 130 CONTINUE
40260 NKFIS=NKFIS+1
40261 KFIS(IKFIS,1)=KFMN
40262 KFIS(IKFIS,2)=KFMX
40263 DO 140 J=0,10
40264 NPIS(IKFIS,J)=0
40265 140 CONTINUE
40266 ENDIF
40267 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
40268
40269C...Count number of partons in initial state.
40270 NP=0
40271 DO 160 I=1,N
40272 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
40273 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
40274 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
40275 & THEN
40276 ELSE
40277 IM=I
40278 150 IM=K(IM,3)
40279 IF(IM.LE.0.OR.IM.GT.N) THEN
40280 NP=NP+1
40281 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40282 NP=NP+1
40283 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
40284 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
40285 & .NE.0) THEN
40286 ELSE
40287 GOTO 150
40288 ENDIF
40289 ENDIF
40290 160 CONTINUE
40291 NPCO=MAX(NP,1)
40292 IF(NP.GE.6) NPCO=6
40293 IF(NP.GE.8) NPCO=7
40294 IF(NP.GE.11) NPCO=8
40295 IF(NP.GE.16) NPCO=9
40296 IF(NP.GE.26) NPCO=10
40297 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
40298 MSTU(62)=NP
40299
40300C...Write statistics on initial parton state.
40301 ELSEIF(MTABU.EQ.12) THEN
40302 FAC=1D0/MAX(1,NEVIS)
40303 WRITE(MSTU(11),5000) NEVIS
40304 DO 170 I=1,NKFIS
40305 KFMN=KFIS(I,1)
40306 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40307 KFM1=(KFMN+1)/2
40308 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40309 CALL PYNAME(KFM1,CHAU)
40310 CHIS(1)=CHAU(1:12)
40311 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
40312 KFMX=KFIS(I,2)
40313 IF(KFIS(I,1).EQ.0) KFMX=0
40314 KFM2=(KFMX+1)/2
40315 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40316 CALL PYNAME(KFM2,CHAU)
40317 CHIS(2)=CHAU(1:12)
40318 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
40319 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
40320 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
40321 170 CONTINUE
40322
40323C...Copy statistics on initial parton state into /PYJETS/.
40324 ELSEIF(MTABU.EQ.13) THEN
40325 FAC=1D0/MAX(1,NEVIS)
40326 DO 190 I=1,NKFIS
40327 KFMN=KFIS(I,1)
40328 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40329 KFM1=(KFMN+1)/2
40330 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40331 KFMX=KFIS(I,2)
40332 IF(KFIS(I,1).EQ.0) KFMX=0
40333 KFM2=(KFMX+1)/2
40334 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40335 K(I,1)=32
40336 K(I,2)=99
40337 K(I,3)=KFM1
40338 K(I,4)=KFM2
40339 K(I,5)=NPIS(I,0)
40340 DO 180 J=1,5
40341 P(I,J)=FAC*NPIS(I,J)
40342 V(I,J)=FAC*NPIS(I,J+5)
40343 180 CONTINUE
40344 190 CONTINUE
40345 N=NKFIS
40346 DO 200 J=1,5
40347 K(N+1,J)=0
40348 P(N+1,J)=0D0
40349 V(N+1,J)=0D0
40350 200 CONTINUE
40351 K(N+1,1)=32
40352 K(N+1,2)=99
40353 K(N+1,5)=NEVIS
40354 MSTU(3)=1
40355
40356C...Reset statistics on number of particles/partons.
40357 ELSEIF(MTABU.EQ.20) THEN
40358 NEVFS=0
40359 NPRFS=0
40360 NFIFS=0
40361 NCHFS=0
40362 NKFFS=0
40363
40364C...Identify whether particle/parton is primary or not.
40365 ELSEIF(MTABU.EQ.21) THEN
40366 NEVFS=NEVFS+1
40367 MSTU(62)=0
40368 DO 260 I=1,N
40369 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
40370 MSTU(62)=MSTU(62)+1
40371 KC=PYCOMP(K(I,2))
40372 MPRI=0
40373 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
40374 MPRI=1
40375 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
40376 MPRI=1
40377 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
40378 MPRI=1
40379 ELSEIF(KC.EQ.0) THEN
40380 ELSEIF(K(K(I,3),1).EQ.13) THEN
40381 IM=K(K(I,3),3)
40382 IF(IM.LE.0.OR.IM.GT.N) THEN
40383 MPRI=1
40384 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40385 MPRI=1
40386 ENDIF
40387 ELSEIF(KCHG(KC,2).EQ.0) THEN
40388 KCM=PYCOMP(K(K(I,3),2))
40389 IF(KCM.NE.0) THEN
40390 IF(KCHG(KCM,2).NE.0) MPRI=1
40391 ENDIF
40392 ENDIF
40393 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
40394 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
40395 ENDIF
40396 IF(K(I,1).LE.10) THEN
40397 NFIFS=NFIFS+1
40398 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
40399 ENDIF
40400
40401C...Fill statistics on number of particles/partons in event.
40402 KFA=IABS(K(I,2))
40403 KFS=3-ISIGN(1,K(I,2))-MPRI
40404 DO 210 IP=1,NKFFS
40405 IF(KFA.EQ.KFFS(IP)) THEN
40406 IKFFS=-IP
40407 GOTO 220
40408 ELSEIF(KFA.LT.KFFS(IP)) THEN
40409 IKFFS=IP
40410 GOTO 220
40411 ENDIF
40412 210 CONTINUE
40413 IKFFS=NKFFS+1
40414 220 IF(IKFFS.LT.0) THEN
40415 IKFFS=-IKFFS
40416 ELSE
40417 IF(NKFFS.GE.400) RETURN
40418 DO 240 IP=NKFFS,IKFFS,-1
40419 KFFS(IP+1)=KFFS(IP)
40420 DO 230 J=1,4
40421 NPFS(IP+1,J)=NPFS(IP,J)
40422 230 CONTINUE
40423 240 CONTINUE
40424 NKFFS=NKFFS+1
40425 KFFS(IKFFS)=KFA
40426 DO 250 J=1,4
40427 NPFS(IKFFS,J)=0
40428 250 CONTINUE
40429 ENDIF
40430 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
40431 260 CONTINUE
40432
40433C...Write statistics on particle/parton composition of events.
40434 ELSEIF(MTABU.EQ.22) THEN
40435 FAC=1D0/MAX(1,NEVFS)
40436 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
40437 DO 270 I=1,NKFFS
40438 CALL PYNAME(KFFS(I),CHAU)
40439 KC=PYCOMP(KFFS(I))
40440 MDCYF=0
40441 IF(KC.NE.0) MDCYF=MDCY(KC,1)
40442 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
40443 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
40444 270 CONTINUE
40445
40446C...Copy particle/parton composition information into /PYJETS/.
40447 ELSEIF(MTABU.EQ.23) THEN
40448 FAC=1D0/MAX(1,NEVFS)
40449 DO 290 I=1,NKFFS
40450 K(I,1)=32
40451 K(I,2)=99
40452 K(I,3)=KFFS(I)
40453 K(I,4)=0
40454 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
40455 DO 280 J=1,4
40456 P(I,J)=FAC*NPFS(I,J)
40457 V(I,J)=0D0
40458 280 CONTINUE
40459 P(I,5)=FAC*K(I,5)
40460 V(I,5)=0D0
40461 290 CONTINUE
40462 N=NKFFS
40463 DO 300 J=1,5
40464 K(N+1,J)=0
40465 P(N+1,J)=0D0
40466 V(N+1,J)=0D0
40467 300 CONTINUE
40468 K(N+1,1)=32
40469 K(N+1,2)=99
40470 K(N+1,5)=NEVFS
40471 P(N+1,1)=FAC*NPRFS
40472 P(N+1,2)=FAC*NFIFS
40473 P(N+1,3)=FAC*NCHFS
40474 MSTU(3)=1
40475
40476C...Reset factorial moments statistics.
40477 ELSEIF(MTABU.EQ.30) THEN
40478 NEVFM=0
40479 NMUFM=0
40480 DO 330 IM=1,3
40481 DO 320 IB=1,10
40482 DO 310 IP=1,4
40483 FM1FM(IM,IB,IP)=0D0
40484 FM2FM(IM,IB,IP)=0D0
40485 310 CONTINUE
40486 320 CONTINUE
40487 330 CONTINUE
40488
40489C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
40490 ELSEIF(MTABU.EQ.31) THEN
40491 NEVFM=NEVFM+1
40492 NLOW=N+MSTU(3)
40493 NUPP=NLOW
40494 DO 410 I=1,N
40495 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
40496 IF(MSTU(41).GE.2) THEN
40497 KC=PYCOMP(K(I,2))
40498 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40499 & KC.EQ.18) GOTO 410
40500 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40501 & PYCHGE(K(I,2)).EQ.0) GOTO 410
40502 ENDIF
40503 PMR=0D0
40504 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40505 IF(MSTU(42).GE.2) PMR=P(I,5)
40506 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
40507 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
40508 & 1D20)),P(I,3))
40509 IF(ABS(YETA).GT.PARU(57)) GOTO 410
40510 PHI=PYANGL(P(I,1),P(I,2))
40511 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
40512 IYETA=MAX(0,MIN(511,IYETA))
40513 IPHI=512D0*(PHI+PARU(1))/PARU(2)
40514 IPHI=MAX(0,MIN(511,IPHI))
40515 IYEP=0
40516 DO 340 IB=0,9
40517 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
40518 340 CONTINUE
40519
40520C...Order particles in (pseudo)rapidity and/or azimuth.
40521 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40522 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40523 RETURN
40524 ENDIF
40525 NUPP=NUPP+1
40526 IF(NUPP.EQ.NLOW+1) THEN
40527 K(NUPP,1)=IYETA
40528 K(NUPP,2)=IPHI
40529 K(NUPP,3)=IYEP
40530 ELSE
40531 DO 350 I1=NUPP-1,NLOW+1,-1
40532 IF(IYETA.GE.K(I1,1)) GOTO 360
40533 K(I1+1,1)=K(I1,1)
40534 350 CONTINUE
40535 360 K(I1+1,1)=IYETA
40536 DO 370 I1=NUPP-1,NLOW+1,-1
40537 IF(IPHI.GE.K(I1,2)) GOTO 380
40538 K(I1+1,2)=K(I1,2)
40539 370 CONTINUE
40540 380 K(I1+1,2)=IPHI
40541 DO 390 I1=NUPP-1,NLOW+1,-1
40542 IF(IYEP.GE.K(I1,3)) GOTO 400
40543 K(I1+1,3)=K(I1,3)
40544 390 CONTINUE
40545 400 K(I1+1,3)=IYEP
40546 ENDIF
40547 410 CONTINUE
40548 K(NUPP+1,1)=2**10
40549 K(NUPP+1,2)=2**10
40550 K(NUPP+1,3)=4**10
40551
40552C...Calculate sum of factorial moments in event.
40553 DO 480 IM=1,3
40554 DO 430 IB=1,10
40555 DO 420 IP=1,4
40556 FEVFM(IB,IP)=0D0
40557 420 CONTINUE
40558 430 CONTINUE
40559 DO 450 IB=1,10
40560 IF(IM.LE.2) IBIN=2**(10-IB)
40561 IF(IM.EQ.3) IBIN=4**(10-IB)
40562 IAGR=K(NLOW+1,IM)/IBIN
40563 NAGR=1
40564 DO 440 I=NLOW+2,NUPP+1
40565 ICUT=K(I,IM)/IBIN
40566 IF(ICUT.EQ.IAGR) THEN
40567 NAGR=NAGR+1
40568 ELSE
40569 IF(NAGR.EQ.1) THEN
40570 ELSEIF(NAGR.EQ.2) THEN
40571 FEVFM(IB,1)=FEVFM(IB,1)+2D0
40572 ELSEIF(NAGR.EQ.3) THEN
40573 FEVFM(IB,1)=FEVFM(IB,1)+6D0
40574 FEVFM(IB,2)=FEVFM(IB,2)+6D0
40575 ELSEIF(NAGR.EQ.4) THEN
40576 FEVFM(IB,1)=FEVFM(IB,1)+12D0
40577 FEVFM(IB,2)=FEVFM(IB,2)+24D0
40578 FEVFM(IB,3)=FEVFM(IB,3)+24D0
40579 ELSE
40580 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
40581 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
40582 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40583 & (NAGR-3D0)
40584 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40585 & (NAGR-3D0)*(NAGR-4D0)
40586 ENDIF
40587 IAGR=ICUT
40588 NAGR=1
40589 ENDIF
40590 440 CONTINUE
40591 450 CONTINUE
40592
40593C...Add results to total statistics.
40594 DO 470 IB=10,1,-1
40595 DO 460 IP=1,4
40596 IF(FEVFM(1,IP).LT.0.5D0) THEN
40597 FEVFM(IB,IP)=0D0
40598 ELSEIF(IM.LE.2) THEN
40599 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40600 ELSE
40601 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40602 ENDIF
40603 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
40604 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
40605 460 CONTINUE
40606 470 CONTINUE
40607 480 CONTINUE
40608 NMUFM=NMUFM+(NUPP-NLOW)
40609 MSTU(62)=NUPP-NLOW
40610
40611C...Write accumulated statistics on factorial moments.
40612 ELSEIF(MTABU.EQ.32) THEN
40613 FAC=1D0/MAX(1,NEVFM)
40614 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
40615 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
40616 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
40617 DO 510 IM=1,3
40618 WRITE(MSTU(11),5500)
40619 DO 500 IB=1,10
40620 BYETA=2D0*PARU(57)
40621 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
40622 BPHI=PARU(2)
40623 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
40624 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
40625 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
40626 DO 490 IP=1,4
40627 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
40628 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40629 & FMOMA(IP)**2)))
40630 490 CONTINUE
40631 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
40632 & IP=1,4)
40633 500 CONTINUE
40634 510 CONTINUE
40635
40636C...Copy statistics on factorial moments into /PYJETS/.
40637 ELSEIF(MTABU.EQ.33) THEN
40638 FAC=1D0/MAX(1,NEVFM)
40639 DO 540 IM=1,3
40640 DO 530 IB=1,10
40641 I=10*(IM-1)+IB
40642 K(I,1)=32
40643 K(I,2)=99
40644 K(I,3)=1
40645 IF(IM.NE.2) K(I,3)=2**(IB-1)
40646 K(I,4)=1
40647 IF(IM.NE.1) K(I,4)=2**(IB-1)
40648 K(I,5)=0
40649 P(I,1)=2D0*PARU(57)/K(I,3)
40650 V(I,1)=PARU(2)/K(I,4)
40651 DO 520 IP=1,4
40652 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
40653 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40654 & P(I,IP+1)**2)))
40655 520 CONTINUE
40656 530 CONTINUE
40657 540 CONTINUE
40658 N=30
40659 DO 550 J=1,5
40660 K(N+1,J)=0
40661 P(N+1,J)=0D0
40662 V(N+1,J)=0D0
40663 550 CONTINUE
40664 K(N+1,1)=32
40665 K(N+1,2)=99
40666 K(N+1,5)=NEVFM
40667 MSTU(3)=1
40668
40669C...Reset statistics on Energy-Energy Correlation.
40670 ELSEIF(MTABU.EQ.40) THEN
40671 NEVEE=0
40672 DO 560 J=1,25
40673 FE1EC(J)=0D0
40674 FE2EC(J)=0D0
40675 FE1EC(51-J)=0D0
40676 FE2EC(51-J)=0D0
40677 FE1EA(J)=0D0
40678 FE2EA(J)=0D0
40679 560 CONTINUE
40680
40681C...Find particles to include, with proper assumed mass.
40682 ELSEIF(MTABU.EQ.41) THEN
40683 NEVEE=NEVEE+1
40684 NLOW=N+MSTU(3)
40685 NUPP=NLOW
40686 ECM=0D0
40687 DO 570 I=1,N
40688 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
40689 IF(MSTU(41).GE.2) THEN
40690 KC=PYCOMP(K(I,2))
40691 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40692 & KC.EQ.18) GOTO 570
40693 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40694 & PYCHGE(K(I,2)).EQ.0) GOTO 570
40695 ENDIF
40696 PMR=0D0
40697 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40698 IF(MSTU(42).GE.2) PMR=P(I,5)
40699 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40700 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40701 RETURN
40702 ENDIF
40703 NUPP=NUPP+1
40704 P(NUPP,1)=P(I,1)
40705 P(NUPP,2)=P(I,2)
40706 P(NUPP,3)=P(I,3)
40707 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40708 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
40709 ECM=ECM+P(NUPP,4)
40710 570 CONTINUE
40711 IF(NUPP.EQ.NLOW) RETURN
40712
40713C...Analyze Energy-Energy Correlation in event.
40714 FAC=(2D0/ECM**2)*50D0/PARU(1)
40715 DO 580 J=1,50
40716 FEVEE(J)=0D0
40717 580 CONTINUE
40718 DO 600 I1=NLOW+2,NUPP
40719 DO 590 I2=NLOW+1,I1-1
40720 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40721 & (P(I1,5)*P(I2,5))
40722 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
40723 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
40724 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
40725 590 CONTINUE
40726 600 CONTINUE
40727 DO 610 J=1,25
40728 FE1EC(J)=FE1EC(J)+FEVEE(J)
40729 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
40730 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
40731 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
40732 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
40733 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
40734 610 CONTINUE
40735 MSTU(62)=NUPP-NLOW
40736
40737C...Write statistics on Energy-Energy Correlation.
40738 ELSEIF(MTABU.EQ.42) THEN
40739 FAC=1D0/MAX(1,NEVEE)
40740 WRITE(MSTU(11),5700) NEVEE
40741 DO 620 J=1,25
40742 FEEC1=FAC*FE1EC(J)
40743 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
40744 FEEC2=FAC*FE1EC(51-J)
40745 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
40746 FEECA=FAC*FE1EA(J)
40747 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
40748 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
40749 & FEEC2,FEES2,FEECA,FEESA
40750 620 CONTINUE
40751
40752C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
40753 ELSEIF(MTABU.EQ.43) THEN
40754 FAC=1D0/MAX(1,NEVEE)
40755 DO 630 I=1,25
40756 K(I,1)=32
40757 K(I,2)=99
40758 K(I,3)=0
40759 K(I,4)=0
40760 K(I,5)=0
40761 P(I,1)=FAC*FE1EC(I)
40762 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
40763 P(I,2)=FAC*FE1EC(51-I)
40764 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
40765 P(I,3)=FAC*FE1EA(I)
40766 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
40767 P(I,4)=PARU(1)*(I-1)/50D0
40768 P(I,5)=PARU(1)*I/50D0
40769 V(I,4)=3.6D0*(I-1)
40770 V(I,5)=3.6D0*I
40771 630 CONTINUE
40772 N=25
40773 DO 640 J=1,5
40774 K(N+1,J)=0
40775 P(N+1,J)=0D0
40776 V(N+1,J)=0D0
40777 640 CONTINUE
40778 K(N+1,1)=32
40779 K(N+1,2)=99
40780 K(N+1,5)=NEVEE
40781 MSTU(3)=1
40782
40783C...Reset statistics on decay channels.
40784 ELSEIF(MTABU.EQ.50) THEN
40785 NEVDC=0
40786 NKFDC=0
40787 NREDC=0
40788
40789C...Identify and order flavour content of final state.
40790 ELSEIF(MTABU.EQ.51) THEN
40791 NEVDC=NEVDC+1
40792 NDS=0
40793 DO 670 I=1,N
40794 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
40795 NDS=NDS+1
40796 IF(NDS.GT.8) THEN
40797 NREDC=NREDC+1
40798 RETURN
40799 ENDIF
40800 KFM=2*IABS(K(I,2))
40801 IF(K(I,2).LT.0) KFM=KFM-1
40802 DO 650 IDS=NDS-1,1,-1
40803 IIN=IDS+1
40804 IF(KFM.LT.KFDM(IDS)) GOTO 660
40805 KFDM(IDS+1)=KFDM(IDS)
40806 650 CONTINUE
40807 IIN=1
40808 660 KFDM(IIN)=KFM
40809 670 CONTINUE
40810
40811C...Find whether old or new final state.
40812 DO 690 IDC=1,NKFDC
40813 IF(NDS.LT.KFDC(IDC,0)) THEN
40814 IKFDC=IDC
40815 GOTO 700
40816 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
40817 DO 680 I=1,NDS
40818 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
40819 IKFDC=IDC
40820 GOTO 700
40821 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
40822 GOTO 690
40823 ENDIF
40824 680 CONTINUE
40825 IKFDC=-IDC
40826 GOTO 700
40827 ENDIF
40828 690 CONTINUE
40829 IKFDC=NKFDC+1
40830 700 IF(IKFDC.LT.0) THEN
40831 IKFDC=-IKFDC
40832 ELSEIF(NKFDC.GE.200) THEN
40833 NREDC=NREDC+1
40834 RETURN
40835 ELSE
40836 DO 720 IDC=NKFDC,IKFDC,-1
40837 NPDC(IDC+1)=NPDC(IDC)
40838 DO 710 I=0,8
40839 KFDC(IDC+1,I)=KFDC(IDC,I)
40840 710 CONTINUE
40841 720 CONTINUE
40842 NKFDC=NKFDC+1
40843 KFDC(IKFDC,0)=NDS
40844 DO 730 I=1,NDS
40845 KFDC(IKFDC,I)=KFDM(I)
40846 730 CONTINUE
40847 NPDC(IKFDC)=0
40848 ENDIF
40849 NPDC(IKFDC)=NPDC(IKFDC)+1
40850
40851C...Write statistics on decay channels.
40852 ELSEIF(MTABU.EQ.52) THEN
40853 FAC=1D0/MAX(1,NEVDC)
40854 WRITE(MSTU(11),5900) NEVDC
40855 DO 750 IDC=1,NKFDC
40856 DO 740 I=1,KFDC(IDC,0)
40857 KFM=KFDC(IDC,I)
40858 KF=(KFM+1)/2
40859 IF(2*KF.NE.KFM) KF=-KF
40860 CALL PYNAME(KF,CHAU)
40861 CHDC(I)=CHAU(1:12)
40862 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
40863 740 CONTINUE
40864 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
40865 750 CONTINUE
40866 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
40867
40868C...Copy statistics on decay channels into /PYJETS/.
40869 ELSEIF(MTABU.EQ.53) THEN
40870 FAC=1D0/MAX(1,NEVDC)
40871 DO 780 IDC=1,NKFDC
40872 K(IDC,1)=32
40873 K(IDC,2)=99
40874 K(IDC,3)=0
40875 K(IDC,4)=0
40876 K(IDC,5)=KFDC(IDC,0)
40877 DO 760 J=1,5
40878 P(IDC,J)=0D0
40879 V(IDC,J)=0D0
40880 760 CONTINUE
40881 DO 770 I=1,KFDC(IDC,0)
40882 KFM=KFDC(IDC,I)
40883 KF=(KFM+1)/2
40884 IF(2*KF.NE.KFM) KF=-KF
40885 IF(I.LE.5) P(IDC,I)=KF
40886 IF(I.GE.6) V(IDC,I-5)=KF
40887 770 CONTINUE
40888 V(IDC,5)=FAC*NPDC(IDC)
40889 780 CONTINUE
40890 N=NKFDC
40891 DO 790 J=1,5
40892 K(N+1,J)=0
40893 P(N+1,J)=0D0
40894 V(N+1,J)=0D0
40895 790 CONTINUE
40896 K(N+1,1)=32
40897 K(N+1,2)=99
40898 K(N+1,5)=NEVDC
40899 V(N+1,5)=FAC*NREDC
40900 MSTU(3)=1
40901 ENDIF
40902
40903C...Format statements for output on unit MSTU(11) (default 6).
40904 5000 FORMAT(///20X,'Event statistics - initial state'/
40905 &20X,'based on an analysis of ',I6,' events'//
40906 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
40907 &'according to fragmenting system multiplicity'/
40908 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
40909 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
40910 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
40911 5200 FORMAT(///20X,'Event statistics - final state'/
40912 &20X,'based on an analysis of ',I7,' events'//
40913 &5X,'Mean primary multiplicity =',F10.4/
40914 &5X,'Mean final multiplicity =',F10.4/
40915 &5X,'Mean charged multiplicity =',F10.4//
40916 &5X,'Number of particles produced per event (directly and via ',
40917 &'decays/branchings)'/
40918 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
40919 &8X,'Total'/35X,'prim seco prim seco'/)
40920 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
40921 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
40922 &20X,'based on an analysis of ',I6,' events'//
40923 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
40924 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
40925 5500 FORMAT(10X)
40926 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
40927 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
40928 &20X,'based on an analysis of ',I6,' events'//
40929 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
40930 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
40931 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
40932 5900 FORMAT(///20X,'Decay channel analysis - final state'/
40933 &20X,'based on an analysis of ',I6,' events'//
40934 &2X,'Probability',10X,'Complete final state'/)
40935 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
40936 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
40937 &'or table overflow)')
40938
40939 RETURN
40940 END
40941
40942C*********************************************************************
40943
40944C...PYEEVT
40945C...Handles the generation of an e+e- annihilation jet event.
40946
40947 SUBROUTINE PYEEVT(KFL,ECM)
40948C...Double precision and integer declarations.
40949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40950 INTEGER PYK,PYCHGE,PYCOMP
40951C...Commonblocks.
40952 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40955 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40956
40957C...Check input parameters.
40958 IF(MSTU(12).GE.1) CALL PYLIST(0)
40959 IF(KFL.LT.0.OR.KFL.GT.8) THEN
40960 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
40961 IF(MSTU(21).GE.1) RETURN
40962 ENDIF
40963 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
40964 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
40965 IF(ECM.LT.ECMMIN) THEN
40966 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
40967 IF(MSTU(21).GE.1) RETURN
40968 ENDIF
40969
40970C...Check consistency of MSTJ options set.
40971 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
40972 CALL PYERRM(6,
40973 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
40974 MSTJ(110)=1
40975 ENDIF
40976 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
40977 CALL PYERRM(6,
40978 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
40979 MSTJ(111)=0
40980 ENDIF
40981
40982C...Initialize alpha_strong and total cross-section.
40983 MSTU(111)=MSTJ(108)
40984 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
40985 &MSTU(111)=1
40986 PARU(112)=PARJ(121)
40987 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
40988 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
40989 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
40990 &XTOT)
40991 IF(MSTJ(116).GE.3) MSTJ(116)=1
40992 PARJ(171)=0D0
40993
40994C...Add initial e+e- to event record (documentation only).
40995 NTRY=0
40996 100 NTRY=NTRY+1
40997 IF(NTRY.GT.100) THEN
40998 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
40999 RETURN
41000 ENDIF
41001 MSTU(24)=0
41002 NC=0
41003 IF(MSTJ(115).GE.2) THEN
41004 NC=NC+2
41005 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
41006 K(NC-1,1)=21
41007 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
41008 K(NC,1)=21
41009 ENDIF
41010
41011C...Radiative photon (in initial state).
41012 MK=0
41013 ECMC=ECM
41014 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
41015 &THEK,PHIK,ALPK)
41016 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
41017 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
41018 NC=NC+1
41019 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
41020 K(NC,3)=MIN(MSTJ(115)/2,1)
41021 ENDIF
41022
41023C...Virtual exchange boson (gamma or Z0).
41024 IF(MSTJ(115).GE.3) THEN
41025 NC=NC+1
41026 KF=22
41027 IF(MSTJ(102).EQ.2) KF=23
41028 MSTU10=MSTU(10)
41029 MSTU(10)=1
41030 P(NC,5)=ECMC
41031 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
41032 K(NC,1)=21
41033 K(NC,3)=1
41034 MSTU(10)=MSTU10
41035 ENDIF
41036
41037C...Choice of flavour and jet configuration.
41038 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
41039 IF(KFLC.EQ.0) GOTO 100
41040 CALL PYXJET(ECMC,NJET,CUT)
41041 KFLN=21
41042 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
41043 &X12,X14)
41044 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
41045 IF(NJET.EQ.2) MSTJ(120)=1
41046
41047C...Fill jet configuration and origin.
41048 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
41049 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
41050 &ECMC)
41051 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
41052 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
41053 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41054 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
41055 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41056 IF(MSTU(24).NE.0) GOTO 100
41057 DO 110 IP=NC+1,N
41058 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
41059 110 CONTINUE
41060
41061C...Angular orientation according to matrix element.
41062 IF(MSTJ(106).EQ.1) THEN
41063 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
41064 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
41065 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
41066 ENDIF
41067
41068C...Rotation and boost from radiative photon.
41069 IF(MK.EQ.1) THEN
41070 DBEK=-PAK/(ECM-PAK)
41071 NMIN=NC+1-MSTJ(115)/3
41072 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
41073 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
41074 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
41075 ENDIF
41076
41077C...Generate parton shower. Rearrange along strings and check.
41078 IF(MSTJ(101).EQ.5) THEN
41079 CALL PYSHOW(N-1,N,ECMC)
41080 MSTJ14=MSTJ(14)
41081 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
41082 IF(MSTJ(105).GE.0) MSTU(28)=0
41083 CALL PYPREP(0)
41084 MSTJ(14)=MSTJ14
41085 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
41086 ENDIF
41087
41088C...Fragmentation/decay generation. Information for PYTABU.
41089 IF(MSTJ(105).EQ.1) CALL PYEXEC
41090 MSTU(161)=KFLC
41091 MSTU(162)=-KFLC
41092
41093 RETURN
41094 END
41095
41096C*********************************************************************
41097
41098C...PYXTEE
41099C...Calculates total cross-section, including initial state
41100C...radiation effects.
41101
41102 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
41103
41104C...Double precision and integer declarations.
41105 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41106 INTEGER PYK,PYCHGE,PYCOMP
41107C...Commonblocks.
41108 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41109 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41110 SAVE /PYDAT1/,/PYDAT2/
41111
41112C...Status, (optimized) Q^2 scale, alpha_strong.
41113 PARJ(151)=ECM
41114 MSTJ(119)=10*MSTJ(102)+KFL
41115 IF(MSTJ(111).EQ.0) THEN
41116 Q2R=ECM**2
41117 ELSEIF(MSTU(111).EQ.0) THEN
41118 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41119 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41120 Q2R=PARJ(168)*ECM**2
41121 ELSE
41122 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41123 & (2D0*PARU(112)/ECM)**2))
41124 Q2R=PARJ(168)*ECM**2
41125 ENDIF
41126 ALSPI=PYALPS(Q2R)/PARU(1)
41127
41128C...QCD corrections factor in R.
41129 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
41130 RQCD=1D0
41131 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
41132 RQCD=1D0+ALSPI
41133 ELSEIF(MSTJ(109).EQ.0) THEN
41134 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41135 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
41136 & LOG(PARJ(168))*ALSPI**2)
41137 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
41138 RQCD=1D0+(3D0/4D0)*ALSPI
41139 ELSE
41140 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
41141 ENDIF
41142
41143C...Calculate Z0 width if default value not acceptable.
41144 IF(MSTJ(102).GE.3) THEN
41145 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
41146 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
41147 DO 100 KFLC=5,6
41148 VQ=1D0
41149 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
41150 & (2D0*PYMASS(KFLC)/ ECM)**2))
41151 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
41152 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
41153 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
41154 100 CONTINUE
41155 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
41156 & (1D0-PARU(102)))
41157 ENDIF
41158
41159C...Calculate propagator and related constants for QFD case.
41160 POLL=1D0-PARJ(131)*PARJ(132)
41161 IF(MSTJ(102).GE.2) THEN
41162 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41163 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41164 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
41165 VE=4D0*PARU(102)-1D0
41166 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
41167 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41168 HF1I=SFI*SF1I
41169 HF1W=SFW*SF1W
41170 ENDIF
41171
41172C...Loop over different flavours: charge, velocity.
41173 RTOT=0D0
41174 RQQ=0D0
41175 RQV=0D0
41176 RVA=0D0
41177 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
41178 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
41179 MSTJ(93)=1
41180 PMQ=PYMASS(KFLC)
41181 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
41182 QF=KCHG(KFLC,1)/3D0
41183 VQ=1D0
41184 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
41185
41186C...Calculate R and sum of charges for QED or QFD case.
41187 RQQ=RQQ+3D0*QF**2*POLL
41188 IF(MSTJ(102).LE.1) THEN
41189 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
41190 ELSE
41191 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41192 RQV=RQV-6D0*QF*VF*SF1I
41193 RVA=RVA+3D0*(VF**2+1D0)*SF1W
41194 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
41195 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
41196 ENDIF
41197 110 CONTINUE
41198 RSUM=RQQ
41199 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
41200
41201C...Calculate cross-section, including QCD corrections.
41202 PARJ(141)=RQQ
41203 PARJ(142)=RTOT
41204 PARJ(143)=RTOT*RQCD
41205 PARJ(144)=PARJ(143)
41206 PARJ(145)=PARJ(141)*86.8D0/ECM**2
41207 PARJ(146)=PARJ(142)*86.8D0/ECM**2
41208 PARJ(147)=PARJ(143)*86.8D0/ECM**2
41209 PARJ(148)=PARJ(147)
41210 PARJ(157)=RSUM*RQCD
41211 PARJ(158)=0D0
41212 PARJ(159)=0D0
41213 XTOT=PARJ(147)
41214 IF(MSTJ(107).LE.0) RETURN
41215
41216C...Virtual cross-section.
41217 XKL=PARJ(135)
41218 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41219 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
41220 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
41221 &1.526D0*LOG(ECM**2/0.932D0)
41222
41223C...Soft and hard radiative cross-section in QED case.
41224 IF(MSTJ(102).LE.1) THEN
41225 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
41226 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
41227 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
41228
41229C...Soft and hard radiative cross-section in QFD case.
41230 ELSE
41231 SZM=1D0-(PARJ(123)/ECM)**2
41232 SZW=PARJ(123)*PARJ(124)/ECM**2
41233 PARJ(161)=-RQQ/RSUM
41234 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
41235 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
41236 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
41237 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
41238 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
41239 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
41240 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
41241 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
41242 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
41243 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
41244 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
41245 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
41246 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
41247 ENDIF
41248
41249C...Total cross-section and fraction of hard photon events.
41250 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
41251 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
41252 PARJ(144)=PARJ(157)
41253 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41254 XTOT=PARJ(148)
41255
41256 RETURN
41257 END
41258
41259C*********************************************************************
41260
41261C...PYRADK
41262C...Generates initial state photon radiation.
41263
41264 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
41265
41266C...Double precision and integer declarations.
41267 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41268 INTEGER PYK,PYCHGE,PYCOMP
41269C...Commonblocks.
41270 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41271 SAVE /PYDAT1/
41272
41273C...Function: cumulative hard photon spectrum in QFD case.
41274 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
41275 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
41276
41277C...Determine whether radiative photon or not.
41278 MK=0
41279 PAK=0D0
41280 IF(PARJ(160).LT.PYR(0)) RETURN
41281 MK=1
41282
41283C...Photon energy range. Find photon momentum in QED case.
41284 XKL=PARJ(135)
41285 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41286 IF(MSTJ(102).LE.1) THEN
41287 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
41288 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
41289
41290C...Ditto in QFD case, by numerical inversion of integrated spectrum.
41291 ELSE
41292 SZM=1D0-(PARJ(123)/ECM)**2
41293 SZW=PARJ(123)*PARJ(124)/ECM**2
41294 FXKL=FXK(XKL)
41295 FXKU=FXK(XKU)
41296 FXKD=1D-4*(FXKU-FXKL)
41297 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
41298 NXK=0
41299 110 NXK=NXK+1
41300 XK=0.5D0*(XKL+XKU)
41301 FXKV=FXK(XK)
41302 IF(FXKV.GT.FXKR) THEN
41303 XKU=XK
41304 FXKU=FXKV
41305 ELSE
41306 XKL=XK
41307 FXKL=FXKV
41308 ENDIF
41309 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
41310 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
41311 ENDIF
41312 PAK=0.5D0*ECM*XK
41313
41314C...Photon polar and azimuthal angle.
41315 PME=2D0*(PYMASS(11)/ECM)**2
41316 120 CTHM=PME*(2D0/PME)**PYR(0)
41317 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
41318 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
41319 CTHE=1D0-CTHM
41320 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
41321 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
41322 THEK=PYANGL(CTHE,STHE)
41323 PHIK=PARU(2)*PYR(0)
41324
41325C...Rotation angle for hadronic system.
41326 SGN=1D0
41327 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
41328 &PYR(0)) SGN=-1D0
41329 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
41330 &(2D0-XK*(1D0-SGN*CTHE)))
41331
41332 RETURN
41333 END
41334
41335C*********************************************************************
41336
41337C...PYXKFL
41338C...Selects flavour for produced qqbar pair.
41339
41340 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
41341
41342C...Double precision and integer declarations.
41343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41344 INTEGER PYK,PYCHGE,PYCOMP
41345C...Commonblocks.
41346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41347 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41348 SAVE /PYDAT1/,/PYDAT2/
41349
41350C...Calculate maximum weight in QED or QFD case.
41351 IF(MSTJ(102).LE.1) THEN
41352 RFMAX=4D0/9D0
41353 ELSE
41354 POLL=1D0-PARJ(131)*PARJ(132)
41355 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41356 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41357 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
41358 VE=4D0*PARU(102)-1D0
41359 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
41360 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41361 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
41362 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
41363 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
41364 & 1D0)*HF1W)
41365 ENDIF
41366
41367C...Choose flavour. Gives charge and velocity.
41368 NTRY=0
41369 100 NTRY=NTRY+1
41370 IF(NTRY.GT.100) THEN
41371 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
41372 KFLC=0
41373 RETURN
41374 ENDIF
41375 KFLC=KFL
41376 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
41377 MSTJ(93)=1
41378 PMQ=PYMASS(KFLC)
41379 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
41380 QF=KCHG(KFLC,1)/3D0
41381 VQ=1D0
41382 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
41383
41384C...Calculate weight in QED or QFD case.
41385 IF(MSTJ(102).LE.1) THEN
41386 RF=QF**2
41387 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
41388 ELSE
41389 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41390 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
41391 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
41392 & VQ**3*HF1W
41393 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
41394 ENDIF
41395
41396C...Weighting or new event (radiative photon). Cross-section update.
41397 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
41398 PARJ(158)=PARJ(158)+1D0
41399 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
41400 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
41401 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
41402 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
41403 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41404
41405 RETURN
41406 END
41407
41408C*********************************************************************
41409
41410C...PYXJET
41411C...Selects number of jets in matrix element approach.
41412
41413 SUBROUTINE PYXJET(ECM,NJET,CUT)
41414
41415C...Double precision and integer declarations.
41416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41417 INTEGER PYK,PYCHGE,PYCOMP
41418C...Commonblocks.
41419 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41420 SAVE /PYDAT1/
41421C...Local array and data.
41422 DIMENSION ZHUT(5)
41423 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
41424
41425C...Trivial result for two-jets only, including parton shower.
41426 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41427 CUT=0D0
41428
41429C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
41430 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
41431 CF=4D0/3D0
41432 IF(MSTJ(109).EQ.2) CF=1D0
41433 IF(MSTJ(111).EQ.0) THEN
41434 Q2=ECM**2
41435 Q2R=ECM**2
41436 ELSEIF(MSTU(111).EQ.0) THEN
41437 PARJ(169)=MIN(1D0,PARJ(129))
41438 Q2=PARJ(169)*ECM**2
41439 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41440 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41441 Q2R=PARJ(168)*ECM**2
41442 ELSE
41443 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
41444 Q2=PARJ(169)*ECM**2
41445 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41446 & (2D0*PARU(112)/ECM)**2))
41447 Q2R=PARJ(168)*ECM**2
41448 ENDIF
41449
41450C...alpha_strong for R and R itself.
41451 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
41452 IF(IABS(MSTJ(101)).EQ.1) THEN
41453 RQCD=1D0+ALSPI
41454 ELSEIF(MSTJ(109).EQ.0) THEN
41455 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41456 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
41457 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
41458 ELSE
41459 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
41460 ENDIF
41461
41462C...alpha_strong for jet rate. Initial value for y cut.
41463 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41464 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
41465 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
41466 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
41467 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41468
41469C...Parametrization of first order three-jet cross-section.
41470 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
41471 PARJ(152)=0D0
41472 ELSE
41473 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
41474 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
41475 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
41476 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
41477 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
41478 & PARJ(152)=0D0
41479 ENDIF
41480
41481C...Parametrization of second order three-jet cross-section.
41482 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
41483 & CUT.GE.0.25D0) THEN
41484 PARJ(153)=0D0
41485 ELSEIF(MSTJ(110).LE.1) THEN
41486 CT=LOG(1D0/CUT-2D0)
41487 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
41488 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
41489
41490C...Interpolation in second/first order ratio for Zhu parametrization.
41491 ELSEIF(MSTJ(110).EQ.2) THEN
41492 IZA=0
41493 DO 110 IY=1,5
41494 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41495 110 CONTINUE
41496 IF(IZA.NE.0) THEN
41497 ZHURAT=ZHUT(IZA)
41498 ELSE
41499 IZ=100D0*CUT
41500 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
41501 ENDIF
41502 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
41503 ENDIF
41504
41505C...Shift in second order three-jet cross-section with optimized Q^2.
41506 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
41507 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
41508 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
41509
41510C...Parametrization of second order four-jet cross-section.
41511 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
41512 PARJ(154)=0D0
41513 ELSE
41514 CT=LOG(1D0/CUT-5D0)
41515 IF(CUT.LE.0.018D0) THEN
41516 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
41517 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
41518 & 0.4059D0*CT**2)
41519 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
41520 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41521 ELSE
41522 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
41523 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
41524 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
41525 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
41526 & 0.002093D0*CT**3)
41527 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41528 ENDIF
41529 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
41530 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
41531 ENDIF
41532
41533C...If negative three-jet rate, change y' optimization parameter.
41534 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
41535 & PARJ(169).LT.0.99D0) THEN
41536 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41537 Q2=PARJ(169)*ECM**2
41538 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41539 GOTO 100
41540 ENDIF
41541
41542C...If too high cross-section, use harder cuts, or fail.
41543 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
41544 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
41545 & PARJ(169).LT.0.99D0) THEN
41546 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41547 Q2=PARJ(169)*ECM**2
41548 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41549 GOTO 100
41550 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
41551 CALL PYERRM(26,
41552 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
41553 ENDIF
41554 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
41555 & PARJ(154))**(-1D0/3D0)
41556 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41557 GOTO 100
41558 ENDIF
41559
41560C...Scalar gluon (first order only).
41561 ELSE
41562 ALSPI=PYALPS(ECM**2)/PARU(1)
41563 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
41564 PARJ(152)=0D0
41565 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
41566 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
41567 PARJ(153)=0D0
41568 PARJ(154)=0D0
41569 ENDIF
41570
41571C...Select number of jets.
41572 PARJ(150)=CUT
41573 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41574 NJET=2
41575 ELSEIF(MSTJ(101).LE.0) THEN
41576 NJET=MIN(4,2-MSTJ(101))
41577 ELSE
41578 RNJ=PYR(0)
41579 NJET=2
41580 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
41581 IF(PARJ(154).GT.RNJ) NJET=4
41582 ENDIF
41583
41584 RETURN
41585 END
41586
41587C*********************************************************************
41588
41589C...PYX3JT
41590C...Selects the kinematical variables of three-jet events.
41591
41592 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
41593
41594C...Double precision and integer declarations.
41595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41596 INTEGER PYK,PYCHGE,PYCOMP
41597C...Commonblocks.
41598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41599 SAVE /PYDAT1/
41600C...Local array.
41601 DIMENSION ZHUP(5,12)
41602
41603C...Coefficients of Zhu second order parametrization.
41604 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
41605 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
41606 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
41607 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
41608 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
41609 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
41610 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
41611 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
41612 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
41613 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
41614 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
41615
41616C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
41617 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
41618 &X**7/49D0
41619
41620C...Event type. Mass effect factors and other common constants.
41621 MSTJ(120)=2
41622 MSTJ(121)=0
41623 PMQ=PYMASS(KFL)
41624 QME=(2D0*PMQ/ECM)**2
41625 IF(MSTJ(109).NE.1) THEN
41626 CUTL=LOG(CUT)
41627 CUTD=LOG(1D0/CUT-2D0)
41628 IF(MSTJ(109).EQ.0) THEN
41629 CF=4D0/3D0
41630 CN=3D0
41631 TR=2D0
41632 WTMX=MIN(20D0,37D0-6D0*CUTD)
41633 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
41634 ELSE
41635 CF=1D0
41636 CN=0D0
41637 TR=12D0
41638 WTMX=0D0
41639 ENDIF
41640
41641C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
41642 ALS2PI=PARU(118)/PARU(2)
41643 WTOPT=0D0
41644 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
41645 & LOG(PARJ(169))*ALS2PI
41646 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
41647
41648C...Choose three-jet events in allowed region.
41649 100 NJET=3
41650 110 Y13L=CUTL+CUTD*PYR(0)
41651 Y23L=CUTL+CUTD*PYR(0)
41652 Y13=EXP(Y13L)
41653 Y23=EXP(Y23L)
41654 Y12=1D0-Y13-Y23
41655 IF(Y12.LE.CUT) GOTO 110
41656 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
41657
41658C...Second order corrections.
41659 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
41660 Y12L=LOG(Y12)
41661 Y13M=LOG(1D0-Y13)
41662 Y23M=LOG(1D0-Y23)
41663 Y12M=LOG(1D0-Y12)
41664 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
41665 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
41666 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
41667 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
41668 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
41669 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
41670 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
41671 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
41672 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
41673 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
41674 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
41675 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
41676 & TR*(2D0*CUTL/3D0-10D0/9D0)+
41677 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
41678 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
41679 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
41680 & Y13*Y23)/(Y12+Y13)**2)/WT1+
41681 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
41682 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
41683 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
41684 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
41685 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
41686 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
41687 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
41688 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41689 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41690 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
41691
41692 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
41693C...Second order corrections; Zhu parametrization of ERT.
41694 ZX=(Y23-Y13)**2
41695 ZY=1D0-Y12
41696 IZA=0
41697 DO 120 IY=1,5
41698 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41699 120 CONTINUE
41700 IF(IZA.NE.0) THEN
41701 IZ=IZA
41702 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41703 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41704 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41705 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41706 ELSE
41707 IZ=100D0*CUT
41708 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41709 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41710 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41711 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41712 IZ=IZ+1
41713 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41714 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41715 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41716 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41717 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
41718 ENDIF
41719 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41720 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41721 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
41722 ENDIF
41723
41724C...Impose mass cuts (gives two jets). For fixed jet number new try.
41725 X1=1D0-Y23
41726 X2=1D0-Y13
41727 X3=1D0-Y12
41728 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
41729 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
41730 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
41731 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
41732 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
41733
41734C...Scalar gluon model (first order only, no mass effects).
41735 ELSE
41736 130 NJET=3
41737 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
41738 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
41739 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
41740 X1=1D0-0.5D0*(X3+YD)
41741 X2=1D0-0.5D0*(X3-YD)
41742 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
41743 IF(MSTJ(102).GE.2) THEN
41744 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
41745 & X3**2*PYR(0)) NJET=2
41746 ENDIF
41747 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
41748 ENDIF
41749
41750 RETURN
41751 END
41752
41753C*********************************************************************
41754
41755C...PYX4JT
41756C...Selects the kinematical variables of four-jet events.
41757
41758 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
41759
41760C...Double precision and integer declarations.
41761 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41762 INTEGER PYK,PYCHGE,PYCOMP
41763C...Commonblocks.
41764 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41765 SAVE /PYDAT1/
41766C...Local arrays.
41767 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
41768
41769C...Common constants. Colour factors for QCD and Abelian gluon theory.
41770 PMQ=PYMASS(KFL)
41771 QME=(2D0*PMQ/ECM)**2
41772 CT=LOG(1D0/CUT-5D0)
41773 IF(MSTJ(109).EQ.0) THEN
41774 CF=4D0/3D0
41775 CN=3D0
41776 TR=2.5D0
41777 ELSE
41778 CF=1D0
41779 CN=0D0
41780 TR=15D0
41781 ENDIF
41782
41783C...Choice of process (qqbargg or qqbarqqbar).
41784 100 NJET=4
41785 IT=1
41786 IF(PARJ(155).GT.PYR(0)) IT=2
41787 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
41788 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
41789 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
41790 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
41791 ID=1
41792
41793C...Sample the five kinematical variables (for qqgg preweighted in y34).
41794 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
41795 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
41796 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
41797 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
41798 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
41799 VT=PYR(0)
41800 CP=COS(PARU(1)*PYR(0))
41801 Y14=(Y134-Y34)*VT
41802 Y13=Y134-Y14-Y34
41803 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
41804 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
41805 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
41806 Y23=Y234-Y34-Y24
41807 Y12=1D0-Y134-Y23-Y24
41808 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
41809 Y123=Y12+Y13+Y23
41810 Y124=Y12+Y14+Y24
41811
41812C...Calculate matrix elements for qqgg or qqqq process.
41813 IC=0
41814 WTTOT=0D0
41815 120 IC=IC+1
41816 IF(IT.EQ.1) THEN
41817 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
41818 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
41819 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
41820 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
41821 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
41822 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
41823 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
41824 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
41825 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
41826 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
41827 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
41828 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
41829 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
41830 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
41831 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
41832 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
41833 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
41834 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
41835 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
41836 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
41837 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
41838 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
41839 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
41840 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
41841 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
41842 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
41843 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
41844 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
41845 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
41846 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
41847 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
41848 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
41849 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
41850 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
41851 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
41852 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
41853 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
41854 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
41855 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
41856 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
41857 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
41858 & CN*WTC(IC))/8D0
41859 ELSE
41860 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
41861 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
41862 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
41863 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
41864 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
41865 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
41866 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
41867 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
41868 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
41869 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
41870 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
41871 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
41872 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
41873 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
41874 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
41875 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
41876 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
41877 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
41878 ENDIF
41879
41880C...Permutations of momenta in matrix element. Weighting.
41881 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
41882 YSAV=Y13
41883 Y13=Y14
41884 Y14=YSAV
41885 YSAV=Y23
41886 Y23=Y24
41887 Y24=YSAV
41888 YSAV=Y123
41889 Y123=Y124
41890 Y124=YSAV
41891 ENDIF
41892 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
41893 YSAV=Y13
41894 Y13=Y23
41895 Y23=YSAV
41896 YSAV=Y14
41897 Y14=Y24
41898 Y24=YSAV
41899 YSAV=Y134
41900 Y134=Y234
41901 Y234=YSAV
41902 ENDIF
41903 IF(IC.LE.3) GOTO 120
41904 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
41905 IC=5
41906
41907C...qqgg events: string configuration and event type.
41908 IF(IT.EQ.1) THEN
41909 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
41910 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
41911 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
41912 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
41913 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
41914 IF(ID.EQ.2) GOTO 130
41915 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
41916 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
41917 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
41918 IF(ID.EQ.2) GOTO 130
41919 ENDIF
41920 MSTJ(120)=3
41921 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
41922 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
41923 KFLN=21
41924
41925C...Mass cuts. Kinematical variables out.
41926 IF(Y12.LE.CUT+QME) NJET=2
41927 IF(NJET.EQ.2) GOTO 150
41928 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
41929 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
41930 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
41931 X2=1D0-Y124
41932 X12=(1D0-Q12)*Y13+Q12*Y23
41933 X14=Y12-0.5D0*QME
41934 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
41935
41936C...qqbarqqbar events: string configuration, choose new flavour.
41937 ELSE
41938 IF(ID.EQ.1) THEN
41939 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
41940 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
41941 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
41942 IF(WTR.LT.WTD(4)) ID=4
41943 IF(ID.GE.2) GOTO 130
41944 ENDIF
41945 MSTJ(120)=5
41946 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
41947 140 KFLN=1+INT(5D0*PYR(0))
41948 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
41949 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
41950 IF(KFLN.GT.MSTJ(104)) NJET=2
41951 PMQN=PYMASS(KFLN)
41952 QMEN=(2D0*PMQN/ECM)**2
41953
41954C...Mass cuts. Kinematical variables out.
41955 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
41956 IF(NJET.EQ.2) GOTO 150
41957 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
41958 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
41959 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
41960 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
41961 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
41962 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
41963 & Q13*Y23)
41964 X14=Y24-0.5D0*QME
41965 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
41966 & Q13*Y14)
41967 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
41968 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
41969 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
41970 ENDIF
41971 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
41972
41973 RETURN
41974 END
41975
41976C*********************************************************************
41977
41978C...PYXDIF
41979C...Gives the angular orientation of events.
41980
41981 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
41982
41983C...Double precision and integer declarations.
41984 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41985 INTEGER PYK,PYCHGE,PYCOMP
41986C...Commonblocks.
41987 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41989 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41990 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41991
41992C...Charge. Factors depending on polarization for QED case.
41993 QF=KCHG(KFL,1)/3D0
41994 POLL=1D0-PARJ(131)*PARJ(132)
41995 POLD=PARJ(132)-PARJ(131)
41996 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
41997 HF1=POLL
41998 HF2=0D0
41999 HF3=PARJ(133)**2
42000 HF4=0D0
42001
42002C...Factors depending on flavour, energy and polarization for QFD case.
42003 ELSE
42004 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
42005 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
42006 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
42007 AE=-1D0
42008 VE=4D0*PARU(102)-1D0
42009 AF=SIGN(1D0,QF)
42010 VF=AF-4D0*QF*PARU(102)
42011 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
42012 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
42013 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
42014 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
42015 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
42016 & SFW*SFF**2*(VE**2-AE**2))
42017 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
42018 & SFF*AE
42019 ENDIF
42020
42021C...Mass factor. Differential cross-sections for two-jet events.
42022 SQ2=SQRT(2D0)
42023 QME=0D0
42024 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
42025 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
42026 IF(NJET.EQ.2) THEN
42027 SIGU=4D0*SQRT(1D0-QME)
42028 SIGL=2D0*QME*SQRT(1D0-QME)
42029 SIGT=0D0
42030 SIGI=0D0
42031 SIGA=0D0
42032 SIGP=4D0
42033
42034C...Kinematical variables. Reduce four-jet event to three-jet one.
42035 ELSE
42036 IF(NJET.EQ.3) THEN
42037 X1=2D0*P(NC+1,4)/ECM
42038 X2=2D0*P(NC+3,4)/ECM
42039 ELSE
42040 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
42041 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
42042 X1=2D0*P(NC+1,4)/ECMR
42043 X2=2D0*P(NC+4,4)/ECMR
42044 ENDIF
42045
42046C...Differential cross-sections for three-jet (or reduced four-jet).
42047 XQ=(1D0-X1)/(1D0-X2)
42048 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
42049 ST12=SQRT(1D0-CT12**2)
42050 IF(MSTJ(109).NE.1) THEN
42051 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
42052 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
42053 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
42054 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
42055 & X2)*XQ
42056 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
42057 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
42058 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
42059 SIGA=X2**2*ST12/SQ2
42060 SIGP=2D0*(X1**2-X2**2*CT12)
42061
42062C...Differential cross-sect for scalar gluons (no mass effects).
42063 ELSE
42064 X3=2D0-X1-X2
42065 XT=X2*ST12
42066 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
42067 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
42068 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
42069 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
42070 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
42071 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
42072 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
42073 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
42074 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
42075 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
42076 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
42077 ENDIF
42078 ENDIF
42079
42080C...Upper bounds for differential cross-section.
42081 HF1A=ABS(HF1)
42082 HF2A=ABS(HF2)
42083 HF3A=ABS(HF3)
42084 HF4A=ABS(HF4)
42085 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
42086 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
42087 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
42088 &2D0*HF2A*ABS(SIGP)
42089
42090C...Generate angular orientation according to differential cross-sect.
42091 100 CHI=PARU(2)*PYR(0)
42092 CTHE=2D0*PYR(0)-1D0
42093 PHI=PARU(2)*PYR(0)
42094 CCHI=COS(CHI)
42095 SCHI=SIN(CHI)
42096 C2CHI=COS(2D0*CHI)
42097 S2CHI=SIN(2D0*CHI)
42098 THE=ACOS(CTHE)
42099 STHE=SIN(THE)
42100 C2PHI=COS(2D0*(PHI-PARJ(134)))
42101 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42102 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
42103 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
42104 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
42105 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
42106 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
42107 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
42108 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
42109 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
42110
42111 RETURN
42112 END
42113
42114C*********************************************************************
42115
42116C...PYONIA
42117C...Generates Upsilon and toponium decays into three gluons
42118C...or two gluons and a photon.
42119
42120 SUBROUTINE PYONIA(KFL,ECM)
42121
42122C...Double precision and integer declarations.
42123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42124 INTEGER PYK,PYCHGE,PYCOMP
42125C...Commonblocks.
42126 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42127 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42128 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42129 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42130
42131C...Printout. Check input parameters.
42132 IF(MSTU(12).GE.1) CALL PYLIST(0)
42133 IF(KFL.LT.0.OR.KFL.GT.8) THEN
42134 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
42135 IF(MSTU(21).GE.1) RETURN
42136 ENDIF
42137 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
42138 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
42139 IF(MSTU(21).GE.1) RETURN
42140 ENDIF
42141
42142C...Initial e+e- and onium state (optional).
42143 NC=0
42144 IF(MSTJ(115).GE.2) THEN
42145 NC=NC+2
42146 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
42147 K(NC-1,1)=21
42148 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
42149 K(NC,1)=21
42150 ENDIF
42151 KFLC=IABS(KFL)
42152 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
42153 NC=NC+1
42154 KF=110*KFLC+3
42155 MSTU10=MSTU(10)
42156 MSTU(10)=1
42157 P(NC,5)=ECM
42158 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
42159 K(NC,1)=21
42160 K(NC,3)=1
42161 MSTU(10)=MSTU10
42162 ENDIF
42163
42164C...Choose x1 and x2 according to matrix element.
42165 NTRY=0
42166 100 X1=PYR(0)
42167 X2=PYR(0)
42168 X3=2D0-X1-X2
42169 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
42170 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
42171 NTRY=NTRY+1
42172 NJET=3
42173 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
42174 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
42175
42176C...Photon-gluon-gluon events. Small system modifications. Jet origin.
42177 MSTU(111)=MSTJ(108)
42178 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
42179 &MSTU(111)=1
42180 PARU(112)=PARJ(121)
42181 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
42182 QF=0D0
42183 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
42184 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
42185 MK=0
42186 ECMC=ECM
42187 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
42188 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
42189 & NJET=2
42190 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
42191 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
42192 ELSE
42193 MK=1
42194 ECMC=SQRT(1D0-X1)*ECM
42195 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
42196 K(NC+1,1)=1
42197 K(NC+1,2)=22
42198 K(NC+1,4)=0
42199 K(NC+1,5)=0
42200 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
42201 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
42202 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
42203 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
42204 NJET=2
42205 IF(ECMC.LT.4D0*PARJ(127)) THEN
42206 MSTU10=MSTU(10)
42207 MSTU(10)=1
42208 P(NC+2,5)=ECMC
42209 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
42210 MSTU(10)=MSTU10
42211 NJET=0
42212 ENDIF
42213 ENDIF
42214 DO 110 IP=NC+1,N
42215 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
42216 110 CONTINUE
42217
42218C...Differential cross-sections. Upper limit for cross-section.
42219 IF(MSTJ(106).EQ.1) THEN
42220 SQ2=SQRT(2D0)
42221 HF1=1D0-PARJ(131)*PARJ(132)
42222 HF3=PARJ(133)**2
42223 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
42224 ST13=SQRT(1D0-CT13**2)
42225 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
42226 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
42227 SIGT=0.5D0*SIGL
42228 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
42229 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
42230 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
42231
42232C...Angular orientation of event.
42233 120 CHI=PARU(2)*PYR(0)
42234 CTHE=2D0*PYR(0)-1D0
42235 PHI=PARU(2)*PYR(0)
42236 CCHI=COS(CHI)
42237 SCHI=SIN(CHI)
42238 C2CHI=COS(2D0*CHI)
42239 S2CHI=SIN(2D0*CHI)
42240 THE=ACOS(CTHE)
42241 STHE=SIN(THE)
42242 C2PHI=COS(2D0*(PHI-PARJ(134)))
42243 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42244 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
42245 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
42246 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
42247 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
42248 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
42249 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
42250 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
42251 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
42252 ENDIF
42253
42254C...Generate parton shower. Rearrange along strings and check.
42255 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
42256 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
42257 MSTJ14=MSTJ(14)
42258 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
42259 IF(MSTJ(105).GE.0) MSTU(28)=0
42260 CALL PYPREP(0)
42261 MSTJ(14)=MSTJ14
42262 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
42263 ENDIF
42264
42265C...Generate fragmentation. Information for PYTABU:
42266 IF(MSTJ(105).EQ.1) CALL PYEXEC
42267 MSTU(161)=110*KFLC+3
42268 MSTU(162)=0
42269
42270 RETURN
42271 END
42272
42273C*********************************************************************
42274
42275C...PYBOOK
42276C...Books a histogram.
42277
42278 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
42279
42280C...Double precision declaration.
42281 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42282C...Commonblock.
42283 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42284 SAVE /PYBINS/
42285C...Local character variables.
42286 CHARACTER TITLE*(*), TITFX*60
42287
42288C...Check that input is sensible. Find initial address in memory.
42289 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42290 &'(PYBOOK:) not allowed histogram number')
42291 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
42292 &'(PYBOOK:) not allowed number of bins')
42293 IF(XL.GE.XU) CALL PYERRM(28,
42294 &'(PYBOOK:) x limits in wrong order')
42295 INDX(ID)=IHIST(4)
42296 IHIST(4)=IHIST(4)+28+NX
42297 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
42298 &'(PYBOOK:) out of histogram space')
42299 IS=INDX(ID)
42300
42301C...Store histogram size and reset contents.
42302 BIN(IS+1)=NX
42303 BIN(IS+2)=XL
42304 BIN(IS+3)=XU
42305 BIN(IS+4)=(XU-XL)/NX
42306 CALL PYNULL(ID)
42307
42308C...Store title by conversion to integer to double precision.
42309 TITFX=TITLE//' '
42310 DO 100 IT=1,20
42311 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
42312 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
42313 100 CONTINUE
42314
42315 RETURN
42316 END
42317
42318C*********************************************************************
42319
42320C...PYFILL
42321C...Fills entry in histogram.
42322
42323 SUBROUTINE PYFILL(ID,X,W)
42324
42325C...Double precision declaration.
42326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42327C...Commonblock.
42328 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42329 SAVE /PYBINS/
42330
42331C...Find initial address in memory. Increase number of entries.
42332 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42333 &'(PYFILL:) not allowed histogram number')
42334 IS=INDX(ID)
42335 IF(IS.EQ.0) CALL PYERRM(28,
42336 &'(PYFILL:) filling unbooked histogram')
42337 BIN(IS+5)=BIN(IS+5)+1D0
42338
42339C...Find bin in x, including under/overflow, and fill.
42340 IF(X.LT.BIN(IS+2)) THEN
42341 BIN(IS+6)=BIN(IS+6)+W
42342 ELSEIF(X.GE.BIN(IS+3)) THEN
42343 BIN(IS+8)=BIN(IS+8)+W
42344 ELSE
42345 BIN(IS+7)=BIN(IS+7)+W
42346 IX=(X-BIN(IS+2))/BIN(IS+4)
42347 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
42348 BIN(IS+9+IX)=BIN(IS+9+IX)+W
42349 ENDIF
42350
42351 RETURN
42352 END
42353
42354C*********************************************************************
42355
42356C...PYFACT
42357C...Multiplies histogram contents by factor.
42358
42359 SUBROUTINE PYFACT(ID,F)
42360
42361C...Double precision declaration.
42362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42363C...Commonblock.
42364 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42365 SAVE /PYBINS/
42366
42367C...Find initial address in memory. Multiply all contents bins.
42368 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42369 &'(PYFACT:) not allowed histogram number')
42370 IS=INDX(ID)
42371 IF(IS.EQ.0) CALL PYERRM(28,
42372 &'(PYFACT:) scaling unbooked histogram')
42373 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
42374 BIN(IX)=F*BIN(IX)
42375 100 CONTINUE
42376
42377 RETURN
42378 END
42379
42380C*********************************************************************
42381
42382C...PYOPER
42383C...Performs operations between histograms.
42384
42385 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
42386
42387C...Double precision declaration.
42388 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42389C...Commonblock.
42390 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42391 SAVE /PYBINS/
42392C...Character variable.
42393 CHARACTER OPER*(*)
42394
42395C...Find initial addresses in memory, and histogram size.
42396 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
42397 &'(PYFACT:) not allowed histogram number')
42398 IS1=INDX(ID1)
42399 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
42400 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
42401 NX=NINT(BIN(IS3+1))
42402 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
42403
42404C...Update info on number of histogram entries.
42405 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
42406 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
42407 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
42408 BIN(IS3+5)=BIN(IS1+5)
42409 ENDIF
42410
42411C...Operations on pair of histograms: addition, subtraction,
42412C...multiplication, division.
42413 IF(OPER.EQ.'+') THEN
42414 DO 100 IX=6,8+NX
42415 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
42416 100 CONTINUE
42417 ELSEIF(OPER.EQ.'-') THEN
42418 DO 110 IX=6,8+NX
42419 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
42420 110 CONTINUE
42421 ELSEIF(OPER.EQ.'*') THEN
42422 DO 120 IX=6,8+NX
42423 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
42424 120 CONTINUE
42425 ELSEIF(OPER.EQ.'/') THEN
42426 DO 130 IX=6,8+NX
42427 FA2=F2*BIN(IS2+IX)
42428 IF(ABS(FA2).LE.1D-20) THEN
42429 BIN(IS3+IX)=0D0
42430 ELSE
42431 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
42432 ENDIF
42433 130 CONTINUE
42434
42435C...Operations on single histogram: multiplication+addition,
42436C...square root+addition, logarithm+addition.
42437 ELSEIF(OPER.EQ.'A') THEN
42438 DO 140 IX=6,8+NX
42439 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
42440 140 CONTINUE
42441 ELSEIF(OPER.EQ.'S') THEN
42442 DO 150 IX=6,8+NX
42443 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
42444 150 CONTINUE
42445 ELSEIF(OPER.EQ.'L') THEN
42446 ZMIN=1D20
42447 DO 160 IX=9,8+NX
42448 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
42449 & ZMIN=0.8D0*BIN(IS1+IX)
42450 160 CONTINUE
42451 DO 170 IX=6,8+NX
42452 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
42453 170 CONTINUE
42454
42455C...Operation on two or three histograms: average and
42456C...standard deviation.
42457 ELSEIF(OPER.EQ.'M') THEN
42458 DO 180 IX=6,8+NX
42459 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42460 BIN(IS2+IX)=0D0
42461 ELSE
42462 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
42463 ENDIF
42464 IF(ID3.NE.0) THEN
42465 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42466 BIN(IS3+IX)=0D0
42467 ELSE
42468 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
42469 & BIN(IS2+IX)**2))
42470 ENDIF
42471 ENDIF
42472 BIN(IS1+IX)=F1*BIN(IS1+IX)
42473 180 CONTINUE
42474 ENDIF
42475
42476 RETURN
42477 END
42478
42479C*********************************************************************
42480
42481C...PYHIST
42482C...Prints and resets all histograms.
42483
42484 SUBROUTINE PYHIST
42485
42486C...Double precision declaration.
42487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42488C...Commonblock.
42489 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42490 SAVE /PYBINS/
42491
42492C...Loop over histograms, print and reset used ones.
42493 DO 100 ID=1,IHIST(1)
42494 IS=INDX(ID)
42495 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
42496 CALL PYPLOT(ID)
42497 CALL PYNULL(ID)
42498 ENDIF
42499 100 CONTINUE
42500
42501 RETURN
42502 END
42503
42504C*********************************************************************
42505
42506C...PYPLOT
42507C...Prints a histogram (but does not reset it).
42508
42509 SUBROUTINE PYPLOT(ID)
42510
42511C...Double precision declaration.
42512 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42513C...Commonblocks.
42514 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42515 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42516 SAVE /PYDAT1/,/PYBINS/
42517C...Local arrays and character variables.
42518 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
42519 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
42520
42521C...Steps in histogram scale. Character sequence.
42522 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
42523 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
42524
42525C...Find initial address in memory; skip if empty histogram.
42526 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42527 IS=INDX(ID)
42528 IF(IS.EQ.0) RETURN
42529 IF(NINT(BIN(IS+5)).LE.0) THEN
42530 WRITE(MSTU(11),5000) ID
42531 RETURN
42532 ENDIF
42533
42534C...Number of histogram lines and x bins.
42535 LIN=IHIST(3)-18
42536 NX=NINT(BIN(IS+1))
42537
42538C...Extract title by conversion from double precision via integer.
42539 DO 100 IT=1,20
42540 IEQ=NINT(BIN(IS+8+NX+IT))
42541 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
42542 & //CHAR(MOD(IEQ,256))
42543 100 CONTINUE
42544
42545C...Find time; print title.
42546 CALL PYTIME(IDATI)
42547 IF(IDATI(1).GT.0) THEN
42548 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
42549 ELSE
42550 WRITE(MSTU(11),5200) ID, TITLE
42551 ENDIF
42552
42553C...Find minimum and maximum bin content.
42554 YMIN=BIN(IS+9)
42555 YMAX=BIN(IS+9)
42556 DO 110 IX=IS+10,IS+8+NX
42557 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
42558 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
42559 110 CONTINUE
42560
42561C...Determine scale and step size for y axis.
42562 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
42563 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
42564 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
42565 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
42566 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
42567 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
42568 DELY=DYAC(1)
42569 DO 120 IDEL=1,9
42570 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
42571 120 CONTINUE
42572 DY=DELY*10D0**IPOT
42573
42574C...Convert bin contents to integer form; fractional fill in top row.
42575 DO 130 IX=1,NX
42576 CTA=ABS(BIN(IS+8+IX))/DY
42577 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
42578 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
42579 130 CONTINUE
42580 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
42581 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
42582
42583C...Print histogram row by row.
42584 DO 150 IR=IRMA,IRMI,-1
42585 IF(IR.EQ.0) GOTO 150
42586 OUT=' '
42587 DO 140 IX=1,NX
42588 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
42589 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
42590 140 CONTINUE
42591 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
42592 150 CONTINUE
42593
42594C...Print sign and value of bin contents.
42595 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
42596 OUT=' '
42597 DO 160 IX=1,NX
42598 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
42599 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
42600 160 CONTINUE
42601 WRITE(MSTU(11),5400) OUT
42602 DO 180 IR=4,1,-1
42603 DO 170 IX=1,NX
42604 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42605 170 CONTINUE
42606 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
42607 180 CONTINUE
42608
42609C...Print sign and value of lower bin edge.
42610 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
42611 & 10.0001D0)-10
42612 OUT=' '
42613 DO 190 IX=1,NX
42614 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
42615 & OUT(IX:IX)=CHA(11)
42616 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
42617 190 CONTINUE
42618 WRITE(MSTU(11),5600) OUT
42619 DO 210 IR=3,1,-1
42620 DO 200 IX=1,NX
42621 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42622 200 CONTINUE
42623 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
42624 210 CONTINUE
42625 ENDIF
42626
42627C...Calculate and print statistics.
42628 CSUM=0D0
42629 CXSUM=0D0
42630 CXXSUM=0D0
42631 DO 220 IX=1,NX
42632 CTA=ABS(BIN(IS+8+IX))
42633 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
42634 CSUM=CSUM+CTA
42635 CXSUM=CXSUM+CTA*X
42636 CXXSUM=CXXSUM+CTA*X**2
42637 220 CONTINUE
42638 XMEAN=CXSUM/MAX(CSUM,1D-20)
42639 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
42640 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
42641 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
42642
42643C...Formats for output.
42644 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
42645 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
42646 &I2,':',I2/)
42647 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
42648 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
42649 5400 FORMAT(/8X,'Contents',3X,A100)
42650 5500 FORMAT(9X,'*10**',I2,3X,A100)
42651 5600 FORMAT(/8X,'Low edge',3X,A100)
42652 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
42653 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
42654 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
42655
42656 RETURN
42657 END
42658
42659C*********************************************************************
42660
42661C...PYNULL
42662C...Resets bin contents of a histogram.
42663
42664 SUBROUTINE PYNULL(ID)
42665
42666C...Double precision declaration.
42667 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42668C...Commonblock.
42669 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42670 SAVE /PYBINS/
42671
42672 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42673 IS=INDX(ID)
42674 IF(IS.EQ.0) RETURN
42675 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
42676 BIN(IX)=0D0
42677 100 CONTINUE
42678
42679 RETURN
42680 END
42681
42682C*********************************************************************
42683
42684C...PYDUMP
42685C...Dumps histogram contents on file for reading by other program.
42686C...Can also read back own dump.
42687
42688 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
42689
42690C...Double precision declaration.
42691 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42692C...Commonblock.
42693 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42694 SAVE /PYBINS/
42695C...Local arrays and character variables.
42696 DIMENSION IHI(*),ISS(100),VAL(5)
42697 CHARACTER TITLE*60,FORMAT*13
42698
42699C...Dump all histograms that have been booked,
42700C...including titles and ranges, one after the other.
42701 IF(MDUMP.EQ.1) THEN
42702
42703C...Loop over histograms and find which are wanted and booked.
42704 IF(NHI.LE.0) THEN
42705 NW=IHIST(1)
42706 ELSE
42707 NW=NHI
42708 ENDIF
42709 DO 130 IW=1,NW
42710 IF(NHI.EQ.0) THEN
42711 ID=IW
42712 ELSE
42713 ID=IHI(IW)
42714 ENDIF
42715 IS=INDX(ID)
42716 IF(IS.NE.0) THEN
42717
42718C...Write title, histogram size, filling statistics.
42719 NX=NINT(BIN(IS+1))
42720 DO 100 IT=1,20
42721 IEQ=NINT(BIN(IS+8+NX+IT))
42722 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
42723 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
42724 100 CONTINUE
42725 WRITE(LFN,5100) ID,TITLE
42726 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
42727 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
42728 & BIN(IS+8)
42729
42730
42731C...Write histogram contents, in groups of five.
42732 DO 120 IXG=1,(NX+4)/5
42733 DO 110 IXV=1,5
42734 IX=5*IXG+IXV-5
42735 IF(IX.LE.NX) THEN
42736 VAL(IXV)=BIN(IS+8+IX)
42737 ELSE
42738 VAL(IXV)=0D0
42739 ENDIF
42740 110 CONTINUE
42741 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
42742 120 CONTINUE
42743
42744C...Go to next histogram; finish.
42745 ELSEIF(NHI.GT.0) THEN
42746 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
42747 ENDIF
42748 130 CONTINUE
42749
42750C...Read back in histograms dumped MDUMP=1.
42751 ELSEIF(MDUMP.EQ.2) THEN
42752
42753C...Read histogram number, title and range, and book.
42754 140 READ(LFN,5100,END=170) ID,TITLE
42755 READ(LFN,5200) NX,XL,XU
42756 CALL PYBOOK(ID,TITLE,NX,XL,XU)
42757 IS=INDX(ID)
42758
42759C...Read filling statistics.
42760 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
42761 BIN(IS+5)=DBLE(NENTRY)
42762
42763C...Read histogram contents, in groups of five.
42764 DO 160 IXG=1,(NX+4)/5
42765 READ(LFN,5400) (VAL(IXV),IXV=1,5)
42766 DO 150 IXV=1,5
42767 IX=5*IXG+IXV-5
42768 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
42769 150 CONTINUE
42770 160 CONTINUE
42771
42772C...Go to next histogram; finish.
42773 GOTO 140
42774 170 CONTINUE
42775
42776C...Write histogram contents in column format,
42777C...convenient e.g. for GNUPLOT input.
42778 ELSEIF(MDUMP.EQ.3) THEN
42779
42780C...Find addresses to wanted histograms.
42781 NSS=0
42782 IF(NHI.LE.0) THEN
42783 NW=IHIST(1)
42784 ELSE
42785 NW=NHI
42786 ENDIF
42787 DO 180 IW=1,NW
42788 IF(NHI.EQ.0) THEN
42789 ID=IW
42790 ELSE
42791 ID=IHI(IW)
42792 ENDIF
42793 IS=INDX(ID)
42794 IF(IS.NE.0.AND.NSS.LT.100) THEN
42795 NSS=NSS+1
42796 ISS(NSS)=IS
42797 ELSEIF(NSS.GE.100) THEN
42798 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
42799 ELSEIF(NHI.GT.0) THEN
42800 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
42801 ENDIF
42802 180 CONTINUE
42803
42804C...Check that they have common number of x bins. Fix format.
42805 NX=NINT(BIN(ISS(1)+1))
42806 DO 190 IW=2,NSS
42807 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
42808 CALL PYERRM(8,'(PYDUMP:) different number of bins')
42809 RETURN
42810 ENDIF
42811 190 CONTINUE
42812 FORMAT='(1P,000E12.4)'
42813 WRITE(FORMAT(5:7),'(I3)') NSS+1
42814
42815C...Write histogram contents; first column x values.
42816 DO 200 IX=1,NX
42817 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
42818 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
42819 200 CONTINUE
42820
42821 ENDIF
42822
42823C...Formats for output.
42824 5100 FORMAT(I5,5X,A60)
42825 5200 FORMAT(I5,1P,2D12.4)
42826 5300 FORMAT(I12,1P,3D12.4)
42827 5400 FORMAT(1P,5D12.4)
42828
42829 RETURN
42830 END
42831
42832C*********************************************************************
42833
42834C...PYKCUT
42835C...Dummy routine, which the user can replace in order to make cuts on
42836C...the kinematics on the parton level before the matrix elements are
42837C...evaluated and the event is generated. The cross-section estimates
42838C...will automatically take these cuts into account, so the given
42839C...values are for the allowed phase space region only. MCUT=0 means
42840C...that the event has passed the cuts, MCUT=1 that it has failed.
42841
42842 SUBROUTINE PYKCUT(MCUT)
42843
42844C...Double precision and integer declarations.
42845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42846 INTEGER PYK,PYCHGE,PYCOMP
42847C...Commonblocks.
42848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42849 COMMON/PYINT1/MINT(400),VINT(400)
42850 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42851 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
42852
42853C...Set default value (accepting event) for MCUT.
42854 MCUT=0
42855
42856C...Read out subprocess number.
42857 ISUB=MINT(1)
42858 ISTSB=ISET(ISUB)
42859
42860C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
42861 TAU=VINT(21)
42862 YST=VINT(22)
42863 CTH=0D0
42864 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
42865 TAUP=0D0
42866 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
42867
42868C...Calculate x_1, x_2, x_F.
42869 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
42870 X1=SQRT(TAU)*EXP(YST)
42871 X2=SQRT(TAU)*EXP(-YST)
42872 ELSE
42873 X1=SQRT(TAUP)*EXP(YST)
42874 X2=SQRT(TAUP)*EXP(-YST)
42875 ENDIF
42876 XF=X1-X2
42877
42878C...Calculate shat, that, uhat, p_T^2.
42879 SHAT=TAU*VINT(2)
42880 SQM3=VINT(63)
42881 SQM4=VINT(64)
42882 RM3=SQM3/SHAT
42883 RM4=SQM4/SHAT
42884 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
42885 RPTS=4D0*VINT(71)**2/SHAT
42886 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
42887 RM34=2D0*RM3*RM4
42888 RSQM=1D0+RM34
42889 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
42890 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
42891 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
42892 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
42893
42894C...Decisions by user to be put here.
42895
42896C...Stop program if this routine is ever called.
42897C...You should not copy these lines to your own routine.
42898 WRITE(MSTU(11),5000)
42899 IF(PYR(0).LT.10D0) STOP
42900
42901C...Format for error printout.
42902 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
42903 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
42904 &1X,'Execution stopped!')
42905
42906 RETURN
42907 END
42908
42909C*********************************************************************
42910
42911C...PYEVWT
42912C...Dummy routine, which the user can replace in order to multiply the
42913C...standard PYTHIA differential cross-section by a process- and
42914C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
42915C...to generation of weighted events, with weight 1/WTXS, while for
42916C...MSTP(142)=2 it corresponds to a modification of the underlying
42917C...physics.
42918
42919 SUBROUTINE PYEVWT(WTXS)
42920
42921C...Double precision and integer declarations.
42922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42923 INTEGER PYK,PYCHGE,PYCOMP
42924C...Commonblocks.
42925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42926 COMMON/PYINT1/MINT(400),VINT(400)
42927 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42928 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
42929
42930C...Set default weight for WTXS.
42931 WTXS=1D0
42932
42933C...Read out subprocess number.
42934 ISUB=MINT(1)
42935 ISTSB=ISET(ISUB)
42936
42937C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
42938 TAU=VINT(21)
42939 YST=VINT(22)
42940 CTH=0D0
42941 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
42942 TAUP=0D0
42943 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
42944
42945C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
42946 X1=VINT(41)
42947 X2=VINT(42)
42948 XF=X1-X2
42949 SHAT=VINT(44)
42950 THAT=VINT(45)
42951 UHAT=VINT(46)
42952 PT2=VINT(48)
42953
42954C...Modifications by user to be put here.
42955
42956C...Stop program if this routine is ever called.
42957C...You should not copy these lines to your own routine.
42958 WRITE(MSTU(11),5000)
42959 IF(PYR(0).LT.10D0) STOP
42960
42961C...Format for error printout.
42962 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
42963 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
42964 &1X,'Execution stopped!')
42965
42966 RETURN
42967 END
42968
42969C*********************************************************************
42970
42971C...PYUPIN
42972C...Dummy copy of routine to be called by user to set up a user-defined
42973C...process.
42974
42975 SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
42976
42977C...Double precision and integer declarations.
42978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42979 INTEGER PYK,PYCHGE,PYCOMP
42980C...Commonblocks.
42981 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42982 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42983 COMMON/PYINT6/PROC(0:500)
42984 CHARACTER PROC*28
42985 SAVE /PYDAT1/,/PYINT2/,/PYINT6/
42986C...Local character variable.
42987 CHARACTER*(*) TITLE
42988
42989C...Check that subprocess number free.
42990 IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
42991 WRITE(MSTU(11),5000) ISUB
42992 STOP
42993 ENDIF
42994
42995C...Fill information on new process.
42996 ISET(ISUB)=11
42997 COEF(ISUB,1)=SIGMAX
42998 PROC(ISUB)=TITLE//' '
42999
43000C...Format for error output.
43001 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
43002 &' not allowed.'//1X,'Execution stopped!')
43003
43004 RETURN
43005 END
43006
43007C*********************************************************************
43008
43009C...PYUPEV
43010C...Dummy routine, to be replaced by user. When called from PYTHIA
43011C...the subprocess number ISUB will be given, and PYUPEV is supposed
43012C...to generate an event of this type, to be stored in the PYUPPR
43013C...commonblock. SIGEV gives the differential cross-section associated
43014C...with the event, i.e. the acceptance probability of the event is
43015C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
43016C...call.
43017
43018 SUBROUTINE PYUPEV(ISUB,SIGEV)
43019
43020C...Double precision and integer declarations.
43021 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43022 INTEGER PYK,PYCHGE,PYCOMP
43023C...Commonblocks.
43024 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43025 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
43026 SAVE /PYDAT1/,/PYUPPR/
43027
43028C...Stop program if this routine is ever called.
43029C...You should not copy these lines to your own routine.
43030 WRITE(MSTU(11),5000)
43031 IF(PYR(0).LT.10D0) STOP
43032 SIGEV=ISUB
43033
43034C...Format for error printout.
43035 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
43036 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43037 &1X,'Execution stopped!')
43038
43039 RETURN
43040 END
43041
43042C*********************************************************************
43043
43044C...PYTAUD
43045C...Dummy routine, to be replaced by user, to handle the decay of a
43046C...polarized tau lepton.
43047C...Input:
43048C...ITAU is the position where the decaying tau is stored in /PYJETS/.
43049C...IORIG is the position where the mother of the tau is stored;
43050C... is 0 when the mother is not stored.
43051C...KFORIG is the flavour of the mother of the tau;
43052C... is 0 when the mother is not known.
43053C...Note that IORIG=0 does not necessarily imply KFORIG=0;
43054C... e.g. in B hadron semileptonic decays the W propagator
43055C... is not explicitly stored but the W code is still unambiguous.
43056C...Output:
43057C...NDECAY is the number of decay products in the current tau decay.
43058C...These decay products should be added to the /PYJETS/ common block,
43059C...in positions N+1 through N+NDECAY. For each product I you must
43060C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
43061C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
43062
43063 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
43064
43065C...Double precision and integer declarations.
43066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43067 INTEGER PYK,PYCHGE,PYCOMP
43068C...Commonblocks.
43069 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43070 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43071 SAVE /PYJETS/,/PYDAT1/
43072
43073C...Stop program if this routine is ever called.
43074C...You should not copy these lines to your own routine.
43075 NDECAY=ITAU+IORIG+KFORIG
43076 WRITE(MSTU(11),5000)
43077 IF(PYR(0).LT.10D0) STOP
43078
43079C...Format for error printout.
43080 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
43081 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43082 &1X,'Execution stopped!')
43083
43084 RETURN
43085 END
43086
43087C*********************************************************************
43088
43089C...PYTIME
43090C...Finds current date and time.
43091C...Since this task is not standardized in Fortran 77, the routine
43092C...is dummy, to be replaced by the user. Examples are given for
43093C...the Fortran 90 routine and DEC Fortran 77, and what to do if
43094C...you do not have access to suitable routines.
43095
43096 SUBROUTINE PYTIME(IDATI)
43097
43098C...Double precision and integer declarations.
43099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43100 INTEGER PYK,PYCHGE,PYCOMP
43101 CHARACTER*8 ATIME
43102C...Local array.
43103 INTEGER IDATI(6),IDTEMP(3)
43104
43105C...Example 0: if you do not have suitable routines.
43106 DO 100 J=1,6
43107 IDATI(J)=0
43108 100 CONTINUE
43109
43110C...Example 1: Fortran 90 routine.
43111C INTEGER IVAL(8)
43112C CALL DATE_AND_TIME(VALUES=IVAL)
43113C IDATI(1)=IVAL(1)
43114C IDATI(2)=IVAL(2)
43115C IDATI(3)=IVAL(3)
43116C IDATI(4)=IVAL(5)
43117C IDATI(5)=IVAL(6)
43118C IDATI(6)=IVAL(7)
43119
43120C...Example 2: DEC Fortran 77.
43121C CALL IDATE(IMON,IDAY,IYEAR)
43122C IDATI(1)=1900+IYEAR
43123C IDATI(2)=IMON
43124C IDATI(3)=IDAY
43125C CALL ITIME(IHOUR,IMIN,ISEC)
43126C IDATI(4)=IHOUR
43127C IDATI(5)=IMIN
43128C IDATI(6)=ISEC
43129
43130C...Example 3: DEC Fortran
43131C CALL IDATE(IMON,IDAY,IYEAR)
43132C IDATI(1)=1900+IYEAR
43133C IDATI(2)=IMON
43134C IDATI(3)=IDAY
43135C CALL TIME(ATIME)
43136C IHOUR=0
43137C IMIN=0
43138C ISEC=0
43139C READ(ATIME(1:2),'(I2)') IHOUR
43140C READ(ATIME(4:5),'(I2)') IMIN
43141C READ(ATIME(7:8),'(I2)') ISEC
43142C IDATI(4)=IHOUR
43143C IDATI(5)=IMIN
43144C IDATI(6)=ISEC
43145
43146C...Example 4: GNU LINUX libU77.
43147C CALL IDATE(IDTEMP)
43148C IDATI(1)=IDTEMP(3)
43149C IDATI(2)=IDTEMP(2)
43150C IDATI(3)=IDTEMP(1)
43151C CALL ITIME(IDTEMP)
43152C IDATI(4)=IDTEMP(1)
43153C IDATI(5)=IDTEMP(2)
43154C IDATI(6)=IDTEMP(3)
43155
43156 RETURN
43157 END