C++ Interface to Tauola
pythia6152.f
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* Physics Department, UC Davis **
20C* One Shields Avenue, Davis, CA 95616, USA **
21C* phone + 1 - 530 - 752 - 2661 **
22C* E-mail mrenna@physics.ucdavis.edu **
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* code for virtual photons mainly written by Christer Friberg **
28C* code for low-mass strings mainly written by Emanuel Norrbin **
29C* Bose-Einstein code mainly written by Leif Lonnblad **
30C* CTEQ parton distributions are by the CTEQ collaboration **
31C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
32C* SaS photon parton distributions together with Gerhard Schuler **
33C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
34C* MSSM Higgs mass calculation code by M. Carena, **
35C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
36C* PYGAUS adapted from CERN library (K.S. Kolbig) **
37C* **
38C* The latest program version and documentation is found on WWW **
39C* http://www.thep.lu.se/~torbjorn/Pythia.html **
40C* **
41C* Copyright Torbjorn Sjostrand, Lund 1997 **
42C* **
43C*********************************************************************
44C*********************************************************************
45C *
46C List of subprograms in order of appearance, with main purpose *
47C (S = subroutine, F = function, B = block data) *
48C *
49C B PYDATA to contain all default values *
50C S PYTEST to test the proper functioning of the package *
51C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
52C *
53C S PYINIT to administer the initialization procedure *
54C S PYEVNT to administer the generation of an event *
55C S PYSTAT to print cross-section and other information *
56C S PYINRE to initialize treatment of resonances *
57C S PYINBM to read in beam, target and frame choices *
58C S PYINKI to initialize kinematics of incoming particles *
59C S PYINPR to set up the selection of included processes *
60C S PYXTOT to give total, elastic and diffractive cross-sect. *
61C S PYMAXI to find differential cross-section maxima *
62C S PYPILE to select multiplicity of pileup events *
63C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
64C S PYGAGA to handle lepton -> lepton + gamma branchings *
65C S PYRAND to select subprocess and kinematics for event *
66C S PYSCAT to set up kinematics and colour flow of event *
67C S PYSSPA to simulate initial state spacelike showers *
68C S PYRESD to perform resonance decays *
69C S PYMULT to generate multiple interactions *
70C S PYREMN to add on target remnants *
71C S PYDIFF to set up kinematics for diffractive events *
72C S PYDISG to set up kinematics, remnant and showers for DIS *
73C S PYDOCU to compute cross-sections and handle documentation *
74C S PYFRAM to perform boosts between different frames *
75C S PYWIDT to calculate full and partial widths of resonances *
76C S PYOFSH to calculate partial width into off-shell channels *
77C S PYRECO to handle colour reconnection in W+W- events *
78C S PYKLIM to calculate borders of allowed kinematical region *
79C S PYKMAP to construct value of kinematical variable *
80C S PYSIGH to calculate differential cross-sections *
81C S PYPDFU to evaluate parton distributions *
82C S PYPDFL to evaluate parton distributions at low x and Q^2 *
83C S PYPDEL to evaluate electron parton distributions *
84C S PYPDGA to evaluate photon parton distributions (generic) *
85C S PYGGAM to evaluate photon parton distributions (SaS sets) *
86C S PYGVMD to evaluate VMD part of photon parton distributions *
87C S PYGANO to evaluate anomalous part of photon pdf's *
88C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
89C S PYGDIR to evaluate direct contribution to photon pdf's *
90C S PYPDPI to evaluate pion parton distributions *
91C S PYPDPR to evaluate proton parton distributions *
92C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
93C S PYGRVL to evaluate the GRV 94L proton parton distributions *
94C S PYGRVM to evaluate the GRV 94M proton parton distributions *
95C S PYGRVD to evaluate the GRV 94D proton parton distributions *
96C F PYGRVV auxiliary to the PYGRV* routines *
97C F PYGRVW auxiliary to the PYGRV* routines *
98C F PYGRVS auxiliary to the PYGRV* routines *
99C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
100C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
101C S PYPDPO to evaluate old proton parton distributions *
102C F PYHFTH to evaluate threshold factor for heavy flavour *
103C S PYSPLI to find flavours left in hadron when one removed *
104C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
105C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
106C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
107C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
108C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
109C *
110C S PYMSIN to initialize the supersymmetry simulation *
111C S PYAPPS to determine MSSM parameters from SUGRA input *
112C F PYRNMQ to determine running quark masses *
113C F PYRNMT to determine running top mass *
114C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
115C S PYINOM to calculate neutralino/chargino mass eigenstates *
116C F PYRNM3 to determine running M3, gluino mass *
117C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
118C S PYHGGM to determine Higgs mass spectrum *
119C S PYSUBH to determine Higgs masses in the MSSM *
120C S PYPOLE to determine Higgs masses in the MSSM *
121C S PYVACU to determine Higgs masses in the MSSM *
122C S PYRGHM auxiliary to PYVACU *
123C S PYGFXX auxiliary to PYRGHM *
124C F PYFINT auxiliary to PYVACU *
125C F PYFISB auxiliary to PYFINT *
126C S PYSFDC to calculate sfermion decay partial widths *
127C S PYGLUI to calculate gluino decay partial widths *
128C S PYTBBN to calculate 3-body decay of gluino to neutralino *
129C S PYTBBC to calculate 3-body decay of gluino to chargino *
130C S PYNJDC to calculate neutralino decay partial widths *
131C S PYCJDC to calculate chargino decay partial widths *
132C F PYXXZ5 auxiliary for neutralino 3-body decay *
133C F PYXXW5 auxiliary for ino charge change 3-body decay *
134C F PYXXGA auxiliary for ino -> ino + gamma decay *
135C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
136C F PYX2XH auxiliary for ino -> ino + Higgs decay *
137C F PYXXZ2 auxiliary for chargino 3-body decay *
138C S PYHEXT to calculate non-SM Higgs decay partial widths *
139C F PYH2XX auxiliary for H -> ino + ino decay *
140C F PYGAUS to perform Gaussian integration *
141C F PYSIMP to perform Simpson integration *
142C F PYLAMF to evaluate the lambda kinematics function *
143C S PYTBDY to perform 3-body decay of gauginos *
144C S PYTECM to calculate techni_rho/omega masses *
145C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
146C *
147C S PY1ENT to fill one entry (= parton or particle) *
148C S PY2ENT to fill two entries *
149C S PY3ENT to fill three entries *
150C S PY4ENT to fill four entries *
151C S PY2FRM to interface to generic two-fermion generator *
152C S PY4FRM to interface to generic four-fermion generator *
153C S PY6FRM to interface to generic six-fermion generator *
154C S PY4JET to generate a shower from a given 4-parton config *
155C S PY4JTW to evaluate the weight od a shower history for above *
156C S PY4JTS to set up the parton configuration for above *
157C S PYJOIN to connect entries with colour flow information *
158C S PYGIVE to fill (or query) commonblock variables *
159C S PYEXEC to administrate fragmentation and decay chain *
160C S PYPREP to rearrange showered partons along strings *
161C S PYSTRF to do string fragmentation of jet system *
162C S PYINDF to do independent fragmentation of one or many jets *
163C S PYDECY to do the decay of a particle *
164C S PYDCYK to select parton and hadron flavours in decays *
165C S PYKFDI to select parton and hadron flavours in fragm *
166C S PYNMES to select number of popcorn mesons *
167C S PYKFIN to calculate falvour prod. ratios from input params. *
168C S PYPTDI to select transverse momenta in fragm *
169C S PYZDIS to select longitudinal scaling variable in fragm *
170C S PYSHOW to do timelike parton shower evolution *
171C S PYBOEI to include Bose-Einstein effects (crudely) *
172C S PYBESQ auxiliary to PYBOEI *
173C F PYMASS to give the mass of a particle or parton *
174C F PYMRUN to give the running MSbar mass of a quark *
175C S PYNAME to give the name of a particle or parton *
176C F PYCHGE to give three times the electric charge *
177C F PYCOMP to compress standard KF flavour code to internal KC *
178C S PYERRM to write error messages and abort faulty run *
179C F PYALEM to give the alpha_electromagnetic value *
180C F PYALPS to give the alpha_strong value *
181C F PYANGL to give the angle from known x and y components *
182C F PYR to provide a random number generator *
183C S PYRGET to save the state of the random number generator *
184C S PYRSET to set the state of the random number generator *
185C S PYROBO to rotate and/or boost an event *
186C S PYEDIT to remove unwanted entries from record *
187C S PYLIST to list event record or particle data *
188C S PYLOGO to write a logo *
189C S PYUPDA to update particle data *
190C F PYK to provide integer-valued event information *
191C F PYP to provide real-valued event information *
192C S PYSPHE to perform sphericity analysis *
193C S PYTHRU to perform thrust analysis *
194C S PYCLUS to perform three-dimensional cluster analysis *
195C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
196C S PYJMAS to give high and low jet mass of event *
197C S PYFOWO to give Fox-Wolfram moments *
198C S PYTABU to analyze events, with tabular output *
199C *
200C S PYEEVT to administrate the generation of an e+e- event *
201C S PYXTEE to give the total cross-section at given CM energy *
202C S PYRADK to generate initial state photon radiation *
203C S PYXKFL to select flavour of primary qqbar pair *
204C S PYXJET to select (matrix element) jet multiplicity *
205C S PYX3JT to select kinematics of three-jet event *
206C S PYX4JT to select kinematics of four-jet event *
207C S PYXDIF to select angular orientation of event *
208C S PYONIA to perform generation of onium decay to gluons *
209C *
210C S PYBOOK to book a histogram *
211C S PYFILL to fill an entry in a histogram *
212C S PYFACT to multiply histogram contents by a factor *
213C S PYOPER to perform operations between histograms *
214C S PYHIST to print and reset all histograms *
215C S PYPLOT to print a single histogram *
216C S PYNULL to reset contents of a single histogram *
217C S PYDUMP to dump histogram contents onto a file *
218C *
219C S PYKCUT dummy routine for user kinematical cuts *
220C S PYEVWT dummy routine for weighting events *
221C S PYUPIN dummy routine to initialize a user process *
222C S PYUPEV dummy routine to generate a user process event *
223C S PDFSET dummy routine to be removed when using PDFLIB *
224C S STRUCTM dummy routine to be removed when using PDFLIB *
225C S STRUCTP dummy routine to be removed when using PDFLIB *
226C S PYTAUD dummy routine for interface to tau decay libraries *
227C S PYTIME dummy routine for giving date and time *
228C *
229C*********************************************************************
230
231C...PYDATA
232C...Default values for switches and parameters,
233C...and particle, decay and process data.
234
235 BLOCK DATA pydata
236
237C...Double precision and integer declarations.
238 IMPLICIT DOUBLE PRECISION(a-h, o-z)
239 IMPLICIT INTEGER(I-N)
240 INTEGER PYK,PYCHGE,PYCOMP
241C...Commonblocks.
242 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
243 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
244 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
245 common/pydat4/chaf(500,2)
246 CHARACTER CHAF*16
247 common/pydatr/mrpy(6),rrpy(100)
248 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
249 common/pypars/mstp(200),parp(200),msti(200),pari(200)
250 common/pyint1/mint(400),vint(400)
251 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
252 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
253 common/pyint4/mwid(500),wids(500,5)
254 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
255 common/pyint6/proc(0:500)
256 CHARACTER PROC*28
257 common/pyint7/sigt(0:6,0:6,0:5)
258 common/pymssm/imss(0:99),rmss(0:99)
259 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
260 &sfmix(16,4)
261 common/pybins/ihist(4),indx(1000),bin(20000)
262 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,/pysubs/,
263 &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
264 &/pyint6/,/pyint7/,/pymssm/,/pyssmt/,/pybins/
265
266C...PYDAT1, containing status codes and most parameters.
267 DATA mstu/
268 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
269 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
270 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
271 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
272 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
273 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
274 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
275 7 30*0,
276 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
277 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
278 & 80*0/
279 DATA (paru(i),i=1,100)/
280 & 3.141592653589793d0, 6.283185307179586d0,
281 & 0.197327d0, 5.06773d0, 0.389380d0, 2.56819d0, 4*0d0,
282 1 0.001d0, 0.09d0, 0.01d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
283 2 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
284 3 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
285 4 2.0d0, 1.0d0, 0.25d0, 2.5d0, 0.05d0,
286 4 0d0, 0d0, 0.0001d0, 0d0, 0d0,
287 5 2.5d0,1.5d0,7.0d0,1.0d0,0.5d0,2.0d0,3.2d0, 0d0, 0d0, 0d0,
288 6 40*0d0/
289 DATA (paru(i),i=101,200)/
290 & 0.00729735d0, 0.232d0, 0.007764d0, 1.0d0, 1.16639d-5,
291 & 0d0, 0d0, 0d0, 0d0, 0d0,
292 1 0.20d0, 0.25d0, 1.0d0, 4.0d0, 10d0, 0d0, 0d0, 0d0, 0d0, 0d0,
293 2 -0.693d0, -1.0d0, 0.387d0, 1.0d0, -0.08d0,
294 2 -1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,
295 3 1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
296 4 5.0d0, 1.0d0, 1.0d0, 0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0,
297 5 1.0d0, 0d0, 0d0, 0d0, 1000d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0,0d0,
298 6 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
299 7 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
300 8 1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
301 9 0d0, 0d0, 0d0, 0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0/
302 DATA mstj/
303 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
304 1 4, 2, 0, 1, 0, 2, 2, 0, 0, 0,
305 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
306 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
307 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
308 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
309 6 40*0,
310 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
311 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
312 2 80*0/
313 DATA parj/
314 & 0.10d0, 0.30d0, 0.40d0, 0.05d0, 0.50d0,
315 & 0.50d0, 0.50d0, 0.6d0, 1.2d0, 0.6d0,
316 1 0.50d0,0.60d0,0.75d0, 0d0, 0d0, 0d0, 0d0, 1.0d0, 1.0d0, 0d0,
317 2 0.36d0, 1.0d0,0.01d0, 2.0d0,1.0d0,0.4d0, 0d0, 0d0, 0d0, 0d0,
318 3 0.10d0, 1.0d0, 0.8d0, 1.5d0,0d0,2.0d0,0.2d0, 0d0,0.08d0,0d0,
319 4 0.3d0, 0.58d0, 0.5d0, 0.9d0,0.5d0,1.0d0,1.0d0,1.0d0,0d0,0d0,
320 5 0.77d0, 0.77d0, 0.77d0, -0.05d0, -0.005d0,
321 5 -0.00001d0, -0.00001d0, -0.00001d0, 1.0d0, 0d0,
322 6 4.5d0, 0.7d0, 0d0,0.003d0, 0.5d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
323 7 10d0, 1000d0, 100d0, 1000d0, 0d0, 0.7d0,10d0, 0d0, 0d0, 0d0,
324 8 0.29d0, 1.0d0, 1.0d0, 0d0, 10d0, 10d0, 0d0, 0d0, 0d0,1d-4,
325 9 0.02d0, 1.0d0, 0.2d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
326 & 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
327 1 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
328 2 1.0d0, 0.25d0,91.187d0,2.489d0, 0.01d0,
329 2 2.0d0, 1.0d0, 0.25d0,0.002d0, 0d0,
330 3 0d0, 0d0, 0d0, 0d0, 0.01d0, 0.99d0, 0d0, 0d0, 0.2d0, 0d0,
331 4 10*0d0,
332 5 10*0d0,
333 6 10*0d0,
334 7 0d0, 200d0, 200d0, .333d0, .05d0, 0d0, 0d0, 0d0, 0d0, -0.693d0,
335 8 -1.0d0, 0.387d0, 1.0d0, -0.08d0, -1.0d0,
336 8 1.0d0, 1.0d0, -0.693d0, -1.0d0, 0.387d0,
337 9 1.0d0, -0.08d0, -1.0d0, 1.0d0, 1.0d0,
338 9 5*0d0/
339
340C...PYDAT2, with particle data and flavour treatment parameters.
341 DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
342 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,5*0,2*6,3,20*0,2,-1,
343 &20*0,4*3,8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,
344 &3*0,4,3*3,6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,
345 &2*4,2*3,2*6,3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,
346 &2*1,2*0,2*3,0,3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,
347 &2*0,2*-3,2*0,-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,
348 &3*0,3,2*0,3,0,3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,
349 &4*0,3,2*0,3,0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
350 DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
351 &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,
352 &-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,
353 &6*1,6*0,2*1,165*0/
354 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,
355 &11*0,1,2*0,1,5*0,6*1,15*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,
356 &12*1,3*0,102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,
357 &0,4*1,3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
358 DATA (kchg(i,4),i= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
359 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
360 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
361 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
362 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
363 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
364 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
365 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
366 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
367 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
368 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
369 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
370 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
371 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
372 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
373 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
374 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
375 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
376 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
377 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
378 DATA (kchg(i,4),i= 294, 500)/20443,20513,20523,20533,20543,20553,
379 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
380 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
381 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
382 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
383 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
384 DATA (pmas(i,1),i= 1, 211)/0.33d0,0.33d0,0.50d0,1.50d0,
385 &4.80d0,175d0,2*400d0,2*0d0,0.00051d0,0d0,0.10566d0,0d0,1.777d0,
386 &0d0,400d0,5*0d0,91.187d0,80.33d0,80d0,6*0d0,500d0,900d0,500d0,
387 &3*300d0,350d0,200d0,5000d0,10*0d0,3*110d0,3*210d0,4*0d0,2*200d0,
388 &4*750d0,16*0d0,1d0,2d0,5d0,16*0d0,0.13498d0,0.7685d0,1.318d0,
389 &0.49767d0,0d0,0.13957d0,0.7669d0,1.318d0,0d0,0.54745d0,0.78194d0,
390 &1.275d0,2*0.49767d0,0.8961d0,1.432d0,0.4936d0,0.8916d0,1.425d0,
391 &0d0,0.95777d0,1.0194d0,1.525d0,1.8693d0,2.01d0,2.46d0,1.8645d0,
392 &2.0067d0,2.46d0,1.9685d0,2.1124d0,2.5735d0,0d0,2.9798d0,
393 &3.09688d0,3.5562d0,5.2792d0,5.3248d0,5.83d0,5.2789d0,5.3248d0,
394 &5.83d0,5.3693d0,5.4163d0,6.07d0,6.594d0,6.602d0,7.35d0,9.4d0,
395 &9.4603d0,9.9132d0,0.77133d0,1.234d0,0.57933d0,0.77133d0,0d0,
396 &0.93957d0,1.233d0,0.77133d0,0d0,0.93827d0,1.232d0,1.231d0,
397 &0.80473d0,0.92953d0,1.19744d0,1.3872d0,1.11568d0,0.80473d0,
398 &0.92953d0,1.19255d0,1.3837d0,1.18937d0,1.3828d0,1.09361d0,
399 &1.3213d0,1.535d0,1.3149d0,1.5318d0,1.67245d0,1.96908d0,2.00808d0,
400 &2.4521d0,2.5d0,2.2849d0,2.4703d0,1.96908d0,2.00808d0,2.4535d0,
401 &2.5d0,2.4529d0,2.5d0,2.4656d0,2.15432d0,2.17967d0,2.55d0,2.63d0,
402 &2.55d0,2.63d0,2.704d0,2.8d0,3.27531d0,3.59798d0,3.65648d0,
403 &3.59798d0,3.65648d0,3.78663d0,3.82466d0,4.91594d0,5.38897d0/
404 DATA (pmas(i,1),i= 212, 500)/5.40145d0,5.8d0,5.81d0,5.641d0,
405 &5.84d0,7.00575d0,5.38897d0,5.40145d0,5.8d0,5.81d0,5.8d0,5.81d0,
406 &5.84d0,7.00575d0,5.56725d0,5.57536d0,5.96d0,5.97d0,5.96d0,5.97d0,
407 &6.12d0,6.13d0,7.19099d0,6.67143d0,6.67397d0,7.03724d0,7.0485d0,
408 &7.03724d0,7.0485d0,7.21101d0,7.219d0,8.30945d0,8.31325d0,
409 &10.07354d0,10.42272d0,10.44144d0,10.42272d0,10.44144d0,
410 &10.60209d0,10.61426d0,11.70767d0,11.71147d0,15.11061d0,0.9835d0,
411 &1.231d0,0.9835d0,1.231d0,1d0,1.17d0,1.429d0,1.29d0,1.429d0,
412 &1.29d0,2*1.4d0,2.272d0,2.424d0,2.272d0,2.424d0,2.5d0,2.536d0,
413 &3.4151d0,3.46d0,5.68d0,5.73d0,5.68d0,5.73d0,5.92d0,5.97d0,7.25d0,
414 &7.3d0,9.8598d0,9.875d0,2*1.23d0,1.282d0,2*1.402d0,1.427d0,
415 &2*2.372d0,2.56d0,3.5106d0,2*5.78d0,6.02d0,7.3d0,9.8919d0,3.686d0,
416 &10.0233d0,32*500d0,4*400d0,163*0d0/
417 DATA (pmas(i,2),i= 1, 500)/5*0d0,1.39883d0,16*0d0,2.48009d0,
418 &2.07002d0,0.00237d0,6*0d0,14.54848d0,0d0,16.6708d0,8.42842d0,
419 &4.92026d0,5.75967d0,0.10158d0,0.39162d0,417.4648d0,10*0d0,
420 &0.04104d0,0.0105d0,0.02807d0,0.82101d0,0.64973d0,0.1575d0,4*0d0,
421 &0.88161d0,0.88001d0,19.33905d0,39*0d0,0.151d0,0.107d0,3*0d0,
422 &0.149d0,0.107d0,2*0d0,0.00843d0,0.185d0,2*0d0,0.0505d0,0.109d0,
423 &0d0,0.0498d0,0.098d0,0d0,0.0002d0,0.00443d0,0.076d0,2*0d0,
424 &0.023d0,2*0d0,0.023d0,2*0d0,0.015d0,0d0,0.0013d0,0d0,0.002d0,
425 &2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,4*0d0,0.12d0,
426 &4*0d0,0.12d0,3*0d0,2*0.12d0,3*0d0,0.0394d0,4*0d0,0.036d0,0d0,
427 &0.0358d0,2*0d0,0.0099d0,0d0,0.0091d0,74*0d0,0.06d0,0.142d0,
428 &0.06d0,0.142d0,0d0,0.36d0,0.287d0,0.09d0,0.287d0,0.09d0,0.25d0,
429 &0.08d0,0.05d0,0.02d0,0.05d0,0.02d0,0.05d0,0d0,0.014d0,0.01d0,
430 &8*0.05d0,0d0,0.01d0,2*0.4d0,0.025d0,2*0.174d0,0.053d0,3*0.05d0,
431 &0.0009d0,4*0.05d0,3*0d0,19*1d0,0d0,7*1d0,0d0,1d0,0d0,1d0,0d0,
432 &2.65171d0,2.65499d0,0.42901d0,0.41917d0,163*0d0/
433 DATA (pmas(i,3),i= 1, 500)/5*0d0,13.98835d0,16*0d0,24.8009d0,
434 &20.70015d0,0.02369d0,6*0d0,145.48484d0,0d0,166.70801d0,
435 &84.28416d0,49.20256d0,57.59671d0,1.0158d0,3.91624d0,4174.64797d0,
436 &10*0d0,0.41042d0,0.10504d0,0.28068d0,8.21005d0,6.49728d0,
437 &1.57496d0,4*0d0,8.81606d0,8.80013d0,193.39048d0,39*0d0,0.4d0,
438 &0.25d0,3*0d0,0.4d0,0.25d0,2*0d0,0.1d0,0.17d0,2*0d0,0.2d0,0.12d0,
439 &0d0,0.2d0,0.12d0,0d0,0.002d0,0.015d0,0.2d0,2*0d0,0.12d0,2*0d0,
440 &0.12d0,2*0d0,0.05d0,0d0,0.005d0,0d0,0.01d0,2*0d0,0.05d0,2*0d0,
441 &0.05d0,2*0d0,0.05d0,2*0d0,0.05d0,4*0d0,0.14d0,4*0d0,0.14d0,3*0d0,
442 &2*0.14d0,3*0d0,0.04d0,4*0d0,0.035d0,0d0,0.035d0,2*0d0,0.05d0,0d0,
443 &0.05d0,74*0d0,0.05d0,0.25d0,0.05d0,0.25d0,0d0,0.2d0,0.4d0,
444 &0.005d0,0.4d0,0.01d0,0.35d0,0.001d0,0.1d0,0.08d0,0.1d0,0.08d0,
445 &0.1d0,0d0,0.05d0,0.02d0,6*0.1d0,0.05d0,0.1d0,0d0,0.02d0,2*0.3d0,
446 &0.05d0,2*0.3d0,0.02d0,2*0.1d0,0.03d0,0.001d0,4*0.1d0,3*0d0,
447 &19*10d0,0.00001d0,7*10d0,0.00001d0,10d0,0.00001d0,10d0,0.00001d0,
448 &26.51715d0,26.54994d0,4.29011d0,4.19173d0,163*0d0/
449 DATA (pmas(i,4),i= 1, 500)/12*0d0,658654d0,0d0,0.0872d0,68*0d0,
450 &0.1d0,0.387d0,16*0d0,0.00003d0,2*0d0,15500d0,0d0,7804.5d0,6*0d0,
451 &26.762d0,3*0d0,3709d0,6*0d0,0.317d0,2*0d0,0.1244d0,2*0d0,0.14d0,
452 &6*0d0,0.468d0,2*0d0,0.462d0,2*0d0,0.483d0,2*0d0,0.15d0,19*0d0,
453 &44.34d0,0d0,78.88d0,4*0d0,23.96d0,2*0d0,49.1d0,0d0,87.1d0,0d0,
454 &24.6d0,4*0d0,0.0618d0,0.029d0,6*0d0,0.106d0,6*0d0,0.019d0,2*0d0,
455 &7*0.1d0,4*0d0,0.342d0,2*0.387d0,6*0d0,2*0.387d0,6*0d0,0.387d0,
456 &0d0,0.387d0,2*0d0,8*0.387d0,0d0,9*0.387d0,83*0d0,163*0d0/
457 DATA parf/
458 & 0.5d0,0.25d0, 0.5d0,0.25d0, 1d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
459 1 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
460 2 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
461 3 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
462 4 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
463 5 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
464 6 0.75d0, 0.5d0, 0d0,0.1667d0,0.0833d0,0.1667d0,0d0,0d0,0d0, 0d0,
465 7 0d0, 0d0, 1d0,0.3333d0,0.6667d0,0.3333d0,0d0,0d0,0d0, 0d0,
466 8 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
467 9 0.0099d0, 0.0056d0, 0.199d0, 1.35d0, 4.5d0, 5*0d0,
468 & 0.325d0,0.325d0,0.5d0,1.6d0, 5.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
469 1 0d0,0.11d0,0.16d0,0.048d0,0.50d0,0.45d0,0.55d0,0.60d0,0d0,0d0,
470 2 0.2d0, 0.1d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
471 3 60*0d0,
472 4 0.2d0, 0.5d0, 8*0d0,
473 5 1800*0d0/
474 DATA ((vckm(i,j),j=1,4),i=1,4)/
475 & 0.95113d0, 0.04884d0, 0.00003d0, 0.00000d0,
476 & 0.04884d0, 0.94940d0, 0.00176d0, 0.00000d0,
477 & 0.00003d0, 0.00176d0, 0.99821d0, 0.00000d0,
478 & 0.00000d0, 0.00000d0, 0.00000d0, 1.00000d0/
479
480C...PYDAT3, with particle decay parameters and data.
481 DATA (mdcy(i,1),i= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
482 &7*1,10*0,6*1,4*0,3*1,19*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,
483 &12*1,0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,
484 &5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,
485 &1,0,1,0,4*1,163*0/
486 DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,56,66,2*0,76,80,82,
487 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,416,
488 &496,523,526,527,10*0,536,544,550,558,582,608,4*0,632,639,646,
489 &19*0,658,659,663,16*0,672,674,679,688,0,697,699,701,0,708,716,
490 &722,731,733,735,738,748,754,757,0,768,774,785,791,854,857,865,
491 &926,928,936,969,971,0,975,976,979,981,1017,1018,1026,1062,1063,
492 &1071,1110,1111,1115,1146,1147,1151,1152,1161,0,1163,4*0,1164,3*0,
493 &1167,1170,2*0,1171,1173,1176,2*0,1180,1181,1184,1187,0,1190,1195,
494 &1197,1200,1202,2*0,1206,1207,1208,1284,2*0,1288,1289,1290,1291,
495 &1292,2*0,1296,1297,1299,1300,1302,1306,0,1307,1311,1315,1319,
496 &1323,1327,1331,2*0,1335,1336,1337,1354,1363,2*0,1372,1373,1374,
497 &1375,1376,1385,2*0,1394,1395,1396,1397,1398,1407,1408,2*0,1417,
498 &1426,1435,1444,1453,1462,1471,1480,0,1489,1498,1507,1516,1525,
499 &1534,1543,1552,1561,1570,1571,1572,1573,1574,1579,1582,1584,1589,
500 &1591,1596,1603,1607,1609,1611,1613,1615,1617,1619,1621,1622,1624,
501 &1626,1628,1630,1632,1634,1636,1638,1640,1641,1643,1645,1659,1661,
502 &1663,1667,1669,1671,1673,1675,1677,1679,1681,1683,1685,1696,1710,
503 &1722,1734,1746,1758,1770,1785,1796,1807,1818,1829,1840,1851,1912,
504 &1919,2021,2077,2195,2329,0,2400,2416,2432,2448,2464,2480,2496,0,
505 &2511,0,2526,0,2541,2545,2549,2552,163*0/
506 DATA (mdcy(i,3),i= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
507 &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,8,6,8,24,26,24,
508 &4*0,2*7,12,19*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,
509 &11,0,6,11,6,63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,
510 &1,4,1,9,2,0,1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,
511 &2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,
512 &2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,
513 &2*2,14,2*2,4,9*2,11,14,5*12,15,6*11,61,7,102,56,118,134,71,0,
514 &6*16,15,0,15,0,15,0,2*4,3,2,163*0/
515 DATA (mdme(i,1),i= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
516 &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
517 &2*-1, 3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
518 &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,
519 &4*-1,6*1,2*-1,3*1,-1,8*1,62*1,6*1,2*-1,3*1,-1,6*1,62*1,3*1,-1,
520 &3*1,-1,1,18*1,8*1,2*-1,2*1,-1,36*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,
521 &3*1,5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,1151*1,2*-1,132*1,2*-1,635*1,
522 &1447*0/
523 DATA (mdme(i,2),i= 1,4000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
524 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
525 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
526 &8*32,14*0,16*32,7*0,8*32,12*0,62*53,8*32,10*0,62*53,4*32,5*0,
527 &18*53,3*32,0,6*32,3*0,4*32,3*0,4*32,3*0,4*32,3*0,32,8*0,8*32,
528 &14*0,16*32,12*0,8*32,22*0,9*32,3*0,12,2*42,2*11,9*42,0,2,3,15*0,
529 &4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,
530 &1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,
531 &12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,
532 &2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,
533 &2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,
534 &2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,
535 &2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,
536 &162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,
537 &5*0,832*53,1459*0/
538 DATA (brat(i) ,i= 1, 348)/43*0d0,0.00003d0,0.001765d0,
539 &0.998205d0,35*0d0,1d0,6*0d0,0.1783d0,0.1735d0,0.1131d0,0.2494d0,
540 &0.003d0,0.09d0,0.0027d0,0.01d0,0.0014d0,0.0012d0,2*0.00025d0,
541 &0.0071d0,0.012d0,0.0004d0,0.00075d0,0.00006d0,2*0.00078d0,
542 &0.0034d0,0.08d0,0.011d0,0.0191d0,0.00006d0,0.005d0,0.0133d0,
543 &0.0067d0,0.0005d0,0.0035d0,0.0006d0,0.0015d0,0.00021d0,0.0002d0,
544 &0.00075d0,0.0001d0,0.0002d0,0.0011d0,3*0.0002d0,0.00022d0,
545 &0.0004d0,0.0001d0,2*0.00205d0,2*0.00069d0,0.00025d0,0.00051d0,
546 &0.00025d0,35*0d0,0.154075d0,0.119483d0,0.154072d0,0.119346d0,
547 &0.152196d0,3*0d0,0.033549d0,0.066752d0,0.033549d0,0.066752d0,
548 &0.033473d0,0.066752d0,2*0d0,0.321502d0,0.016502d0,2*0d0,
549 &0.016509d0,0.320778d0,2*0d0,0.00001d0,0.000591d0,6*0d0,
550 &2*0.108062d0,0.107983d0,0d0,0.000001d0,0d0,0.000327d0,0.053489d0,
551 &0.852249d0,4*0d0,0.000244d0,0.06883d0,0d0,0.023981d0,0.000879d0,
552 &65*0d0,0.145869d0,0.113303d0,0.145869d0,0.113298d0,0.14581d0,
553 &0.049013d0,2*0d0,0.032007d0,0.063606d0,0.032007d0,0.063606d0,
554 &0.032004d0,0.063606d0,8*0d0,0.251276d0,0.012903d0,0.000006d0,0d0,
555 &0.012903d0,0.250816d0,0.00038d0,0d0,0.000008d0,0.000465d0,
556 &0.215459d0,5*0d0,2*0.085262d0,0.08526d0,7*0d0,0.000046d0,
557 &0.000754d0,5*0d0,0.000074d0,0d0,0.000439d0,0.000015d0,0.000061d0/
558 DATA (brat(i) ,i= 349, 642)/0.306171d0,0.68864d0,0d0,0.003799d0,
559 &66*0d0,0.000079d0,0.001292d0,5*0d0,0.000126d0,0d0,0.002256d0,
560 &0.00001d0,0.000002d0,2*0d0,0.996233d0,63*0d0,0.000013d0,
561 &0.067484d0,2*0d0,0.00001d0,0.002701d0,0d0,0.929792d0,18*0d0,
562 &0.452899d0,0d0,0.547101d0,1d0,2*0.215134d0,0.215133d0,0.214738d0,
563 &2*0d0,2*0.06993d0,0d0,0.000225d0,0.036777d0,0.596654d0,2*0d0,
564 &0.000177d0,0.050055d0,0.316112d0,0.041762d0,0.90916d0,2*0d0,
565 &0.000173d0,0.048905d0,0.000328d0,0.053776d0,0.872444d0,2*0d0,
566 &0.000259d0,0.073192d0,0d0,0.153373d0,2*0.342801d0,0d0,0.086867d0,
567 &0.03128d0,0.001598d0,0.000768d0,0.004789d0,0.006911d0,0.004789d0,
568 &0.006911d0,0.004789d0,3*0d0,0.003077d0,0.00103d0,0.003077d0,
569 &0.00103d0,0.003077d0,0.00103d0,2*0d0,0.138845d0,0.474102d0,
570 &0.176299d0,0d0,0.109767d0,0.008161d0,0.028584d0,0.001468d0,2*0d0,
571 &0.001468d0,0.02853d0,0.000007d0,0d0,0.000001d0,0.000053d0,
572 &0.003735d0,5*0d0,2*0.009661d0,0.00966d0,0d0,0.163019d0,
573 &0.004003d0,0.45294d0,0.008334d0,2*0.038042d0,0.001999d0,0d0,
574 &0.017733d0,0.045908d0,0.017733d0,0.045908d0,0.017733d0,3*0d0,
575 &0.038354d0,0.011181d0,0.038354d0,0.011181d0,0.038354d0,
576 &0.011181d0,2*0d0,0.090264d0,2*0.001805d0,0.090264d0,0.001805d0,
577 &0.81225d0,0.001806d0,0.090428d0,0.001809d0,0.001808d0,0.090428d0/
578 DATA (brat(i) ,i= 643, 803)/0.001808d0,0.81372d0,0d0,0.325914d0,
579 &0.016735d0,0.000009d0,0.016736d0,0.32532d0,0.000554d0,0.00001d0,
580 &0.000603d0,0.314118d0,3*0d0,1d0,2*0.08d0,0.76d0,0.08d0,2*0.105d0,
581 &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,0.988d0,
582 &0.012d0,0.998739d0,0.00079d0,0.00038d0,0.000046d0,0.000045d0,
583 &2*0.34725d0,0.144d0,0.104d0,0.0245d0,2*0.01225d0,0.0028d0,
584 &0.0057d0,0.2112d0,0.1256d0,2*0.1939d0,2*0.1359d0,0.002d0,0.001d0,
585 &0.0006d0,0.999877d0,0.000123d0,0.99955d0,0.00045d0,2*0.34725d0,
586 &0.144d0,0.104d0,0.049d0,0.0028d0,0.0057d0,0.3923d0,0.321d0,
587 &0.2317d0,0.0478d0,0.0049d0,0.0013d0,0.0003d0,0.0007d0,0.89d0,
588 &0.08693d0,0.0221d0,0.00083d0,2*0.00007d0,0.564d0,0.282d0,0.072d0,
589 &0.028d0,0.023d0,2*0.0115d0,0.005d0,0.003d0,0.6861d0,0.3139d0,
590 &2*0.5d0,0.665d0,0.333d0,0.002d0,0.333d0,0.166d0,0.168d0,0.084d0,
591 &0.087d0,0.043d0,0.059d0,2*0.029d0,0.002d0,0.6352d0,0.2116d0,
592 &0.0559d0,0.0173d0,0.0482d0,0.0318d0,0.666d0,0.333d0,0.001d0,
593 &0.332d0,0.166d0,0.168d0,0.084d0,0.086d0,0.043d0,0.059d0,
594 &2*0.029d0,2*0.002d0,0.437d0,0.208d0,0.302d0,0.0302d0,0.0212d0,
595 &0.0016d0,0.48947d0,0.34d0,3*0.043d0,0.027d0,0.0126d0,0.0013d0,
596 &0.0003d0,0.00025d0,0.00008d0,0.444d0,2*0.222d0,0.104d0,2*0.004d0,
597 &0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.07d0,0.065d0/
598 DATA (brat(i) ,i= 804, 977)/2*0.005d0,2*0.011d0,5*0.001d0,
599 &0.026d0,0.019d0,0.066d0,0.041d0,0.045d0,0.076d0,0.0073d0,
600 &2*0.0047d0,0.026d0,0.001d0,0.0006d0,0.0066d0,0.005d0,2*0.003d0,
601 &2*0.0006d0,2*0.001d0,0.006d0,0.005d0,0.012d0,0.0057d0,0.067d0,
602 &0.008d0,0.0022d0,0.027d0,0.004d0,0.019d0,0.012d0,0.002d0,0.009d0,
603 &0.0218d0,0.001d0,0.022d0,0.087d0,0.001d0,0.0019d0,0.0015d0,
604 &0.0028d0,0.683d0,0.306d0,0.011d0,0.3d0,0.15d0,0.16d0,0.08d0,
605 &0.13d0,0.06d0,0.08d0,0.04d0,0.034d0,0.027d0,2*0.002d0,2*0.004d0,
606 &2*0.002d0,0.034d0,0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.0365d0,
607 &0.045d0,0.073d0,0.062d0,3*0.021d0,0.0061d0,0.015d0,0.025d0,
608 &0.0088d0,0.074d0,0.0109d0,0.0041d0,0.002d0,0.0035d0,0.0011d0,
609 &0.001d0,0.0027d0,2*0.0016d0,0.0018d0,0.011d0,0.0063d0,0.0052d0,
610 &0.018d0,0.016d0,0.0034d0,0.0036d0,0.0009d0,0.0006d0,0.015d0,
611 &0.0923d0,0.018d0,0.022d0,0.0077d0,0.009d0,0.0075d0,0.024d0,
612 &0.0085d0,0.067d0,0.0511d0,0.017d0,0.0004d0,0.0028d0,0.619d0,
613 &0.381d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,
614 &0.01d0,2*0.02d0,0.03d0,2*0.005d0,2*0.02d0,0.03d0,2*0.005d0,
615 &0.015d0,0.037d0,0.028d0,0.079d0,0.095d0,0.052d0,0.0078d0,
616 &4*0.001d0,0.028d0,0.033d0,0.026d0,0.05d0,0.01d0,4*0.005d0,0.25d0,
617 &0.0952d0,0.94d0,0.06d0,2*0.4d0,2*0.1d0,1d0,0.0602d0,0.0601d0/
618 DATA (brat(i) ,i= 978,1136)/0.8797d0,0.135d0,0.865d0,0.02d0,
619 &0.055d0,2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,2*0.005d0,
620 &0.008d0,0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,0.0055d0,0.0042d0,
621 &0.009d0,0.018d0,0.015d0,0.0185d0,0.0135d0,0.025d0,0.0004d0,
622 &0.0007d0,0.0008d0,0.0014d0,0.0019d0,0.0025d0,0.4291d0,0.08d0,
623 &0.07d0,0.02d0,0.015d0,0.005d0,1d0,0.3d0,0.15d0,0.16d0,0.08d0,
624 &0.13d0,0.06d0,0.08d0,0.04d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
625 &0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,
626 &0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,
627 &0.0185d0,0.0135d0,0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,
628 &0.0019d0,0.0025d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,
629 &1d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,
630 &0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,
631 &2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,
632 &0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,0.0185d0,0.0135d0,
633 &0.025d0,2*0.0002d0,0.0007d0,2*0.0004d0,0.0014d0,0.001d0,0.0009d0,
634 &0.0025d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,1d0,
635 &2*0.3d0,2*0.2d0,0.047d0,0.122d0,0.006d0,0.012d0,0.035d0,0.012d0,
636 &0.035d0,0.003d0,0.007d0,0.15d0,0.037d0,0.008d0,0.002d0,0.05d0,
637 &0.015d0,0.003d0,0.001d0,0.014d0,0.042d0,0.014d0,0.042d0,0.24d0/
638 DATA (brat(i) ,i=1137,1341)/0.065d0,0.012d0,0.003d0,0.001d0,
639 &0.002d0,0.001d0,0.002d0,0.014d0,0.003d0,1d0,2*0.3d0,2*0.2d0,1d0,
640 &0.0252d0,0.0248d0,0.0267d0,0.015d0,0.045d0,0.015d0,0.045d0,
641 &0.7743d0,0.029d0,0.22d0,0.78d0,1d0,0.331d0,0.663d0,0.006d0,
642 &0.663d0,0.331d0,0.006d0,1d0,0.999d0,0.001d0,0.88d0,2*0.06d0,
643 &0.639d0,0.358d0,0.002d0,0.001d0,1d0,0.88d0,2*0.06d0,0.516d0,
644 &0.483d0,0.001d0,0.88d0,2*0.06d0,0.9988d0,0.0001d0,0.0006d0,
645 &0.0004d0,0.0001d0,0.667d0,0.333d0,0.9954d0,0.0011d0,0.0035d0,
646 &0.333d0,0.667d0,0.676d0,0.234d0,0.085d0,0.005d0,2*1d0,0.018d0,
647 &2*0.005d0,0.003d0,0.002d0,2*0.006d0,0.018d0,2*0.005d0,0.003d0,
648 &0.002d0,2*0.006d0,0.0066d0,0.025d0,0.016d0,0.0088d0,2*0.005d0,
649 &0.0058d0,0.005d0,0.0055d0,4*0.004d0,2*0.002d0,2*0.004d0,0.003d0,
650 &0.002d0,2*0.003d0,3*0.002d0,2*0.001d0,0.002d0,2*0.001d0,
651 &2*0.002d0,0.0013d0,0.0018d0,5*0.001d0,4*0.003d0,2*0.005d0,
652 &2*0.002d0,2*0.001d0,2*0.002d0,2*0.001d0,0.2432d0,0.057d0,
653 &2*0.035d0,0.15d0,2*0.075d0,0.03d0,2*0.015d0,2*0.08d0,0.76d0,
654 &0.08d0,4*1d0,2*0.08d0,0.76d0,0.08d0,1d0,2*0.5d0,1d0,2*0.5d0,
655 &2*0.08d0,0.76d0,0.08d0,1d0,2*0.08d0,0.76d0,3*0.08d0,0.76d0,
656 &3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,
657 &3*0.08d0,0.76d0,0.08d0,2*1d0,2*0.105d0,0.04d0,0.0077d0,0.02d0/
658 DATA (brat(i) ,i=1342,1522)/0.0235d0,0.0285d0,0.0435d0,0.0011d0,
659 &0.0022d0,0.0044d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,
660 &2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,
661 &2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,
662 &4*1d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,
663 &0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,
664 &0.005d0,4*1d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
665 &0.015d0,0.005d0,1d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
666 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
667 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
668 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
669 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
670 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
671 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
672 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
673 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
674 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
675 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
676 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
677 &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0/
678 DATA (brat(i) ,i=1523,2548)/0.015d0,0.005d0,2*0.105d0,0.04d0,
679 &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
680 &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
681 &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
682 &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
683 &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,0.52d0,0.26d0,
684 &0.11d0,2*0.055d0,0.333d0,0.334d0,0.333d0,0.667d0,0.333d0,0.28d0,
685 &0.14d0,0.313d0,0.157d0,0.11d0,0.667d0,0.333d0,0.28d0,0.14d0,
686 &0.313d0,0.157d0,0.11d0,0.36d0,0.18d0,0.03d0,2*0.015d0,2*0.2d0,
687 &4*0.25d0,0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,
688 &0.333d0,4*0.5d0,0.007d0,0.993d0,1d0,0.667d0,0.333d0,0.667d0,
689 &0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,8*0.5d0,0.02d0,0.98d0,
690 &1d0,4*0.5d0,3*0.146d0,3*0.05d0,0.15d0,2*0.05d0,4*0.024d0,0.066d0,
691 &0.667d0,0.333d0,0.667d0,0.333d0,4*0.25d0,0.667d0,0.333d0,0.667d0,
692 &0.333d0,2*0.5d0,0.273d0,0.727d0,0.667d0,0.333d0,0.667d0,0.333d0,
693 &4*0.5d0,0.35d0,0.65d0,2*0.0083d0,0.1866d0,0.324d0,0.184d0,
694 &0.027d0,0.001d0,0.093d0,0.087d0,0.078d0,0.0028d0,3*0.014d0,
695 &0.008d0,0.024d0,0.008d0,0.024d0,0.425d0,0.02d0,0.185d0,0.088d0,
696 &0.043d0,0.067d0,0.066d0,831*0d0,0.85422d0,0.005292d0,0.044039d0,
697 &0.096449d0,0.853165d0,0.021144d0,0.029361d0,0.096329d0/
698 DATA (brat(i) ,i=2549,4000)/0.294414d0,0.109437d0,0.596149d0,
699 &0.389861d0,0.610139d0,1447*0d0/
700 DATA (kfdp(i,1),i= 1, 374)/21,22,23,4*-24,25,21,22,23,4*24,25,
701 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
702 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
703 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
704 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
705 &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
706 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
707 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
708 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
709 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
710 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
711 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
712 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
713 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
714 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
715 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
716 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
717 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,
718 &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,
719 &1000001,2000001,1000001,-1000001,1000002,2000002,1000002/
720 DATA (kfdp(i,1),i= 375, 587)/-1000002,1000003,2000003,1000003,
721 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
722 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
723 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
724 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
725 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
726 &1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,
727 &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,
728 &1000001,2000001,1000001,-1000001,1000002,2000002,1000002,
729 &-1000002,1000003,2000003,1000003,-1000003,1000004,2000004,
730 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
731 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
732 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
733 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
734 &1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,-5,-7,
735 &-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
736 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
737 &-1000013,-1000015,-2000015,5,6,21,2,1,2,3,4,5,6,11,13,15,3,4,5,6,
738 &11,13,15,21,2*4,24,-11,-13,-15,3,4,5,6,11,13,15,21,2*24,2*52,
739 &2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*52,24/
740 DATA (kfdp(i,1),i= 588, 979)/4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,
741 &22,23,22,23,24,52,24,52,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
742 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,63,3*-1,3*-3,3*-5,-11,-13,-15,
743 &82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,
744 &11,213,-213,221,223,321,130,310,111,331,111,211,-12,12,-14,14,
745 &211,111,22,-13,-11,2*211,213,113,221,223,321,211,331,22,111,211,
746 &2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,321,130,310,
747 &221,111,211,111,130,310,321,2*311,321,311,323,313,323,313,321,
748 &3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,323,311,
749 &4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,11,13,211,
750 &321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,-313,-20313,
751 &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
752 &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
753 &-321,211,113,421,2*411,421,411,423,413,423,413,421,411,8*-11,
754 &8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,-321,
755 &-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,-313,
756 &-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,211,
757 &113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,5*-13,
758 &221,331,333,221,331,333,10221,211,213,211,213,321,323,321,323,
759 &2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,443/
760 DATA (kfdp(i,1),i= 980,1419)/82,6*12,6*14,2*16,3*-411,3*-413,
761 &2*-411,2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,
762 &513,523,513,521,511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,
763 &2*441,2*443,2*20443,2*2,2*4,2,4,521,511,521,513,523,513,523,511,
764 &521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,
765 &3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,2*14,2*16,
766 &4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,513,
767 &523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,2112,
768 &2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,3112,
769 &2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,3312,
770 &2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
771 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
772 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
773 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
774 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
775 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
776 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
777 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
778 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
779 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16/
780 DATA (kfdp(i,1),i=1420,1739)/2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
781 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
782 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
783 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
784 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
785 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
786 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
787 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
788 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
789 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
790 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
791 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
792 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
793 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
794 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
795 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
796 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
797 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
798 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
799 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025/
800 DATA (kfdp(i,1),i=1740,1907)/1000035,1000004,2000004,1000004,
801 &2000004,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
802 &1000035,1000003,2000003,1000003,2000003,1000021,1000039,-1000024,
803 &-1000037,1000022,1000023,1000025,1000035,1000006,2000006,1000006,
804 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
805 &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,
806 &-1000015,1000039,-1000024,-1000037,1000022,1000023,1000025,
807 &1000035,1000012,2000012,1000012,2000012,1000039,1000024,1000037,
808 &1000022,1000023,1000025,1000035,1000011,2000011,1000011,2000011,
809 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
810 &1000014,2000014,1000014,2000014,1000039,1000024,1000037,1000022,
811 &1000023,1000025,1000035,1000013,2000013,1000013,2000013,1000039,
812 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000016,
813 &2000016,1000016,2000016,1000039,1000024,1000037,1000022,1000023,
814 &1000025,1000035,1000015,2000015,1000015,2000015,1000039,1000001,
815 &-1000001,2000001,-2000001,1000002,-1000002,2000002,-2000002,
816 &1000003,-1000003,2000003,-2000003,1000004,-1000004,2000004,
817 &-2000004,1000005,-1000005,2000005,-2000005,1000006,-1000006,
818 &2000006,-2000006,6*1000022,6*1000023,6*1000025,6*1000035,1000024,
819 &-1000024,1000024,-1000024,1000024,-1000024,1000037,-1000037/
820 DATA (kfdp(i,1),i=1908,2126)/1000037,-1000037,1000037,-1000037,
821 &5*1000039,4,1,5*1000039,16*1000022,1000024,-1000024,1000024,
822 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
823 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
824 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
825 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
826 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
827 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
828 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
829 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
830 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
831 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
832 &-1000016,2000016,-2000016,5*1000021,2*1000039,6*1000022,
833 &6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,1000035,
834 &1000002,2000002,-1000001,-2000001,1000004,2000004,-1000003,
835 &-2000003,1000006,2000006,-1000005,-2000005,1000012,2000012,
836 &-1000011,-2000011,1000014,2000014,-1000013,-2000013,1000016,
837 &2000016,-1000015,-2000015,2*1000021,5*1000039,16*1000022,
838 &16*1000023,1000024,-1000024,1000024,-1000024,1000024,-1000024,
839 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037/
840 DATA (kfdp(i,1),i=2127,2315)/-1000037,1000037,-1000037,1000037,
841 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
842 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
843 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
844 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
845 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
846 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
847 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
848 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
849 &-1000016,2000016,-2000016,5*1000021,5*1000039,16*1000022,
850 &16*1000023,16*1000025,1000024,-1000024,1000024,-1000024,1000024,
851 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
852 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
853 &-1000037,1000037,-1000037,1000037,-1000037,1000024,-1000024,
854 &1000037,-1000037,1000001,-1000001,2000001,-2000001,1000002,
855 &-1000002,2000002,-2000002,1000003,-1000003,2000003,-2000003,
856 &1000004,-1000004,2000004,-2000004,1000005,-1000005,2000005,
857 &-2000005,1000006,-1000006,2000006,-2000006,1000011,-1000011,
858 &2000011,-2000011,1000012,-1000012,2000012,-2000012,1000013,
859 &-1000013,2000013,-2000013,1000014,-1000014,2000014,-2000014/
860 DATA (kfdp(i,1),i=2316,2516)/1000015,-1000015,2000015,-2000015,
861 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
862 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
863 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
864 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012,
865 &2000012,-1000011,-2000011,1000014,2000014,-1000013,-2000013,
866 &1000016,2000016,-1000015,-2000015,2*1000021,1000039,-1000024,
867 &-1000037,1000022,1000023,1000025,1000035,4*1000001,1000002,
868 &2000002,1000002,2000002,1000021,1000039,1000024,1000037,1000022,
869 &1000023,1000025,1000035,4*1000002,1000001,2000001,1000001,
870 &2000001,1000021,1000039,-1000024,-1000037,1000022,1000023,
871 &1000025,1000035,4*1000003,1000004,2000004,1000004,2000004,
872 &1000021,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
873 &4*1000004,1000003,2000003,1000003,2000003,1000021,1000039,
874 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000005,
875 &1000006,2000006,1000006,2000006,1000021,1000039,1000024,1000037,
876 &1000022,1000023,1000025,1000035,4*1000006,1000005,2000005,
877 &1000005,2000005,1000021,1000039,-1000024,-1000037,1000022,
878 &1000023,1000025,1000035,4*1000011,1000012,2000012,1000012,
879 &2000012,1000039,-1000024,-1000037,1000022,1000023,1000025/
880 DATA (kfdp(i,1),i=2517,4000)/1000035,4*1000013,1000014,2000014,
881 &1000014,2000014,1000039,-1000024,-1000037,1000022,1000023,
882 &1000025,1000035,4*1000015,1000016,2000016,1000016,2000016,21,22,
883 &23,-24,21,22,23,24,22,23,-24,23,24,1447*0/
884 DATA (kfdp(i,2),i= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
885 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
886 &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,
887 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
888 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
889 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
890 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
891 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
892 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
893 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
894 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
895 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
896 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
897 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
898 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
899 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
900 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
901 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
902 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
903 &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/
904 DATA (kfdp(i,2),i= 340, 526)/-7,-8,-11,-13,-15,-17,21,22,2*23,
905 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
906 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
907 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
908 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
909 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
910 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
911 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
912 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
913 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
914 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
915 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
916 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
917 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
918 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
919 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
920 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
921 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
922 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
923 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
924 DATA (kfdp(i,2),i= 527, 931)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-3,-4,
925 &-5,-6,-11,-13,-15,21,-3,-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,
926 &-24,-52,-24,-52,51,53,51,53,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,
927 &-14,-15,-16,-17,-18,23,51,23,51,22,53,2,4,6,8,2,4,6,8,2,4,6,8,2,
928 &4,6,8,12,14,16,18,2*51,2*53,-52,2*-24,-52,-1,-2,-3,-4,-5,-6,-7,
929 &-8,-11,-12,-13,-14,-15,-16,-17,-18,-11,-13,-15,-13,2*-15,24,-11,
930 &-13,-15,-13,2*-15,63,2,4,6,2,4,6,2,4,6,64,65,66,-82,12,14,-1,-3,
931 &11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
932 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
933 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
934 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
935 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
936 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
937 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
938 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
939 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
940 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
941 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
942 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
943 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111/
944 DATA (kfdp(i,2),i= 932,1317)/-211,211,-211,211,16,5*12,5*14,
945 &3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,2*-1,
946 &22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13,2*-15,
947 &211,213,20213,211,213,20213,431,433,431,433,311,313,311,313,311,
948 &313,-1,-4,-3,-4,-1,-3,22,-211,111,-211,111,-211,211,-211,211,
949 &6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,
950 &321,323,321,323,321,323,-1,-4,-3,-4,-1,-3,22,211,111,211,111,
951 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
952 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
953 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
954 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
955 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
956 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
957 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
958 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
959 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
960 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
961 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
962 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
963 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1/
964 DATA (kfdp(i,2),i=1318,1756)/-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,
965 &-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,-433,3*3122,
966 &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,
967 &2*211,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,
968 &4,3,4,1,3,22,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,
969 &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,
970 &4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,
971 &3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
972 &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,
973 &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,
974 &3,2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,
975 &113,-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,
976 &310,2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,
977 &311,2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,
978 &-311,-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,
979 &2*211,111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,
980 &-311,311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,
981 &111,-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,
982 &-13,-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,
983 &2*1,4*2,2*24,2*37,2,3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37/
984 DATA (kfdp(i,2),i=1757,2220)/4,5,2*6,4*5,2*-24,2*-37,5,6,2*5,4*6,
985 &2*24,2*37,6,4,-15,16,11,2*12,4*11,2*-24,2*-37,12,2*11,4*12,2*24,
986 &2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37,15,2*16,
987 &4*15,2*-24,2*-37,16,2*15,4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,
988 &-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,
989 &1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,
990 &35,36,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,
991 &35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,
992 &15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
993 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
994 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
995 &24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,
996 &24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,
997 &2*-13,2*14,2*-15,2*16,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,
998 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
999 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1000 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1001 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,
1002 &13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,22,23,25,
1003 &35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15/
1004 DATA (kfdp(i,2),i=2221,4000)/12,14,16,1,3,5,2,4,25,35,36,22,23,
1005 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
1006 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
1007 &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,
1008 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
1009 &-16,16,-16,16,1,3,5,2,4,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,
1010 &35,36,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,
1011 &-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,
1012 &2*12,2*-13,2*14,2*-15,2*16,-1,-3,1,2*2,4*1,23,25,35,36,2*-24,
1013 &2*-37,1,2,2*1,4*2,23,25,35,36,2*24,2*37,2,3,2*4,4*3,23,25,35,36,
1014 &2*-24,2*-37,3,4,2*3,4*4,23,25,35,36,2*24,2*37,4,5,2*6,4*5,23,25,
1015 &35,36,2*-24,2*-37,5,6,2*5,4*6,23,25,35,36,2*24,2*37,6,11,2*12,
1016 &4*11,23,25,35,36,2*-24,2*-37,13,2*14,4*13,23,25,35,36,2*-24,
1017 &2*-37,15,2*16,4*15,23,25,35,36,2*-24,2*-37,3*1,4*2,1,2*11,2*12,
1018 &11,1447*0/
1019 DATA (kfdp(i,3),i= 1,1134)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1020 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1021 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1022 &407*0,-5,112*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,
1023 &-211,211,-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,
1024 &3*0,111,211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,
1025 &5*0,2*221,3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,
1026 &221,331,113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,
1027 &223,22*0,111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,
1028 &111,-211,111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,
1029 &-323,-311,-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,
1030 &-211,310,-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,
1031 &2*211,6*0,111,-211,111,-211,0,221,331,333,321,311,221,331,333,
1032 &321,311,20*0,3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,
1033 &-413,-10413,-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,
1034 &5*0,111,-211,111,-211,-421,-423,-10423,-10421,-20423,-425,-421,
1035 &-423,-10423,-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,
1036 &5*0,111,-211,111,-211,-431,-433,-10433,-10431,-20433,-435,-431,
1037 &-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,
1038 &8*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531/
1039 DATA (kfdp(i,3),i=1135,2233)/533,3,2,3,2,511,513,511,513,1,2,
1040 &13*0,2*21,11*0,2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,
1041 &3212,3214,2112,2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,
1042 &52*0,3*3,1,6*0,4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,
1043 &2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1044 &4*0,4*4,1,4,3,2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1045 &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,
1046 &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,
1047 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1048 &3,2*2,4*4,1,4,3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,
1049 &111,211,30*0,-211,111,13*0,2*21,-211,111,76*0,2*5,91*0,-1,-3,-5,
1050 &-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,
1051 &-2,2,-4,4,-6,6,-2,2,-4,4,-6,6,5*0,11,12,7*0,-11,-13,-15,-12,-14,
1052 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1053 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,
1054 &12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,7*0,-11,-13,
1055 &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,
1056 &-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,
1057 &-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,7*0,-11,-13,-15,-12,-14,-16,
1058 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0/
1059 DATA (kfdp(i,3),i=2234,4000)/-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,
1060 &-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,
1061 &-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,-11,-13,-15,-12,-14,-16,-1,-3,
1062 &-5,-2,-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,
1063 &16,2,4,28*0,2,4,1601*0/
1064 DATA (kfdp(i,4),i= 1,4000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1065 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1066 &6*111,310,2*130,520*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1067 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1068 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1069 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1070 &-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,
1071 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1072 &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,
1073 &162*81,31*0,-211,111,2398*0/
1074 DATA (kfdp(i,5),i= 1,4000)/96*0,2*111,17*0,111,7*0,2*111,0,
1075 &3*111,0,111,715*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1076 &3*111,-211,111,3075*0/
1077
1078C...PYDAT4, with particle names (character strings).
1079 DATA (chaf(i,1),i= 1, 185)/'d','u','s','c','b','t','b''','t''',
1080 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1081 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1082 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1083 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1084 &'rho_tech0','rho_tech+','omega_tech',4*' ','H_L++','H_R++',
1085 &'W_R+','nu_Re','nu_Rmu','nu_Rtau',14*' ','specflav','rndmflav',
1086 &'phasespa','c-hadron','b-hadron',5*' ','cluster','string',
1087 &'indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet','CELLjet',
1088 &'table',' ','rho_diff0','pi0','rho0','a_20','K_L0','pi_diffr+',
1089 &'pi+','rho+','a_2+','omega_di','eta','omega','f_2','K_S0','K0',
1090 &'K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''','phi',
1091 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1092 &'D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0','B*_20',
1093 &'B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+',
1094 &'B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-','ud_0',
1095 &'ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+','Delta+',
1096 &'Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0','su_0',
1097 &'su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-','Xi*-',
1098 &'Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0','Sigma*_c0'/
1099 DATA (chaf(i,1),i= 186, 315)/'Lambda_c+','Xi_c0','cu_0','cu_1',
1100 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1101 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1102 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++',
1103 &'Omega_cc+','Omega*_cc+','Omega*_ccc++','bd_0','bd_1','Sigma_b-',
1104 &'Sigma*_b-','Lambda_b0','Xi_b-','Xi_bc0','bu_0','bu_1',
1105 &'Sigma_b0','Sigma*_b0','Sigma_b+','Sigma*_b+','Xi_b0','Xi_bc+',
1106 &'bs_0','bs_1','Xi''_b-','Xi*_b-','Xi''_b0','Xi*_b0','Omega_b-',
1107 &'Omega*_b-','Omega_bc0','bc_0','bc_1','Xi''_bc0','Xi*_bc0',
1108 &'Xi''_bc+','Xi*_bc+','Omega''_bc0','Omega*_bc0','Omega_bcc+',
1109 &'Omega*_bcc+','bb_1','Xi_bb-','Xi*_bb-','Xi_bb0','Xi*_bb0',
1110 &'Omega_bb-','Omega*_bb-','Omega_bbc0','Omega*_bbc0',
1111 &'Omega*_bbb-','a_00','b_10','a_0+','b_1+','f_0','h_1','K*_00',
1112 &'K_10','K*_0+','K_1+','f''_0','h''_1','D*_0+','D_1+','D*_00',
1113 &'D_10','D*_0s+','D_1s+','chi_0c','h_1c','B*_00','B_10','B*_0+',
1114 &'B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+','chi_0b','h_1b','a_10',
1115 &'a_1+','f_1','K*_10','K*_1+','f''_1','D*_1+','D*_10','D*_1s+',
1116 &'chi_1c','B*_10','B*_1+','B*_1s0','B*_1c+','chi_1b','psi''',
1117 &'Upsilon''','~d_L','~u_L','~s_L','~c_L','~b_1','~t_1','~e_L-',
1118 &'~nu_eL','~mu_L-','~nu_muL','~tau_1-','~nu_tauL','~g','~chi_10'/
1119 DATA (chaf(i,1),i= 316, 500)/'~chi_20','~chi_1+','~chi_30',
1120 &'~chi_40','~chi_2+','~gravitino','~d_R','~u_R','~s_R','~c_R',
1121 &'~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR','~tau_2-',
1122 &'~nu_tauR','d*','u*','e*-','nu*_e0',163*' '/
1123 DATA (chaf(i,2),i= 1, 198)/'dbar','ubar','sbar','cbar','bbar',
1124 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1125 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1126 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1127 &'rho_tech-',5*' ','H_L--','H_R--','W_R-','nu_Rebar','nu_Rmubar',
1128 &'nu_Rtaubar',15*' ','rndmflavbar',' ','c-hadronbar',
1129 &'b-hadronbar',20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ',
1130 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-',
1131 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1132 &4*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1133 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar',
1134 &'Deltabar+','ud_0bar','ud_1bar','n_diffrbar0','nbar0',
1135 &'Deltabar0','uu_1bar','p_diffrbar-','pbar-','Deltabar-',
1136 &'Deltabar--','sd_0bar','sd_1bar','Sigmabar+','Sigma*bar+',
1137 &'Lambdabar0','su_0bar','su_1bar','Sigmabar0','Sigma*bar0',
1138 &'Sigmabar-','Sigma*bar-','ss_1bar','Xibar+','Xi*bar+','Xibar0',
1139 &'Xi*bar0','Omegabar+','cd_0bar','cd_1bar','Sigma_cbar0',
1140 &'Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar','cu_1bar',
1141 &'Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--','Sigma*_cbar--',
1142 &'Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0','Xi*_cbar0'/
1143 DATA (chaf(i,2),i= 199, 308)/'Xi''_cbar-','Xi*_cbar-',
1144 &'Omega_cbar0','Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-',
1145 &'Xi_ccbar--','Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-',
1146 &'Omega*_cccbar-','bd_0bar','bd_1bar','Sigma_bbar+',
1147 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1148 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1149 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1150 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1151 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1152 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1153 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1154 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1155 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1156 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1157 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1158 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1159 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1160 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1161 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1162 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+'/
1163 DATA (chaf(i,2),i= 309, 500)/'~nu_eLbar','~mu_L+','~nu_muLbar',
1164 &'~tau_1+','~nu_tauLbar',3*' ','~chi_1-',2*' ','~chi_2-',' ',
1165 &'~d_Rbar','~u_Rbar','~s_Rbar','~c_Rbar','~b_2bar','~t_2bar',
1166 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1167 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1168
1169C...PYDATR, with initial values for the random number generator.
1170 DATA mrpy/19780503,0,0,97,33,0/
1171
1172C...Default values for allowed processes and kinematics constraints.
1173 DATA msel/1/
1174 DATA msub/500*0/
1175 DATA ((kfin(i,j),j=-40,40),i=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1176 &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,
1177 &6*1,4*0,4*1,16*0/
1178 DATA ckin/
1179 & 2.0d0, -1.0d0, 0.0d0, -1.0d0, 1.0d0,
1180 & 1.0d0, -10d0, 10d0, -40d0, 40d0,
1181 1 -40d0, 40d0, -40d0, 40d0, -40d0,
1182 1 40d0, -1.0d0, 1.0d0, -1.0d0, 1.0d0,
1183 2 0.0d0, 1.0d0, 0.0d0, 1.0d0, -1.0d0,
1184 2 1.0d0, -1.0d0, 1.0d0, 0d0, 0d0,
1185 3 2.0d0, -1.0d0, 0d0, 0d0, 0.0d0,
1186 3 -1.0d0, 0.0d0, -1.0d0, 4.0d0, -1.0d0,
1187 4 12.0d0, -1.0d0, 12.0d0, -1.0d0, 12.0d0,
1188 4 -1.0d0, 12.0d0, -1.0d0, 0d0, 0d0,
1189 5 0.0d0, -1.0d0, 0.0d0, -1.0d0, 0.0d0,
1190 5 -1.0d0, 0d0, 0d0, 0d0, 0d0,
1191 6 0.0001d0, 0.99d0, 0.0001d0, 0.99d0, 0d0,
1192 6 -1d0, 0d0, -1d0, 0d0, -1d0,
1193 7 0d0, -1d0, 0.0001d0, 0.99d0, 0.0001d0,
1194 7 0.99d0, 2d0, -1d0, 0d0, 0d0,
1195 8 120*0d0/
1196
1197C...Default values for main switches and parameters. Reset information.
1198 DATA (mstp(i),i=1,100)/
1199 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1200 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1201 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1202 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1203 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1204 5 4, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1205 6 1, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1206 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1207 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1208 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1209 DATA (mstp(i),i=101,200)/
1210 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1211 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1212 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1213 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1214 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1215 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1216 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1217 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1218 8 6, 152, 2000, 08, 17, 0, 0, 0, 0, 0,
1219 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1220 DATA (parp(i),i=1,100)/
1221 & 0.25d0, 10d0, 8*0d0,
1222 1 0d0, 0d0, 1.0d0, 0.01d0, 0.5d0, 1.0d0, 1.0d0, 0.4d0, 2*0d0,
1223 2 10*0d0,
1224 3 1.5d0,2.0d0,0.075d0,1.0d0,0.2d0,0d0,2.0d0,0.70d0,0.006d0,0d0,
1225 4 0.02d0,2.0d0,0.10d0,1000d0,2054d0, 123d0, 246d0, 50d0, 2*0d0,
1226 5 10*0d0,
1227 6 0.25d0, 1.0d0,0.25d0, 1.0d0, 2.0d0,1d-3, 1.0d0,1d-3,2*0d0,
1228 7 4.0d0, 0.25d0, 8*0d0,
1229 8 1.90d0, 2.10d0, 0.5d0, 0.2d0, 0.33d0,
1230 8 0.66d0, 0.7d0, 0.5d0, 1000d0, 0.16d0,
1231 9 1.0d0,0.40d0,5.0d0,1.0d0,0d0,3.0d0,1.0d0,0.75d0,1.0d0,5.0d0/
1232 DATA (parp(i),i=101,200)/
1233 & 0.5d0, 0.28d0, 1.0d0, 0.8d0, 6*0d0,
1234 1 2.0d0, 3*0d0, 1.5d0, 0.5d0, 0.6d0, 2.5d0, 2.0d0, 1.0d0,
1235 2 1.0d0, 0.4d0, 8*0d0,
1236 3 0.01d0, 8*0d0, 0d0,
1237 4 0.33333d0, 82d0, 1.33333d0, 4d0, 1d0,
1238 4 1d0, .0182d0, 1d0, 0d0, 1.33333d0,
1239 5 0d0, 0d0, 0d0, 0d0, 6*0d0,
1240 6 2.20d0, 23.6d0, 18.4d0, 11.5d0, 0.5d0, 0d0, 0d0, 0d0, 2*0d0,
1241 7 0d0, 0d0, 0d0, 1.0d0, 6*0d0,
1242 8 0.1d0, 0.01d0, 0.01d0, 0.01d0, 0.1d0, 0.01d0, 0.01d0, 0.01d0,
1243 8 0.3d0, 0.64d0,
1244 9 0.64d0, 5.0d0, 8*0d0/
1245 DATA msti/200*0/
1246 DATA pari/200*0d0/
1247 DATA mint/400*0/
1248 DATA vint/400*0d0/
1249
1250C...Constants for the generation of the various processes.
1251 DATA (iset(i),i=1,100)/
1252 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1253 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1254 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1255 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1256 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1257 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1258 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1259 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1260 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1261 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1262 DATA (iset(i),i=101,200)/
1263 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1264 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1265 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1266 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1267 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1268 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1269 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1270 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1271 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1272 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1273 DATA (iset(i),i=201,300)/
1274 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1275 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1276 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1277 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1278 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1279 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1280 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1281 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1282 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1283 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1284 DATA (iset(i),i=301,500)/
1285 & 2, 39*-2,
1286 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1287 5 5, 5, -1, -1, -1, -1, -1, -1, -1, -1,
1288 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1289 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1290 8 120*-2/
1291 DATA ((kfpr(i,j),j=1,2),i=1,50)/
1292 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1293 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1294 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1295 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1296 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1297 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1298 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1299 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1300 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1301 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1302 DATA ((kfpr(i,j),j=1,2),i=51,100)/
1303 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1304 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1305 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1306 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1307 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1308 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1309 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1310 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1311 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1312 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1313 DATA ((kfpr(i,j),j=1,2),i=101,150)/
1314 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1315 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1316 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1317 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1318 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1319 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1320 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1321 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1322 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1323 4 4000011, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1324 DATA ((kfpr(i,j),j=1,2),i=151,200)/
1325 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1326 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1327 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1328 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1329 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1330 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1331 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1332 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1333 9 54, 0, 55, 0, 56, 0, 11, 0, 11, 0,
1334 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1335 DATA ((kfpr(i,j),j=1,2),i=201,250)/
1336 & 1000011, 1000011, 2000011, 2000011, 1000011,
1337 & 2000011, 1000013, 1000013, 2000013, 2000013,
1338 & 1000013, 2000013, 1000015, 1000015, 2000015,
1339 & 2000015, 1000015, 2000015, 1000011, 1000012,
1340 1 1000015, 1000016, 2000015, 1000016, 1000012,
1341 1 1000012, 1000016, 1000016, 0, 0,
1342 1 1000022, 1000022, 1000023, 1000023, 1000025,
1343 1 1000025, 1000035, 1000035, 1000022, 1000023,
1344 2 1000022, 1000025, 1000022, 1000035, 1000023,
1345 2 1000025, 1000023, 1000035, 1000025, 1000035,
1346 2 1000024, 1000024, 1000037, 1000037, 1000024,
1347 2 1000037, 1000022, 1000024, 1000023, 1000024,
1348 3 1000025, 1000024, 1000035, 1000024, 1000022,
1349 3 1000037, 1000023, 1000037, 1000025, 1000037,
1350 3 1000035, 1000037, 1000021, 1000022, 1000021,
1351 3 1000023, 1000021, 1000025, 1000021, 1000035,
1352 4 1000021, 1000024, 1000021, 1000037, 1000021,
1353 4 1000021, 1000021, 1000021, 0, 0,
1354 4 1000002, 1000022, 2000002, 1000022, 1000002,
1355 4 1000023, 2000002, 1000023, 1000002, 1000025/
1356 DATA ((kfpr(i,j),j=1,2),i=251,300)/
1357 5 2000002, 1000025, 1000002, 1000035, 2000002,
1358 5 1000035, 1000001, 1000024, 2000005, 1000024,
1359 5 1000001, 1000037, 2000005, 1000037, 1000002,
1360 5 1000021, 2000002, 1000021, 0, 0,
1361 6 1000006, 1000006, 2000006, 2000006, 1000006,
1362 6 2000006, 1000006, 1000006, 2000006, 2000006,
1363 6 0, 0, 0, 0, 0,
1364 6 0, 0, 0, 0, 0,
1365 7 1000002, 1000002, 2000002, 2000002, 1000002,
1366 7 2000002, 1000002, 1000002, 2000002, 2000002,
1367 7 1000002, 2000002, 1000002, 1000002, 2000002,
1368 7 2000002, 1000002, 1000002, 2000002, 2000002,
1369 8 1000005, 1000002, 2000005, 2000002, 1000005,
1370 8 2000002, 1000005, 1000002, 2000005, 2000002,
1371 8 1000005, 2000002, 1000005, 1000005, 2000005,
1372 8 2000005, 1000005, 1000005, 2000005, 2000005,
1373 9 1000005, 1000005, 2000005, 2000005, 1000005,
1374 9 2000005, 1000005, 1000021, 2000005, 1000021,
1375 9 1000005, 2000005, 37, 25, 37,
1376 9 35, 36, 25, 36, 35/
1377 DATA ((kfpr(i,j),j=1,2),i=301,500)/
1378 & 37, 37, 78*0,
1379 4 61, 0, 62, 0, 61,
1380 4 11, 62, 11, 61, 13,
1381 4 62, 13, 61, 15, 62,
1382 4 15, 61, 61, 62, 62,
1383 5 61, 0, 62, 0, 0,
1384 5 0, 0, 0, 0, 0,
1385 5 0, 0, 0, 0, 0,
1386 5 0, 0, 0, 0, 0,
1387 6 24, 24, 24, 52, 52,
1388 6 52, 22, 51, 22, 53,
1389 6 23, 51, 23, 53, 24,
1390 6 52, 0, 0, 24, 23,
1391 7 24, 51, 52, 23, 52,
1392 7 51, 22, 52, 23, 52,
1393 7 24, 51, 24, 53, 0,
1394 7 0, 0, 0, 0, 0,
1395 8 240*0/
1396 DATA coef/10000*0d0/
1397 DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/
1398 &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,
1399 &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,
1400 &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,
1401 &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,
1402 &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,
1403 &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,
1404 &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,
1405 &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,
1406 &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,
1407 &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/
1408
1409C...Treatment of resonances.
1410 DATA (mwid(i) ,i= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1411 &10*0,6*1,4*0,3*1,238*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1412
1413C...Character constants: name of processes.
1414 DATA proc(0)/ 'All included subprocesses '/
1415 DATA (proc(i),i=1,20)/
1416 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1417 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1418 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1419 &' ', 'W+ + W- -> h0 ',
1420 &' ', 'f + f'' -> f + f'' (QFD) ',
1421 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1422 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1423 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1424 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1425 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1426 DATA (proc(i),i=21,40)/
1427 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1428 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1429 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1430 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1431 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1432 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1433 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1434 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1435 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1436 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1437 DATA (proc(i),i=41,60)/
1438 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1439 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1440 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1441 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1442 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1443 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1444 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1445 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1446 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1447 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1448 DATA (proc(i),i=61,80)/
1449 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1450 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1451 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1452 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1453 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1454 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1455 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1456 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1457 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1458 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1459 DATA (proc(i),i=81,100)/
1460 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1461 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1462 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1463 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1464 8'g + g -> chi_2c + g ', ' ',
1465 9'Elastic scattering ', 'Single diffractive (XB) ',
1466 9'Single diffractive (AX) ', 'Double diffractive ',
1467 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1468 9' ', ' ',
1469 9'q + gamma* -> q ', ' '/
1470 DATA (proc(i),i=101,120)/
1471 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1472 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1473 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1474 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1475 &' ', 'f + fbar -> gamma + h0 ',
1476 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1477 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1478 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1479 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1480 1' ', ' '/
1481 DATA (proc(i),i=121,140)/
1482 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1483 2'f + f'' -> f + f'' + h0 ',
1484 2'f + f'' -> f" + f"'' + h0 ',
1485 2' ', ' ',
1486 2' ', ' ',
1487 2' ', ' ',
1488 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1489 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1490 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1491 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1492 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1493 DATA (proc(i),i=141,160)/
1494 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1495 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1496 4'q + l -> LQ ', 'e + gamma -> e* ',
1497 4'd + g -> d* ', 'u + g -> u* ',
1498 4'g + g -> eta_techni ', ' ',
1499 5'f + fbar -> H0 ', 'g + g -> H0 ',
1500 5'gamma + gamma -> H0 ', ' ',
1501 5' ', 'f + fbar -> A0 ',
1502 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1503 5' ', ' '/
1504 DATA (proc(i),i=161,180)/
1505 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1506 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1507 6'f + fbar -> f'' + fbar'' (g/Z)',
1508 6'f +fbar'' -> f" + fbar"'' (W) ',
1509 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1510 6'q + qbar -> e + e* ', ' ',
1511 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1512 7'f + f'' -> f + f'' + H0 ',
1513 7'f + f'' -> f" + f"'' + H0 ',
1514 7' ', 'f + fbar -> Z0 + A0 ',
1515 7'f + fbar'' -> W+/- + A0 ',
1516 7'f + f'' -> f + f'' + A0 ',
1517 7'f + f'' -> f" + f"'' + A0 ',
1518 7' '/
1519 DATA (proc(i),i=181,200)/
1520 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1521 8' ', ' ',
1522 8' ', 'g + g -> Q + Qbar + A0 ',
1523 8'q + qbar -> Q + Qbar + A0 ', ' ',
1524 8' ', ' ',
1525 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1526 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1527 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1528 9' ', ' ',
1529 9' ', ' '/
1530 DATA (proc(i),i=201,220)/
1531 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1532 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1533 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1534 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1535 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1536 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1537 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1538 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1539 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1540 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1541 DATA (proc(i),i=221,240)/
1542 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1543 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1544 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1545 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1546 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1547 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1548 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1549 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1550 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1551 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1552 DATA (proc(i),i=241,260)/
1553 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1554 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1555 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1556 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1557 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1558 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1559 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1560 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1561 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1562 5'qj + g -> ~qj_R + ~g ', ' '/
1563 DATA (proc(i),i=261,300)/
1564 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1565 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1566 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1567 6' ', ' ',
1568 6' ', ' ',
1569 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1570 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1571 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1572 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1573 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1574 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1575 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1576 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1577 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1578 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1579 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1580 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1581 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1582 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1583 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1584 DATA (proc(i),i=301,340)/
1585 &'f + fbar -> H+ + H- ', 39*' '/
1586 DATA (proc(i),i=341,500)/
1587 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1588 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1589 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1590 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1591 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1592 5'f + f -> f'' + f'' + H_L++/-- ',
1593 5'f + f -> f'' + f'' + H_R++/-- ', 7*' ',
1594 6' ', 'f + fbar -> W_L+ W_L- ',
1595 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1596 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1597 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1598 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1599 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1600 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1601 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1602 7'f + fbar'' -> W+/- pi_T0 ',
1603 7'f + fbar'' -> W+/- pi_T0'' ',
1604 7' ',' ',
1605 8 121*' '/
1606
1607C...Cross sections and slope offsets.
1608 DATA sigt/294*0d0/
1609
1610C...Supersymmetry switches and parameters.
1611 DATA imss/0,
1612 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1613 1 89*0/
1614 DATA rmss/0d0,
1615 & 80d0,160d0,500d0,800d0,2d0,250d0,200d0,800d0,700d0,800d0,
1616 1 700d0,500d0,250d0,200d0,800d0,400d0,0d0,0.1d0,850d0,0.041d0,
1617 2 1d0,800d0,1d4,1d4,1d4,0d0,0d0,0d0,24d17,0d0,
1618 3 69*0d0/
1619
1620C...Data for histogramming routines.
1621 DATA ihist/1000,20000,55,1/
1622 DATA indx/1000*0/
1623
1624 END
1625
1626C*********************************************************************
1627
1628C...PYTEST
1629C...A simple program (disguised as subroutine) to run at installation
1630C...as a check that the program works as intended.
1631
1632 SUBROUTINE pytest(MTEST)
1633
1634C...Double precision and integer declarations.
1635 IMPLICIT DOUBLE PRECISION(a-h, o-z)
1636 IMPLICIT INTEGER(I-N)
1637 INTEGER PYK,PYCHGE,PYCOMP
1638C...Commonblocks.
1639 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
1640 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
1641 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
1642 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
1643 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
1644 common/pypars/mstp(200),parp(200),msti(200),pari(200)
1645 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
1646C...Local arrays.
1647 dimension psum(5),pini(6),pfin(6)
1648
1649C...Save defaults for values that are changed.
1650 mstj1=mstj(1)
1651 mstj3=mstj(3)
1652 mstj11=mstj(11)
1653 mstj42=mstj(42)
1654 mstj43=mstj(43)
1655 mstj44=mstj(44)
1656 parj17=parj(17)
1657 parj22=parj(22)
1658 parj43=parj(43)
1659 parj54=parj(54)
1660 mst101=mstj(101)
1661 mst104=mstj(104)
1662 mst105=mstj(105)
1663 mst107=mstj(107)
1664 mst116=mstj(116)
1665
1666C...First part: loop over simple events to be generated.
1667 IF(mtest.GE.1) CALL pytabu(20)
1668 nerr=0
1669 DO 180 iev=1,500
1670
1671C...Reset parameter values. Switch on some nonstandard features.
1672 mstj(1)=1
1673 mstj(3)=0
1674 mstj(11)=1
1675 mstj(42)=2
1676 mstj(43)=4
1677 mstj(44)=2
1678 parj(17)=0.1d0
1679 parj(22)=1.5d0
1680 parj(43)=1d0
1681 parj(54)=-0.05d0
1682 mstj(101)=5
1683 mstj(104)=5
1684 mstj(105)=0
1685 mstj(107)=1
1686 IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
1687
1688C...Ten events each for some single jets configurations.
1689 IF(iev.LE.50) THEN
1690 ity=(iev+9)/10
1691 mstj(3)=-1
1692 IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
1693 IF(ity.EQ.1) CALL py1ent(1,1,15d0,0d0,0d0)
1694 IF(ity.EQ.2) CALL py1ent(1,3101,15d0,0d0,0d0)
1695 IF(ity.EQ.3) CALL py1ent(1,-2203,15d0,0d0,0d0)
1696 IF(ity.EQ.4) CALL py1ent(1,-4,30d0,0d0,0d0)
1697 IF(ity.EQ.5) CALL py1ent(1,21,15d0,0d0,0d0)
1698
1699C...Ten events each for some simple jet systems; string fragmentation.
1700 ELSEIF(iev.LE.130) THEN
1701 ity=(iev-41)/10
1702 IF(ity.EQ.1) CALL py2ent(1,1,-1,40d0)
1703 IF(ity.EQ.2) CALL py2ent(1,4,-4,30d0)
1704 IF(ity.EQ.3) CALL py2ent(1,2,2103,100d0)
1705 IF(ity.EQ.4) CALL py2ent(1,21,21,40d0)
1706 IF(ity.EQ.5) CALL py3ent(1,2101,21,-3203,30d0,0.6d0,0.8d0)
1707 IF(ity.EQ.6) CALL py3ent(1,5,21,-5,40d0,0.9d0,0.8d0)
1708 IF(ity.EQ.7) CALL py3ent(1,21,21,21,60d0,0.7d0,0.5d0)
1709 IF(ity.EQ.8) CALL py4ent(1,2,21,21,-2,40d0,
1710 & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
1711
1712C...Seventy events with independent fragmentation and momentum cons.
1713 ELSEIF(iev.LE.200) THEN
1714 ity=1+(iev-131)/16
1715 mstj(2)=1+mod(iev-131,4)
1716 mstj(3)=1+mod((iev-131)/4,4)
1717 IF(ity.EQ.1) CALL py2ent(1,4,-5,40d0)
1718 IF(ity.EQ.2) CALL py3ent(1,3,21,-3,40d0,0.9d0,0.4d0)
1719 IF(ity.EQ.3) CALL py4ent(1,2,21,21,-2,40d0,
1720 & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
1721 IF(ity.GE.4) CALL py4ent(1,2,-3,3,-2,40d0,
1722 & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
1723
1724C...A hundred events with random jets (check invariant mass).
1725 ELSEIF(iev.LE.300) THEN
1726 100 DO 110 j=1,5
1727 psum(j)=0d0
1728 110 CONTINUE
1729 njet=2d0+6d0*pyr(0)
1730 DO 130 i=1,njet
1731 kfl=21
1732 IF(i.EQ.1) kfl=int(1d0+4d0*pyr(0))
1733 IF(i.EQ.njet) kfl=-int(1d0+4d0*pyr(0))
1734 ejet=5d0+20d0*pyr(0)
1735 theta=acos(2d0*pyr(0)-1d0)
1736 phi=6.2832d0*pyr(0)
1737 IF(i.LT.njet) CALL py1ent(-i,kfl,ejet,theta,phi)
1738 IF(i.EQ.njet) CALL py1ent(i,kfl,ejet,theta,phi)
1739 IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
1740 IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+pymass(kfl)
1741 DO 120 j=1,4
1742 psum(j)=psum(j)+p(i,j)
1743 120 CONTINUE
1744 130 CONTINUE
1745 IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
1746 & (psum(5)+parj(32))**2) GOTO 100
1747
1748C...Fifty e+e- continuum events with matrix elements.
1749 ELSEIF(iev.LE.350) THEN
1750 mstj(101)=2
1751 CALL pyeevt(0,40d0)
1752
1753C...Fifty e+e- continuum event with varying shower options.
1754 ELSEIF(iev.LE.400) THEN
1755 mstj(42)=1+mod(iev,2)
1756 mstj(43)=1+mod(iev/2,4)
1757 mstj(44)=mod(iev/8,3)
1758 CALL pyeevt(0,90d0)
1759
1760C...Fifty e+e- continuum events with coherent shower.
1761 ELSEIF(iev.LE.450) THEN
1762 CALL pyeevt(0,500d0)
1763
1764C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1765 ELSE
1766 CALL pyonia(5,9.46d0)
1767 ENDIF
1768
1769C...Generate event. Find total momentum, energy and charge.
1770 DO 140 j=1,4
1771 pini(j)=pyp(0,j)
1772 140 CONTINUE
1773 pini(6)=pyp(0,6)
1774 CALL pyexec
1775 DO 150 j=1,4
1776 pfin(j)=pyp(0,j)
1777 150 CONTINUE
1778 pfin(6)=pyp(0,6)
1779
1780C...Check conservation of energy, momentum and charge;
1781C...usually exact, but only approximate for single jets.
1782 merr=0
1783 IF(iev.LE.50) THEN
1784 IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.10d0)
1785 & merr=merr+1
1786 epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
1787 IF(epzrem.LT.0d0.OR.epzrem.GT.2d0*parj(31)) merr=merr+1
1788 IF(abs(pfin(6)-pini(6)).GT.2.1d0) merr=merr+1
1789 ELSE
1790 DO 160 j=1,4
1791 IF(abs(pfin(j)-pini(j)).GT.0.0001d0*pini(4)) merr=merr+1
1792 160 CONTINUE
1793 IF(abs(pfin(6)-pini(6)).GT.0.1d0) merr=merr+1
1794 ENDIF
1795 IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
1796 & (pfin(j),j=1,4),pfin(6)
1797
1798C...Check that all KF codes are known ones, and that partons/particles
1799C...satisfy energy-momentum-mass relation. Store particle statistics.
1800 DO 170 i=1,n
1801 IF(k(i,1).GT.20) GOTO 170
1802 IF(pycomp(k(i,2)).EQ.0) THEN
1803 WRITE(mstu(11),5100) i
1804 merr=merr+1
1805 ENDIF
1806 pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
1807 IF(abs(pd).GT.max(0.1d0,0.001d0*p(i,4)**2).OR.p(i,4).LT.0d0)
1808 & THEN
1809 WRITE(mstu(11),5200) i
1810 merr=merr+1
1811 ENDIF
1812 170 CONTINUE
1813 IF(mtest.GE.1) CALL pytabu(21)
1814
1815C...List all erroneous events and some normal ones.
1816 IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
1817 IF(merr.GE.1) WRITE(mstu(11),6400)
1818 CALL pylist(2)
1819 ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
1820 CALL pylist(1)
1821 ENDIF
1822
1823C...Stop execution if too many errors.
1824 IF(merr.NE.0) nerr=nerr+1
1825 IF(nerr.GE.10) THEN
1826 WRITE(mstu(11),6300)
1827 CALL pylist(1)
1828 stop
1829 ENDIF
1830 180 CONTINUE
1831
1832C...Summarize result of run.
1833 IF(mtest.GE.1) CALL pytabu(22)
1834
1835C...Reset commonblock variables changed during run.
1836 mstj(1)=mstj1
1837 mstj(3)=mstj3
1838 mstj(11)=mstj11
1839 mstj(42)=mstj42
1840 mstj(43)=mstj43
1841 mstj(44)=mstj44
1842 parj(17)=parj17
1843 parj(22)=parj22
1844 parj(43)=parj43
1845 parj(54)=parj54
1846 mstj(101)=mst101
1847 mstj(104)=mst104
1848 mstj(105)=mst105
1849 mstj(107)=mst107
1850 mstj(116)=mst116
1851
1852C...Second part: complete events of various kinds.
1853C...Common initial values. Loop over initiating conditions.
1854 mstp(122)=max(0,min(2,mtest))
1855 mdcy(pycomp(111),1)=0
1856 DO 230 iproc=1,8
1857
1858C...Reset process type, kinematics cuts, and the flags used.
1859 msel=0
1860 DO 190 isub=1,500
1861 msub(isub)=0
1862 190 CONTINUE
1863 ckin(1)=2d0
1864 ckin(3)=0d0
1865 mstp(2)=1
1866 mstp(11)=0
1867 mstp(33)=0
1868 mstp(81)=1
1869 mstp(82)=1
1870 mstp(111)=1
1871 mstp(131)=0
1872 mstp(133)=0
1873 parp(131)=0.01d0
1874
1875C...Prompt photon production at fixed target.
1876 IF(iproc.EQ.1) THEN
1877 pzsum=300d0
1878 pesum=sqrt(pzsum**2+pymass(211)**2)+pymass(2212)
1879 pqsum=2d0
1880 msel=10
1881 ckin(3)=5d0
1882 CALL pyinit('FIXT','pi+','p',pzsum)
1883
1884C...QCD processes at ISR energies.
1885 ELSEIF(iproc.EQ.2) THEN
1886 pesum=63d0
1887 pzsum=0d0
1888 pqsum=2d0
1889 msel=1
1890 ckin(3)=5d0
1891 CALL pyinit('CMS','p','p',pesum)
1892
1893C...W production + multiple interactions at CERN Collider.
1894 ELSEIF(iproc.EQ.3) THEN
1895 pesum=630d0
1896 pzsum=0d0
1897 pqsum=0d0
1898 msel=12
1899 ckin(1)=20d0
1900 mstp(82)=4
1901 mstp(2)=2
1902 mstp(33)=3
1903 CALL pyinit('CMS','p','pbar',pesum)
1904
1905C...W/Z gauge boson pairs + pileup events at the Tevatron.
1906 ELSEIF(iproc.EQ.4) THEN
1907 pesum=1800d0
1908 pzsum=0d0
1909 pqsum=0d0
1910 msub(22)=1
1911 msub(23)=1
1912 msub(25)=1
1913 ckin(1)=200d0
1914 mstp(111)=0
1915 mstp(131)=1
1916 mstp(133)=2
1917 parp(131)=0.04d0
1918 CALL pyinit('CMS','p','pbar',pesum)
1919
1920C...Higgs production at LHC.
1921 ELSEIF(iproc.EQ.5) THEN
1922 pesum=15400d0
1923 pzsum=0d0
1924 pqsum=2d0
1925 msub(3)=1
1926 msub(102)=1
1927 msub(123)=1
1928 msub(124)=1
1929 pmas(25,1)=300d0
1930 ckin(1)=200d0
1931 mstp(81)=0
1932 mstp(111)=0
1933 CALL pyinit('CMS','p','p',pesum)
1934
1935C...Z' production at SSC.
1936 ELSEIF(iproc.EQ.6) THEN
1937 pesum=40000d0
1938 pzsum=0d0
1939 pqsum=2d0
1940 msel=21
1941 pmas(32,1)=600d0
1942 ckin(1)=400d0
1943 mstp(81)=0
1944 mstp(111)=0
1945 CALL pyinit('CMS','p','p',pesum)
1946
1947C...W pair production at 1 TeV e+e- collider.
1948 ELSEIF(iproc.EQ.7) THEN
1949 pesum=1000d0
1950 pzsum=0d0
1951 pqsum=0d0
1952 msub(25)=1
1953 msub(69)=1
1954 mstp(11)=1
1955 CALL pyinit('CMS','e+','e-',pesum)
1956
1957C...Deep inelastic scattering at a LEP+LHC ep collider.
1958 ELSEIF(iproc.EQ.8) THEN
1959 p(1,1)=0d0
1960 p(1,2)=0d0
1961 p(1,3)=8000d0
1962 p(2,1)=0d0
1963 p(2,2)=0d0
1964 p(2,3)=-80d0
1965 pesum=8080d0
1966 pzsum=7920d0
1967 pqsum=0d0
1968 msub(10)=1
1969 ckin(3)=50d0
1970 mstp(111)=0
1971 CALL pyinit('USER','p','e-',pesum)
1972 ENDIF
1973
1974C...Generate 20 events of each required type.
1975 DO 220 iev=1,20
1976 CALL pyevnt
1977 pesumm=pesum
1978 IF(iproc.EQ.4) pesumm=msti(41)*pesum
1979
1980C...Check conservation of energy/momentum/flavour.
1981 pini(1)=0d0
1982 pini(2)=0d0
1983 pini(3)=pzsum
1984 pini(4)=pesumm
1985 pini(6)=pqsum
1986 DO 200 j=1,4
1987 pfin(j)=pyp(0,j)
1988 200 CONTINUE
1989 pfin(6)=pyp(0,6)
1990 merr=0
1991 deve=abs(pfin(4)-pini(4))+abs(pfin(3)-pini(3))
1992 devt=abs(pfin(1)-pini(1))+abs(pfin(2)-pini(2))
1993 devq=abs(pfin(6)-pini(6))
1994 IF(deve.GT.2d-3*pesum.OR.devt.GT.max(0.01d0,1d-4*pesum).OR.
1995 & devq.GT.0.1d0) merr=1
1996 IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
1997 & (pfin(j),j=1,4),pfin(6)
1998
1999C...Check that all KF codes are known ones, and that partons/particles
2000C...satisfy energy-momentum-mass relation.
2001 DO 210 i=1,n
2002 IF(k(i,1).GT.20) GOTO 210
2003 IF(pycomp(k(i,2)).EQ.0) THEN
2004 WRITE(mstu(11),5100) i
2005 merr=merr+1
2006 ENDIF
2007 pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*
2008 & sign(1d0,p(i,5))
2009 IF(abs(pd).GT.max(0.1d0,0.002d0*p(i,4)**2,0.002d0*p(i,5)**2)
2010 & .OR.(p(i,5).GE.0d0.AND.p(i,4).LT.0d0)) THEN
2011 WRITE(mstu(11),5200) i
2012 merr=merr+1
2013 ENDIF
2014 210 CONTINUE
2015
2016C...Listing of erroneous events, and first event of each type.
2017 IF(merr.GE.1) nerr=nerr+1
2018 IF(nerr.GE.10) THEN
2019 WRITE(mstu(11),6300)
2020 CALL pylist(1)
2021 stop
2022 ENDIF
2023 IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN
2024 IF(merr.GE.1) WRITE(mstu(11),6400)
2025 CALL pylist(1)
2026 ENDIF
2027 220 CONTINUE
2028
2029C...List statistics for each process type.
2030 IF(mtest.GE.1) CALL pystat(1)
2031 230 CONTINUE
2032
2033C...Summarize result of run.
2034 IF(nerr.EQ.0) WRITE(mstu(11),6500)
2035 IF(nerr.GT.0) WRITE(mstu(11),6600) nerr
2036
2037C...Format statements for output.
2038 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2039 &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
2040 &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
2041 &4(1x,f12.5),1x,f8.2)
2042 5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
2043 5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
2044 &'kinematics')
2045 6300 FORMAT(/5x,'This is the tenth error experienced! Something is ',
2046 &'wrong.'/5x,'Execution will be stopped after listing of event.')
2047 6400 FORMAT(5x,'Faulty event follows:')
2048 6500 FORMAT(//5x,'End result of PYTEST: no errors detected.')
2049 6600 FORMAT(//5x,'End result of PYTEST:',i2,' errors detected.'/
2050 &5x,'This should not have happened!')
2051
2052 RETURN
2053 END
2054
2055C*********************************************************************
2056
2057C...PYHEPC
2058C...Converts PYTHIA event record contents to or from
2059C...the standard event record commonblock.
2060
2061 SUBROUTINE pyhepc(MCONV)
2062
2063C...Double precision and integer declarations.
2064 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2065 IMPLICIT INTEGER(I-N)
2066 INTEGER PYK,PYCHGE,PYCOMP
2067C...Commonblocks.
2068 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2069 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2070 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2071 SAVE /pyjets/,/pydat1/,/pydat2/
2072C...HEPEVT commonblock.
2073 parameter(nmxhep=4000)
2074 common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
2075 &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
2076 DOUBLE PRECISION PHEP,VHEP
2077 SAVE /hepevt/
2078
2079C...Conversion from PYTHIA to standard, the easy part.
2080 IF(mconv.EQ.1) THEN
2081 nevhep=0
2082 IF(n.GT.nmxhep) CALL pyerrm(8,
2083 & '(PYHEPC:) no more space in /HEPEVT/')
2084 nhep=min(n,nmxhep)
2085 DO 140 i=1,nhep
2086 isthep(i)=0
2087 IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
2088 IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
2089 IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
2090 IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
2091 idhep(i)=k(i,2)
2092 jmohep(1,i)=k(i,3)
2093 jmohep(2,i)=0
2094 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
2095 jdahep(1,i)=k(i,4)
2096 jdahep(2,i)=k(i,5)
2097 ELSE
2098 jdahep(1,i)=0
2099 jdahep(2,i)=0
2100 ENDIF
2101 DO 100 j=1,5
2102 phep(j,i)=p(i,j)
2103 100 CONTINUE
2104 DO 110 j=1,4
2105 vhep(j,i)=v(i,j)
2106 110 CONTINUE
2107
2108C...Check if new event (from pileup).
2109 IF(i.EQ.1) THEN
2110 inew=1
2111 ELSE
2112 IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
2113 ENDIF
2114
2115C...Fill in missing mother information.
2116 IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
2117 imo1=i-2
2118 IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)
2119 & imo1=imo1-1
2120 jmohep(1,i)=imo1
2121 jmohep(2,i)=imo1+1
2122 ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
2123 i1=k(i,3)-1
2124 120 i1=i1+1
2125 IF(i1.GE.i) CALL pyerrm(8,
2126 & '(PYHEPC:) translation of inconsistent event history')
2127 IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) GOTO 120
2128 kc=pycomp(k(i1,2))
2129 IF(i1.LT.i.AND.kc.EQ.0) GOTO 120
2130 IF(i1.LT.i.AND.kchg(kc,2).EQ.0) GOTO 120
2131 jmohep(2,i)=i1
2132 ELSEIF(k(i,2).EQ.94) THEN
2133 njet=2
2134 IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
2135 IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
2136 jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
2137 IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
2138 & mod(k(i+1,4)/mstu(5),mstu(5))
2139 ENDIF
2140
2141C...Fill in missing daughter information.
2142 IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
2143 DO 130 i1=jdahep(1,i),jdahep(2,i)
2144 i2=mod(k(i1,4)/mstu(5),mstu(5))
2145 jdahep(1,i2)=i
2146 130 CONTINUE
2147 ENDIF
2148 IF(k(i,2).GE.91.AND.k(i,2).LE.94) GOTO 140
2149 i1=jmohep(1,i)
2150 IF(i1.LE.0.OR.i1.GT.nhep) GOTO 140
2151 IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) GOTO 140
2152 IF(jdahep(1,i1).EQ.0) THEN
2153 jdahep(1,i1)=i
2154 ELSE
2155 jdahep(2,i1)=i
2156 ENDIF
2157 140 CONTINUE
2158 DO 150 i=1,nhep
2159 IF(k(i,1).NE.13.AND.k(i,1).NE.14) GOTO 150
2160 IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
2161 150 CONTINUE
2162
2163C...Conversion from standard to PYTHIA, the easy part.
2164 ELSE
2165 IF(nhep.GT.mstu(4)) CALL pyerrm(8,
2166 & '(PYHEPC:) no more space in /PYJETS/')
2167 n=min(nhep,mstu(4))
2168 nkq=0
2169 kqsum=0
2170 DO 180 i=1,n
2171 k(i,1)=0
2172 IF(isthep(i).EQ.1) k(i,1)=1
2173 IF(isthep(i).EQ.2) k(i,1)=11
2174 IF(isthep(i).EQ.3) k(i,1)=21
2175 k(i,2)=idhep(i)
2176 k(i,3)=jmohep(1,i)
2177 k(i,4)=jdahep(1,i)
2178 k(i,5)=jdahep(2,i)
2179 DO 160 j=1,5
2180 p(i,j)=phep(j,i)
2181 160 CONTINUE
2182 DO 170 j=1,4
2183 v(i,j)=vhep(j,i)
2184 170 CONTINUE
2185 v(i,5)=0d0
2186 IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
2187 i1=jdahep(1,i)
2188 IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
2189 & phep(5,i)/phep(4,i)
2190 ENDIF
2191
2192C...Fill in missing information on colour connection in jet systems.
2193 IF(isthep(i).EQ.1) THEN
2194 kc=pycomp(k(i,2))
2195 kq=0
2196 IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
2197 IF(kq.NE.0) nkq=nkq+1
2198 IF(kq.NE.2) kqsum=kqsum+kq
2199 IF(kq.NE.0.AND.kqsum.NE.0) THEN
2200 k(i,1)=2
2201 ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
2202 IF(k(i+1,2).EQ.21) k(i,1)=2
2203 ENDIF
2204 ENDIF
2205 180 CONTINUE
2206 IF(nkq.EQ.1.OR.kqsum.NE.0) CALL pyerrm(8,
2207 & '(PYHEPC:) input parton configuration not colour singlet')
2208 ENDIF
2209
2210 END
2211
2212C*********************************************************************
2213
2214C...PYINIT
2215C...Initializes the generation procedure; finds maxima of the
2216C...differential cross-sections to be used for weighting.
2217
2218 SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
2219
2220C...Double precision and integer declarations.
2221 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2222 IMPLICIT INTEGER(I-N)
2223 INTEGER PYK,PYCHGE,PYCOMP
2224C...Commonblocks.
2225 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2226 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2227 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
2228 common/pydat4/chaf(500,2)
2229 CHARACTER CHAF*16
2230 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2231 common/pypars/mstp(200),parp(200),msti(200),pari(200)
2232 common/pyint1/mint(400),vint(400)
2233 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2234 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2235 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
2236 &/pyint1/,/pyint2/,/pyint5/
2237C...Local arrays and character variables.
2238 dimension alamin(20),nfin(20)
2239 CHARACTER*(*) FRAME,BEAM,TARGET
2240 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2241
2242C...Interface to PDFLIB.
2243 common/w50512/qcdl4,qcdl5
2244 SAVE /w50512/
2245 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2246 CHARACTER*20 PARM(20)
2247 DATA VALUE/20*0d0/,parm/20*' '/
2248
2249C...Data:Lambda and n_f values for parton distributions..
2250 DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,
2251 &0.192d0,0.326d0,2*0.2d0,0.2d0,0.2d0,0.29d0,0.2d0,0.4d0,5*0.2d0/,
2252 &nfin/20*4/
2253 DATA chlh/'lepton','hadron'/
2254
2255C...Reset MINT and VINT arrays. Write headers.
2256 DO 100 j=1,400
2257 mint(j)=0
2258 vint(j)=0d0
2259 100 CONTINUE
2260 IF(mstu(12).GE.1) CALL pylist(0)
2261 IF(mstp(122).GE.1) WRITE(mstu(11),5100)
2262
2263C...Maximum 4 generations; set maximum number of allowed flavours.
2264 mstp(1)=min(4,mstp(1))
2265 mstu(114)=min(mstu(114),2*mstp(1))
2266 mstp(58)=min(mstp(58),2*mstp(1))
2267
2268C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2269 DO 120 i=-20,20
2270 vint(180+i)=0d0
2271 ia=iabs(i)
2272 IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN
2273 DO 110 j=1,mstp(1)
2274 ib=2*j-1+mod(ia,2)
2275 IF(ib.GE.6.AND.mstp(9).EQ.0) GOTO 110
2276 ipm=(5-isign(1,i))/2
2277 idc=j+mdcy(ia,2)+2
2278 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=
2279 & vint(180+i)+vckm((ia+1)/2,(ib+1)/2)
2280 110 CONTINUE
2281 ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN
2282 vint(180+i)=1d0
2283 ENDIF
2284 120 CONTINUE
2285
2286C...Initialize parton distributions: PDFLIB.
2287 IF(mstp(52).EQ.2) THEN
2288 parm(1)='NPTYPE'
2289 value(1)=1
2290 parm(2)='NGROUP'
2291 value(2)=mstp(51)/1000
2292 parm(3)='NSET'
2293 value(3)=mod(mstp(51),1000)
2294 parm(4)='TMAS'
2295 value(4)=pmas(6,1)
2296 CALL pdfset(parm,VALUE)
2297 mint(93)=1000000+mstp(51)
2298 ENDIF
2299
2300C...Choose Lambda value to use in alpha-strong.
2301 mstu(111)=mstp(2)
2302 IF(mstp(3).GE.2) THEN
2303 alam=0.2d0
2304 nf=4
2305 IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
2306 alam=alamin(mstp(51))
2307 nf=nfin(mstp(51))
2308 ELSEIF(mstp(52).EQ.2) THEN
2309 alam=qcdl4
2310 nf=4
2311 ENDIF
2312 parp(1)=alam
2313 parp(61)=alam
2314 parp(72)=alam
2315 paru(112)=alam
2316 mstu(112)=nf
2317 IF(mstp(3).EQ.3) parj(81)=alam
2318 ENDIF
2319
2320C...Initialize the SUSY generation: couplings, masses,
2321C...decay modes, branching ratios, and so on.
2322 CALL pymsin
2323
2324C...Initialize widths and partial widths for resonances.
2325 CALL pyinre
2326C...Set Z0 mass and width for e+e- routines.
2327 parj(123)=pmas(23,1)
2328 parj(124)=pmas(23,2)
2329
2330C...Identify beam and target particles and frame of process.
2331 chfram=frame//' '
2332 chbeam=beam//' '
2333 chtarg=TARGET//' '
2334 CALL pyinbm(chfram,chbeam,chtarg,win)
2335 IF(mint(65).EQ.1) GOTO 170
2336
2337C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2338C...For e-gamma allow 2 alternatives.
2339 mint(121)=1
2340 IF(mstp(14).EQ.10.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
2341 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2342 & (iabs(mint(11)).GE.28.OR.iabs(mint(12)).GE.28)) mint(121)=3
2343 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=6
2344 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2345 & (iabs(mint(11)).EQ.11.OR.iabs(mint(12)).EQ.11)) mint(121)=2
2346 ELSEIF(mstp(14).EQ.20.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
2347 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2348 & (iabs(mint(11)).GE.28.OR.iabs(mint(12)).GE.28)) mint(121)=3
2349 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=9
2350 ELSEIF(mstp(14).EQ.25.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
2351 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2352 & (iabs(mint(11)).GE.28.OR.iabs(mint(12)).GE.28)) mint(121)=2
2353 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=4
2354 ELSEIF(mstp(14).EQ.30.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
2355 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2356 & (iabs(mint(11)).GE.28.OR.iabs(mint(12)).GE.28)) mint(121)=4
2357 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=13
2358 ENDIF
2359 mint(123)=mstp(14)
2360 IF((mstp(14).EQ.10.OR.mstp(14).EQ.20.OR.mstp(14).EQ.25.OR.
2361 &mstp(14).EQ.30).AND.msel.NE.1.AND.msel.NE.2) mint(123)=0
2362 IF(mstp(14).GE.11.AND.mstp(14).LE.19) THEN
2363 IF(mstp(14).EQ.11) mint(123)=0
2364 IF(mstp(14).EQ.12.OR.mstp(14).EQ.14) mint(123)=5
2365 IF(mstp(14).EQ.13.OR.mstp(14).EQ.17) mint(123)=6
2366 IF(mstp(14).EQ.15) mint(123)=2
2367 IF(mstp(14).EQ.16.OR.mstp(14).EQ.18) mint(123)=7
2368 IF(mstp(14).EQ.19) mint(123)=3
2369 ELSEIF(mstp(14).GE.21.AND.mstp(14).LE.24) THEN
2370 IF(mstp(14).EQ.21) mint(123)=0
2371 IF(mstp(14).EQ.22.OR.mstp(14).EQ.23) mint(123)=4
2372 IF(mstp(14).EQ.24) mint(123)=1
2373 ELSEIF(mstp(14).GE.26.AND.mstp(14).LE.29) THEN
2374 IF(mstp(14).EQ.26.OR.mstp(14).EQ.28) mint(123)=8
2375 IF(mstp(14).EQ.27.OR.mstp(14).EQ.29) mint(123)=9
2376 ENDIF
2377
2378C...Set up kinematics of process.
2379 CALL pyinki(0)
2380
2381C...Set up kinematics for photons inside leptons.
2382 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(1,wtgaga)
2383
2384C...Precalculate flavour selection weights.
2385 CALL pykfin
2386
2387C...Loop over gamma-p or gamma-gamma alternatives.
2388 ckin3=ckin(3)
2389 msav48=0
2390 DO 160 iga=1,mint(121)
2391 ckin(3)=ckin3
2392 mint(122)=iga
2393
2394C...Select partonic subprocesses to be included in the simulation.
2395 CALL pyinpr
2396 mint(101)=1
2397 mint(102)=1
2398 mint(103)=mint(11)
2399 mint(104)=mint(12)
2400
2401C...Count number of subprocesses on.
2402 mint(48)=0
2403 DO 130 isub=1,500
2404 IF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
2405 & msub(isub).EQ.1.AND.mint(121).GT.1) THEN
2406 msub(isub)=0
2407 ELSEIF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
2408 & msub(isub).EQ.1) THEN
2409 WRITE(mstu(11),5200) isub,chlh(mint(41)),chlh(mint(42))
2410 stop
2411 ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN
2412 WRITE(mstu(11),5300) isub
2413 stop
2414 ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN
2415 WRITE(mstu(11),5400) isub
2416 stop
2417 ELSEIF(msub(isub).EQ.1) THEN
2418 mint(48)=mint(48)+1
2419 ENDIF
2420 130 CONTINUE
2421 IF(mint(121).EQ.1.AND.mint(48).EQ.0) THEN
2422 WRITE(mstu(11),5500)
2423 stop
2424 ENDIF
2425 mint(49)=mint(48)-msub(91)-msub(92)-msub(93)-msub(94)
2426 msav48=msav48+mint(48)
2427
2428C...Reset variables for cross-section calculation.
2429 DO 150 i=0,500
2430 DO 140 j=1,3
2431 ngen(i,j)=0
2432 xsec(i,j)=0d0
2433 140 CONTINUE
2434 150 CONTINUE
2435
2436C...Find parametrized total cross-sections.
2437 CALL pyxtot
2438 vint(318)=vint(317)
2439
2440C...Maxima of differential cross-sections.
2441 IF(mstp(121).LE.1) CALL pymaxi
2442
2443C...Initialize possibility of pileup events.
2444 IF(mint(121).GT.1) mstp(131)=0
2445 IF(mstp(131).NE.0) CALL pypile(1)
2446
2447C...Initialize multiple interactions with variable impact parameter.
2448 IF(mint(50).EQ.1.AND.(mint(49).NE.0.OR.mstp(131).NE.0).AND.
2449 & mstp(82).GE.2) CALL pymult(1)
2450
2451C...Save results for gamma-p and gamma-gamma alternatives.
2452 IF(mint(121).GT.1) CALL pysave(1,iga)
2453 160 CONTINUE
2454
2455C...Initialization finished.
2456 IF(msav48.EQ.0) THEN
2457 WRITE(mstu(11),5500)
2458 stop
2459 ENDIF
2460 170 IF(mstp(122).GE.1) WRITE(mstu(11),5600)
2461
2462C...Formats for initialization information.
2463 5100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',
2464 &'routines',1x,17('*'))
2465 5200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,
2466 &'-',a6,' interactions.'/1x,'Execution stopped!')
2467 5300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/
2468 &1x,'Execution stopped!')
2469 5400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/
2470 &1x,'Execution stopped!')
2471 5500 FORMAT(1x,'Error: no subprocess switched on.'/
2472 &1x,'Execution stopped.')
2473 5600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,
2474 &22('*'))
2475
2476 RETURN
2477 END
2478
2479C*********************************************************************
2480
2481C...PYEVNT
2482C...Administers the generation of a high-pT event via calls to
2483C...a number of subroutines.
2484
2485 SUBROUTINE pyevnt
2486
2487C...Double precision and integer declarations.
2488 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2489 IMPLICIT INTEGER(I-N)
2490 INTEGER PYK,PYCHGE,PYCOMP
2491C...Commonblocks.
2492 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2493 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2494 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2495 common/pypars/mstp(200),parp(200),msti(200),pari(200)
2496 common/pyint1/mint(400),vint(400)
2497 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2498 common/pyint4/mwid(500),wids(500,5)
2499 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2500 common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
2501 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,
2502 &/pyint4/,/pyint5/,/pyuppr/
2503C...Local array.
2504 dimension vtx(4)
2505
2506C...Initial values for some counters.
2507 n=0
2508 mint(5)=mint(5)+1
2509 mint(7)=0
2510 mint(8)=0
2511 mint(83)=0
2512 mint(84)=mstp(126)
2513 mstu(24)=0
2514 mstu70=0
2515 mstj14=mstj(14)
2516
2517C...If variable energies: redo incoming kinematics and cross-section.
2518 msti(61)=0
2519 IF(mstp(171).EQ.1) THEN
2520 CALL pyinki(1)
2521 IF(msti(61).EQ.1) THEN
2522 mint(5)=mint(5)-1
2523 RETURN
2524 ENDIF
2525 IF(mint(121).GT.1) CALL pysave(3,1)
2526 CALL pyxtot
2527 ENDIF
2528
2529C...Loop over number of pileup events; check space left.
2530 IF(mstp(131).LE.0) THEN
2531 npile=1
2532 ELSE
2533 CALL pypile(2)
2534 npile=mint(81)
2535 ENDIF
2536 DO 260 ipile=1,npile
2537 IF(mint(84)+100.GE.mstu(4)) THEN
2538 CALL pyerrm(11,
2539 & '(PYEVNT:) no more space in PYJETS for pileup events')
2540 IF(mstu(21).GE.1) GOTO 270
2541 ENDIF
2542 mint(82)=ipile
2543
2544C...Generate variables of hard scattering.
2545 mint(51)=0
2546 msti(52)=0
2547 100 CONTINUE
2548 IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
2549 mint(31)=0
2550 mint(51)=0
2551 mint(57)=0
2552 CALL pyrand
2553 IF(msti(61).EQ.1) THEN
2554 mint(5)=mint(5)-1
2555 RETURN
2556 ENDIF
2557 IF(mint(51).EQ.2) RETURN
2558 isub=mint(1)
2559 IF(mstp(111).EQ.-1) GOTO 250
2560
2561 IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
2562C...Hard scattering (including low-pT):
2563C...reconstruct kinematics and colour flow of hard scattering.
2564 mint31=mint(31)
2565 110 mint(31)=mint31
2566 mint(51)=0
2567 CALL pyscat
2568 IF(mint(51).EQ.1) GOTO 100
2569 ipu1=mint(84)+1
2570 ipu2=mint(84)+2
2571 IF(isub.EQ.95) GOTO 130
2572
2573C...Showering of initial state partons (optional).
2574 alamsv=parj(81)
2575 parj(81)=parp(72)
2576 IF(mstp(61).GE.1.AND.mint(47).GE.2) CALL pysspa(ipu1,ipu2)
2577 parj(81)=alamsv
2578 IF(mint(51).EQ.1) GOTO 100
2579
2580C...Showering of final state partons (optional).
2581 alamsv=parj(81)
2582 parj(81)=parp(72)
2583 IF(mstp(71).GE.1.AND.iset(isub).GE.2.AND.iset(isub).LE.10)
2584 & THEN
2585 ipu3=mint(84)+3
2586 ipu4=mint(84)+4
2587 IF(iset(isub).EQ.5) ipu4=-3
2588 qmax=vint(55)
2589 IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
2590 CALL pyshow(ipu3,ipu4,qmax)
2591 ELSEIF(mstp(71).GE.1.AND.iset(isub).EQ.11.AND.nfup.GE.1) THEN
2592 DO 120 iup=1,nfup
2593 ipu3=ifup(iup,1)+mint(84)
2594 ipu4=ifup(iup,2)+mint(84)
2595 qmax=sqrt(max(0d0,q2up(iup)))
2596 CALL pyshow(ipu3,ipu4,qmax)
2597 120 CONTINUE
2598 ENDIF
2599 parj(81)=alamsv
2600
2601C...Decay of final state resonances.
2602 mint(32)=0
2603 IF(mstp(41).GE.1.AND.iset(isub).LE.10) CALL pyresd(0)
2604 IF(mint(51).EQ.1) GOTO 100
2605 mint(52)=n
2606
2607C...Multiple interactions.
2608 IF(mstp(81).GE.1.AND.mint(50).EQ.1) CALL pymult(6)
2609 mint(53)=n
2610
2611C...Hadron remnants and primordial kT.
2612 130 CALL pyremn(ipu1,ipu2)
2613 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) GOTO 110
2614 IF(mint(51).EQ.1) GOTO 100
2615
2616 ELSEIF(isub.NE.99) THEN
2617C...Diffractive and elastic scattering.
2618 CALL pydiff
2619
2620 ELSE
2621C...DIS scattering (photon flux external).
2622 CALL pydisg
2623 IF(mint(51).EQ.1) GOTO 100
2624 ENDIF
2625
2626C...Check that no odd resonance left undecayed.
2627 IF(mstp(111).GE.1) THEN
2628 nfix=n
2629 DO 140 i=mint(84)+1,nfix
2630 IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
2631 & k(i,2).NE.22) THEN
2632 IF(mwid(pycomp(k(i,2))).NE.0) THEN
2633 CALL pyresd(i)
2634 IF(mint(51).EQ.1) GOTO 100
2635 ENDIF
2636 ENDIF
2637 140 CONTINUE
2638 ENDIF
2639
2640C...Boost hadronic subsystem to overall rest frame.
2641C..(Only relevant when photon inside lepton beam.)
2642 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
2643
2644C...Recalculate energies from momenta and masses (if desired).
2645 IF(mstp(113).GE.1) THEN
2646 DO 150 i=mint(83)+1,n
2647 IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
2648 & p(i,2)**2+p(i,3)**2+p(i,5)**2)
2649 150 CONTINUE
2650 nrecal=n
2651 ENDIF
2652
2653C...Rearrange partons along strings, check invariant mass cuts.
2654 mstu(28)=0
2655 IF(mstp(111).LE.0) mstj(14)=-1
2656 CALL pyprep(mint(84)+1)
2657 mstj(14)=mstj14
2658 IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100
2659 IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
2660 DO 180 i=mint(84)+1,n
2661 IF(k(i,2).EQ.94) THEN
2662 DO 170 i1=i+1,min(n,i+3)
2663 IF(k(i1,3).EQ.i) THEN
2664 k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
2665 IF(k(i1,3).EQ.0) THEN
2666 DO 160 ii=mint(84)+1,i-1
2667 IF(k(ii,2).EQ.k(i1,2)) THEN
2668 IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
2669 & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
2670 ENDIF
2671 160 CONTINUE
2672 IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
2673 ENDIF
2674 ENDIF
2675 170 CONTINUE
2676 ENDIF
2677 180 CONTINUE
2678 CALL pyedit(12)
2679 CALL pyedit(14)
2680 IF(mstp(125).EQ.0) CALL pyedit(15)
2681 IF(mstp(125).EQ.0) mint(4)=0
2682 DO 200 i=mint(83)+1,n
2683 IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
2684 DO 190 i1=i+1,n
2685 IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
2686 IF(k(i1,3).EQ.i) k(i,5)=i1
2687 190 CONTINUE
2688 ENDIF
2689 200 CONTINUE
2690 ENDIF
2691
2692C...Introduce separators between sections in PYLIST event listing.
2693 IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
2694 mstu70=1
2695 mstu(71)=n
2696 ELSEIF(ipile.EQ.1) THEN
2697 mstu70=3
2698 mstu(71)=2
2699 mstu(72)=mint(4)
2700 mstu(73)=n
2701 ENDIF
2702
2703C...Go back to lab frame (needed for vertices, also in fragmentation).
2704 CALL pyfram(1)
2705
2706C...Set nonvanishing production vertex (optional).
2707 IF(mstp(151).EQ.1) THEN
2708 DO 210 j=1,4
2709 vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
2710 & sin(paru(2)*pyr(0))
2711 210 CONTINUE
2712 DO 230 i=mint(83)+1,n
2713 DO 220 j=1,4
2714 v(i,j)=v(i,j)+vtx(j)
2715 220 CONTINUE
2716 230 CONTINUE
2717 ENDIF
2718
2719C...Perform hadronization (if desired).
2720 IF(mstp(111).GE.1) THEN
2721 CALL pyexec
2722 IF(mstu(24).NE.0) GOTO 100
2723 ENDIF
2724 IF(mstp(113).GE.1) THEN
2725 DO 240 i=nrecal,n
2726 IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
2727 & p(i,2)**2+p(i,3)**2+p(i,5)**2)
2728 240 CONTINUE
2729 ENDIF
2730 IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
2731
2732C...Store event information and calculate Monte Carlo estimates of
2733C...subprocess cross-sections.
2734 250 IF(ipile.EQ.1) CALL pydocu
2735
2736C...Set counters for current pileup event and loop to next one.
2737 msti(41)=ipile
2738 IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
2739 IF(mstu70.LT.10) THEN
2740 mstu70=mstu70+1
2741 mstu(70+mstu70)=n
2742 ENDIF
2743 mint(83)=n
2744 mint(84)=n+mstp(126)
2745 IF(ipile.LT.npile) CALL pyfram(2)
2746 260 CONTINUE
2747
2748C...Generic information on pileup events. Reconstruct missing history.
2749 IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
2750 pari(91)=vint(132)
2751 pari(92)=vint(133)
2752 pari(93)=vint(134)
2753 IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
2754 ENDIF
2755 CALL pyedit(16)
2756
2757C...Transform to the desired coordinate frame.
2758 270 CALL pyfram(mstp(124))
2759 mstu(70)=mstu70
2760 paru(21)=vint(1)
2761
2762 RETURN
2763 END
2764
2765C***********************************************************************
2766
2767C...PYSTAT
2768C...Prints out information about cross-sections, decay widths, branching
2769C...ratios, kinematical limits, status codes and parameter values.
2770
2771 SUBROUTINE pystat(MSTAT)
2772
2773C...Double precision and integer declarations.
2774 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2775 IMPLICIT INTEGER(I-N)
2776 INTEGER PYK,PYCHGE,PYCOMP
2777C...Parameter statement to help give large particle numbers.
2778 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
2779C...Commonblocks.
2780 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2781 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2782 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
2783 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2784 common/pypars/mstp(200),parp(200),msti(200),pari(200)
2785 common/pyint1/mint(400),vint(400)
2786 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2787 common/pyint4/mwid(500),wids(500,5)
2788 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2789 common/pyint6/proc(0:500)
2790 CHARACTER PROC*28
2791 common/pymssm/imss(0:99),rmss(0:99)
2792 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
2793 &/pyint2/,/pyint4/,/pyint5/,/pyint6/,/pymssm/
2794C...Local arrays, character variables and data.
2795 dimension wdtp(0:200),wdte(0:200,0:5)
2796 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2797 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
2798 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
2799 DATA proga/
2800 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2801 &'VMD/hadron * anomalous ','direct * direct ',
2802 &'direct * anomalous ','anomalous * anomalous '/
2803 DATA disga/'e * VMD','e * anomalous'/
2804 DATA progg9/
2805 &'direct * direct ','direct * VMD ',
2806 &'direct * anomalous ','VMD * direct ',
2807 &'VMD * VMD ','VMD * anomalous ',
2808 &'anomalous * direct ','anomalous * VMD ',
2809 &'anomalous * anomalous ','DIS * VMD ',
2810 &'DIS * anomalous ','VMD * DIS ',
2811 &'anomalous * DIS '/
2812 DATA progg4/
2813 &'direct * direct ','direct * resolved ',
2814 &'resolved * direct ','resolved * resolved '/
2815 DATA progg2/
2816 &'direct * hadron ','resolved * hadron '/
2817 DATA progp4/
2818 &'VMD * hadron ','direct * hadron ',
2819 &'anomalous * hadron ','DIS * hadron '/
2820 DATA state/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2821 &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2822 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2823 &' y*_small ',' eta*_large ',' eta*_small ',
2824 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2825 &' x_2 ',' x_F ',' cos(theta_hard) ',
2826 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2827 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2828 &' tau'' '/
2829
2830C...Cross-sections.
2831 IF(mstat.LE.1) THEN
2832 IF(mint(121).GT.1) CALL pysave(5,0)
2833 WRITE(mstu(11),5000)
2834 WRITE(mstu(11),5100)
2835 WRITE(mstu(11),5200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)
2836 DO 100 i=1,500
2837 IF(msub(i).NE.1) GOTO 100
2838 WRITE(mstu(11),5200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)
2839 100 CONTINUE
2840 IF(mint(121).GT.1) THEN
2841 WRITE(mstu(11),5300)
2842 DO 110 iga=1,mint(121)
2843 CALL pysave(3,iga)
2844 IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
2845 WRITE(mstu(11),5200) iga,disga(iga),ngen(0,3),ngen(0,1),
2846 & xsec(0,3)
2847 ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
2848 WRITE(mstu(11),5200) iga,progg9(iga),ngen(0,3),ngen(0,1),
2849 & xsec(0,3)
2850 ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.30) THEN
2851 WRITE(mstu(11),5200) iga,progp4(iga),ngen(0,3),ngen(0,1),
2852 & xsec(0,3)
2853 ELSEIF(mint(121).EQ.4) THEN
2854 WRITE(mstu(11),5200) iga,progg4(iga),ngen(0,3),ngen(0,1),
2855 & xsec(0,3)
2856 ELSEIF(mint(121).EQ.2) THEN
2857 WRITE(mstu(11),5200) iga,progg2(iga),ngen(0,3),ngen(0,1),
2858 & xsec(0,3)
2859 ELSE
2860 WRITE(mstu(11),5200) iga,proga(iga),ngen(0,3),ngen(0,1),
2861 & xsec(0,3)
2862 ENDIF
2863 110 CONTINUE
2864 CALL pysave(5,0)
2865 ENDIF
2866 WRITE(mstu(11),5400) 1d0-dble(ngen(0,3))/
2867 & max(1d0,dble(ngen(0,2)))
2868
2869C...Decay widths and branching ratios.
2870 ELSEIF(mstat.EQ.2) THEN
2871 WRITE(mstu(11),5500)
2872 WRITE(mstu(11),5600)
2873 DO 140 kc=1,500
2874 kf=kchg(kc,4)
2875 CALL pyname(kf,chkf)
2876 ioff=0
2877 IF(kc.LE.22) THEN
2878 IF(kc.GT.2*mstp(1).AND.kc.LE.10) GOTO 140
2879 IF(kc.GT.10+2*mstp(1).AND.kc.LE.20) GOTO 140
2880 IF(kc.LE.5.OR.(kc.GE.11.AND.kc.LE.16)) ioff=1
2881 IF(kc.EQ.18.AND.pmas(18,1).LT.1d0) ioff=1
2882 IF(kc.EQ.21.OR.kc.EQ.22) ioff=1
2883 ELSE
2884 IF(mwid(kc).LE.0) GOTO 140
2885 IF(imss(1).LE.0.AND.(kf/ksusy1.EQ.1.OR.
2886 & kf/ksusy1.EQ.2)) GOTO 140
2887 ENDIF
2888C...Off-shell branchings.
2889 IF(ioff.EQ.1) THEN
2890 ngp=0
2891 IF(kc.LE.20) ngp=(mod(kc,10)+1)/2
2892 IF(ngp.LE.mstp(1)) WRITE(mstu(11),5700) kf,chkf(1:10),
2893 & pmas(kc,1),0d0,0d0,state(mdcy(kc,1)),0d0
2894 DO 120 j=1,mdcy(kc,3)
2895 idc=j+mdcy(kc,2)-1
2896 ngp1=0
2897 IF(iabs(kfdp(idc,1)).LE.20) ngp1=
2898 & (mod(iabs(kfdp(idc,1)),10)+1)/2
2899 ngp2=0
2900 IF(iabs(kfdp(idc,2)).LE.20) ngp2=
2901 & (mod(iabs(kfdp(idc,2)),10)+1)/2
2902 CALL pyname(kfdp(idc,1),chd1)
2903 CALL pyname(kfdp(idc,2),chd2)
2904 IF(kfdp(idc,3).EQ.0) THEN
2905 IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
2906 & ngp2.LE.mstp(1)) WRITE(mstu(11),5800) idc,chd1(1:10),
2907 & chd2(1:10),0d0,0d0,state(mdme(idc,1)),0d0
2908 ELSE
2909 CALL pyname(kfdp(idc,3),chd3)
2910 IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
2911 & ngp2.LE.mstp(1)) WRITE(mstu(11),5900) idc,chd1(1:10),
2912 & chd2(1:10),chd3(1:10),0d0,0d0,state(mdme(idc,1)),0d0
2913 ENDIF
2914 120 CONTINUE
2915C...On-shell decays.
2916 ELSE
2917 CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
2918 brfin=1d0
2919 IF(wdte(0,0).LE.0d0) brfin=0d0
2920 WRITE(mstu(11),5700) kf,chkf(1:10),pmas(kc,1),wdtp(0),1d0,
2921 & state(mdcy(kc,1)),brfin
2922 DO 130 j=1,mdcy(kc,3)
2923 idc=j+mdcy(kc,2)-1
2924 ngp1=0
2925 IF(iabs(kfdp(idc,1)).LE.20) ngp1=
2926 & (mod(iabs(kfdp(idc,1)),10)+1)/2
2927 ngp2=0
2928 IF(iabs(kfdp(idc,2)).LE.20) ngp2=
2929 & (mod(iabs(kfdp(idc,2)),10)+1)/2
2930 brfin=0d0
2931 IF(wdte(0,0).GT.0d0) brfin=wdte(j,0)/wdte(0,0)
2932 CALL pyname(kfdp(idc,1),chd1)
2933 CALL pyname(kfdp(idc,2),chd2)
2934 IF(kfdp(idc,3).EQ.0) THEN
2935 IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
2936 & WRITE(mstu(11),5800) idc,chd1(1:10),
2937 & chd2(1:10),wdtp(j),wdtp(j)/wdtp(0),
2938 & state(mdme(idc,1)),brfin
2939 ELSE
2940 CALL pyname(kfdp(idc,3),chd3)
2941 IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
2942 & WRITE(mstu(11),5900) idc,chd1(1:10),
2943 & chd2(1:10),chd3(1:10),wdtp(j),wdtp(j)/wdtp(0),
2944 & state(mdme(idc,1)),brfin
2945 ENDIF
2946 130 CONTINUE
2947 ENDIF
2948 140 CONTINUE
2949 WRITE(mstu(11),6000)
2950
2951C...Allowed incoming partons/particles at hard interaction.
2952 ELSEIF(mstat.EQ.3) THEN
2953 WRITE(mstu(11),6100)
2954 CALL pyname(mint(11),chau)
2955 chin(1)=chau(1:12)
2956 CALL pyname(mint(12),chau)
2957 chin(2)=chau(1:12)
2958 WRITE(mstu(11),6200) chin(1),chin(2)
2959 DO 150 i=-20,22
2960 IF(i.EQ.0) GOTO 150
2961 ia=iabs(i)
2962 IF(ia.GT.mstp(58).AND.ia.LE.10) GOTO 150
2963 IF(ia.GT.10+2*mstp(1).AND.ia.LE.20) GOTO 150
2964 CALL pyname(i,chau)
2965 WRITE(mstu(11),6300) chau,state(kfin(1,i)),chau,
2966 & state(kfin(2,i))
2967 150 CONTINUE
2968 WRITE(mstu(11),6400)
2969
2970C...User-defined limits on kinematical variables.
2971 ELSEIF(mstat.EQ.4) THEN
2972 WRITE(mstu(11),6500)
2973 WRITE(mstu(11),6600)
2974 shrmax=ckin(2)
2975 IF(shrmax.LT.0d0) shrmax=vint(1)
2976 WRITE(mstu(11),6700) ckin(1),chkin(1),shrmax
2977 pthmin=max(ckin(3),ckin(5))
2978 pthmax=ckin(4)
2979 IF(pthmax.LT.0d0) pthmax=0.5d0*shrmax
2980 WRITE(mstu(11),6800) ckin(3),pthmin,chkin(2),pthmax
2981 WRITE(mstu(11),6900) chkin(3),ckin(6)
2982 DO 160 i=4,14
2983 WRITE(mstu(11),6700) ckin(2*i-1),chkin(i),ckin(2*i)
2984 160 CONTINUE
2985 sprmax=ckin(32)
2986 IF(sprmax.LT.0d0) sprmax=vint(1)
2987 WRITE(mstu(11),6700) ckin(31),chkin(15),sprmax
2988 WRITE(mstu(11),7000)
2989
2990C...Status codes and parameter values.
2991 ELSEIF(mstat.EQ.5) THEN
2992 WRITE(mstu(11),7100)
2993 WRITE(mstu(11),7200)
2994 DO 170 i=1,100
2995 WRITE(mstu(11),7300) i,mstp(i),parp(i),100+i,mstp(100+i),
2996 & parp(100+i)
2997 170 CONTINUE
2998
2999C...List of all processes implemented in the program.
3000 ELSEIF(mstat.EQ.6) THEN
3001 WRITE(mstu(11),7400)
3002 WRITE(mstu(11),7500)
3003 DO 180 i=1,500
3004 IF(iset(i).LT.0) GOTO 180
3005 WRITE(mstu(11),7600) i,proc(i),iset(i),kfpr(i,1),kfpr(i,2)
3006 180 CONTINUE
3007 WRITE(mstu(11),7700)
3008 ENDIF
3009
3010C...Formats for printouts.
3011 5000 FORMAT('1',9('*'),1x,'PYSTAT: Statistics on Number of ',
3012 &'Events and Cross-sections',1x,9('*'))
3013 5100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,
3014 &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,
3015 &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),
3016 &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,
3017 &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,
3018 &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,
3019 &'I',12x,'I')
3020 5200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,
3021 &d10.3,1x,'I')
3022 5300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/
3023 &1x,'I',34x,'I',28x,'I',12x,'I')
3024 5400 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//
3025 &1x,'********* Fraction of events that fail fragmentation ',
3026 &'cuts =',1x,f8.5,' *********'/)
3027 5500 FORMAT('1',27('*'),1x,'PYSTAT: Decay Widths and Branching ',
3028 &'Ratios',1x,27('*'))
3029 5600 FORMAT(/1x,98('=')/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
3030 &1x,'I',5x,'Mother --> Branching/Decay Channel',8x,'I',1x,
3031 &'Width (GeV)',1x,'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,
3032 &'Eff. B.R.',1x,'I'/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
3033 &1x,98('='))
3034 5700 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,
3035 &i8,2x,a10,3x,'(m =',f10.3,')',2x,'-->',5x,'I',2x,1p,d10.3,0p,1x,
3036 &'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,d10.3,0p,1x,'I')
3037 5800 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,15x,'I',2x,
3038 &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
3039 &1p,d10.3,0p,1x,'I')
3040 5900 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,1x,'+',1x,a10,2x,'I',2x,
3041 &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
3042 &1p,d10.3,0p,1x,'I')
3043 6000 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,98('='))
3044 6100 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',
3045 &'Particles at Hard Interaction',1x,7('*'))
3046 6200 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,
3047 &'Beam particle:',1x,a12,10x,'I',1x,'Target particle:',1x,a12,7x,
3048 &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',6x,'State',19x,
3049 &'I',1x,'Content',6x,'State',18x,'I'/1x,'I',38x,'I',37x,'I'/1x,
3050 &78('=')/1x,'I',38x,'I',37x,'I')
3051 6300 FORMAT(1x,'I',1x,a9,5x,a4,19x,'I',1x,a9,5x,a4,18x,'I')
3052 6400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))
3053 6500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',
3054 &'Kinematical Variables',1x,12('*'))
3055 6600 FORMAT(/1x,78('=')/1x,'I',76x,'I')
3056 6700 FORMAT(1x,'I',16x,1p,d10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,d10.3,0p,
3057 &16x,'I')
3058 6800 FORMAT(1x,'I',3x,1p,d10.3,0p,1x,'(',1p,d10.3,0p,')',1x,'<',1x,a,
3059 &1x,'<',1x,1p,d10.3,0p,16x,'I')
3060 6900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,d10.3,0p,16x,'I')
3061 7000 FORMAT(1x,'I',76x,'I'/1x,78('='))
3062 7100 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',
3063 &'Parameter Values',1x,12('*'))
3064 7200 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,
3065 &'PARP(I)'/)
3066 7300 FORMAT(1x,i3,5x,i6,6x,1p,d10.3,0p,18x,i3,5x,i6,6x,1p,d10.3)
3067 7400 FORMAT('1',13('*'),1x,'PYSTAT: List of implemented processes',
3068 &1x,13('*'))
3069 7500 FORMAT(/1x,65('=')/1x,'I',34x,'I',28x,'I'/1x,'I',12x,
3070 &'Subprocess',12x,'I',1x,'ISET',2x,'KFPR(I,1)',2x,'KFPR(I,2)',1x,
3071 &'I'/1x,'I',34x,'I',28x,'I'/1x,65('=')/1x,'I',34x,'I',28x,'I')
3072 7600 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i4,1x,i10,1x,i10,1x,'I')
3073 7700 FORMAT(1x,'I',34x,'I',28x,'I'/1x,65('='))
3074
3075 RETURN
3076 END
3077
3078C*********************************************************************
3079
3080C...PYINRE
3081C...Calculates full and effective widths of gauge bosons, stores
3082C...masses and widths, rescales coefficients to be used for
3083C...resonance production generation.
3084
3085 SUBROUTINE pyinre
3086
3087C...Double precision and integer declarations.
3088 IMPLICIT DOUBLE PRECISION(a-h, o-z)
3089 IMPLICIT INTEGER(I-N)
3090 INTEGER PYK,PYCHGE,PYCOMP
3091C...Parameter statement to help give large particle numbers.
3092 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
3093C...Commonblocks.
3094 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3095 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3096 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
3097 common/pydat4/chaf(500,2)
3098 CHARACTER CHAF*16
3099 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3100 common/pypars/mstp(200),parp(200),msti(200),pari(200)
3101 common/pyint1/mint(400),vint(400)
3102 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3103 common/pyint4/mwid(500),wids(500,5)
3104 common/pyint6/proc(0:500)
3105 CHARACTER PROC*28
3106 common/pymssm/imss(0:99),rmss(0:99)
3107 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
3108 &/pyint1/,/pyint2/,/pyint4/,/pyint6/,/pymssm/
3109C...Local arrays and data.
3110 dimension wdtp(0:200),wdte(0:200,0:5),wdtpm(0:200),
3111 &wdtem(0:200,0:5),kcord(500),pmord(500)
3112
3113C...Born level couplings in MSSM Higgs doublet sector.
3114 xw=paru(102)
3115 xwv=xw
3116 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
3117 xw1=1d0-xw
3118 IF(mstp(4).EQ.2) THEN
3119 tanbe=paru(141)
3120 ratbe=((1d0-tanbe**2)/(1d0+tanbe**2))**2
3121 sqmz=pmas(23,1)**2
3122 sqmw=pmas(24,1)**2
3123 sqmh=pmas(25,1)**2
3124 sqma=sqmh*(sqmz-sqmh)/(sqmz*ratbe-sqmh)
3125 sqmhp=0.5d0*(sqma+sqmz+sqrt((sqma+sqmz)**2-4d0*sqma*sqmz*ratbe))
3126 sqmhc=sqma+sqmw
3127 IF(sqmh.GE.sqmz.OR.min(sqma,sqmhp,sqmhc).LE.0d0) THEN
3128 WRITE(mstu(11),5000)
3129 stop
3130 ENDIF
3131 pmas(35,1)=sqrt(sqmhp)
3132 pmas(36,1)=sqrt(sqma)
3133 pmas(37,1)=sqrt(sqmhc)
3134 alsu=0.5d0*atan(2d0*tanbe*(sqma+sqmz)/((1d0-tanbe**2)*
3135 & (sqma-sqmz)))
3136 besu=atan(tanbe)
3137 paru(142)=1d0
3138 paru(143)=1d0
3139 paru(161)=-sin(alsu)/cos(besu)
3140 paru(162)=cos(alsu)/sin(besu)
3141 paru(163)=paru(161)
3142 paru(164)=sin(besu-alsu)
3143 paru(165)=paru(164)
3144 paru(168)=sin(besu-alsu)+0.5d0*cos(2d0*besu)*sin(besu+alsu)/xw
3145 paru(171)=cos(alsu)/cos(besu)
3146 paru(172)=sin(alsu)/sin(besu)
3147 paru(173)=paru(171)
3148 paru(174)=cos(besu-alsu)
3149 paru(175)=paru(174)
3150 paru(176)=cos(2d0*alsu)*cos(besu+alsu)-2d0*sin(2d0*alsu)*
3151 & sin(besu+alsu)
3152 paru(177)=cos(2d0*besu)*cos(besu+alsu)
3153 paru(178)=cos(besu-alsu)-0.5d0*cos(2d0*besu)*cos(besu+alsu)/xw
3154 paru(181)=tanbe
3155 paru(182)=1d0/tanbe
3156 paru(183)=paru(181)
3157 paru(184)=0d0
3158 paru(185)=paru(184)
3159 paru(186)=cos(besu-alsu)
3160 paru(187)=sin(besu-alsu)
3161 paru(188)=paru(186)
3162 paru(189)=paru(187)
3163 paru(190)=0d0
3164 paru(195)=cos(besu-alsu)
3165 ENDIF
3166
3167C...Reset effective widths of gauge bosons.
3168 DO 110 i=1,500
3169 DO 100 j=1,5
3170 wids(i,j)=1d0
3171 100 CONTINUE
3172 110 CONTINUE
3173
3174C...Order resonances by increasing mass (except Z0 and W+/-).
3175 nres=0
3176 DO 140 kc=1,500
3177 kf=kchg(kc,4)
3178 IF(kf.EQ.0) GOTO 140
3179 IF(mwid(kc).EQ.0) GOTO 140
3180 IF(kc.EQ.7.OR.kc.EQ.8.OR.kc.EQ.17.OR.kc.EQ.18) THEN
3181 IF(mstp(1).LE.3) GOTO 140
3182 ENDIF
3183 IF(kf/ksusy1.EQ.1.OR.kf/ksusy1.EQ.2) THEN
3184 IF(imss(1).LE.0) GOTO 140
3185 ENDIF
3186 nres=nres+1
3187 pmres=pmas(kc,1)
3188 IF(kc.EQ.23.OR.kc.EQ.24) pmres=0d0
3189 DO 120 i1=nres-1,1,-1
3190 IF(pmres.GE.pmord(i1)) GOTO 130
3191 kcord(i1+1)=kcord(i1)
3192 pmord(i1+1)=pmord(i1)
3193 120 CONTINUE
3194 130 kcord(i1+1)=kc
3195 pmord(i1+1)=pmres
3196 140 CONTINUE
3197
3198C...Loop over possible resonances.
3199 DO 180 i=1,nres
3200 kc=kcord(i)
3201 kf=kchg(kc,4)
3202
3203C...Check that no fourth generation channels on by mistake.
3204 IF(mstp(1).LE.3) THEN
3205 DO 150 j=1,mdcy(kc,3)
3206 idc=j+mdcy(kc,2)-1
3207 kfa1=iabs(kfdp(idc,1))
3208 kfa2=iabs(kfdp(idc,2))
3209 IF(kfa1.EQ.7.OR.kfa1.EQ.8.OR.kfa1.EQ.17.OR.kfa1.EQ.18.OR.
3210 & kfa2.EQ.7.OR.kfa2.EQ.8.OR.kfa2.EQ.17.OR.kfa2.EQ.18)
3211 & mdme(idc,1)=-1
3212 150 CONTINUE
3213 ENDIF
3214
3215C...Check that no supersymmetric channels on by mistake.
3216 IF(imss(1).LE.0) THEN
3217 DO 160 j=1,mdcy(kc,3)
3218 idc=j+mdcy(kc,2)-1
3219 kfa1s=iabs(kfdp(idc,1))/ksusy1
3220 kfa2s=iabs(kfdp(idc,2))/ksusy1
3221 IF(kfa1s.EQ.1.OR.kfa1s.EQ.2.OR.kfa2s.EQ.1.OR.kfa2s.EQ.2)
3222 & mdme(idc,1)=-1
3223 160 CONTINUE
3224 ENDIF
3225
3226C...Find mass and evaluate width.
3227 pmr=pmas(kc,1)
3228 IF(kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) mint(62)=1
3229 IF(mwid(kc).EQ.3) mint(63)=1
3230 CALL pywidt(kf,pmr**2,wdtp,wdte)
3231 mint(51)=0
3232
3233C...Evaluate suppression factors due to non-simulated channels.
3234 IF(kchg(kc,3).EQ.0) THEN
3235 wids(kc,1)=((wdte(0,1)+wdte(0,2))**2+
3236 & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
3237 & 2d0*wdte(0,4)*wdte(0,5))/wdtp(0)**2
3238 wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
3239 wids(kc,3)=0d0
3240 wids(kc,4)=0d0
3241 wids(kc,5)=0d0
3242 ELSE
3243 IF(mwid(kc).EQ.3) mint(63)=1
3244 CALL pywidt(-kf,pmr**2,wdtpm,wdtem)
3245 mint(51)=0
3246 wids(kc,1)=((wdte(0,1)+wdte(0,2))*(wdtem(0,1)+wdtem(0,3))+
3247 & (wdte(0,1)+wdte(0,2))*(wdtem(0,4)+wdtem(0,5))+
3248 & (wdte(0,4)+wdte(0,5))*(wdtem(0,1)+wdtem(0,3))+
3249 & wdte(0,4)*wdtem(0,5)+wdte(0,5)*wdtem(0,4))/wdtp(0)**2
3250 wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
3251 wids(kc,3)=(wdtem(0,1)+wdtem(0,3)+wdtem(0,4))/wdtp(0)
3252 wids(kc,4)=((wdte(0,1)+wdte(0,2))**2+
3253 & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
3254 & 2d0*wdte(0,4)*wdte(0,5))/wdtp(0)**2
3255 wids(kc,5)=((wdtem(0,1)+wdtem(0,3))**2+
3256 & 2d0*(wdtem(0,1)+wdtem(0,3))*(wdtem(0,4)+wdtem(0,5))+
3257 & 2d0*wdtem(0,4)*wdtem(0,5))/wdtp(0)**2
3258 ENDIF
3259
3260C...Set resonance widths and branching ratios;
3261C...also on/off switch for decays.
3262 IF(mwid(kc).EQ.1.OR.mwid(kc).EQ.3) THEN
3263 pmas(kc,2)=wdtp(0)
3264 pmas(kc,3)=min(0.9d0*pmas(kc,1),10d0*pmas(kc,2))
3265 mdcy(kc,1)=mstp(41)
3266 DO 170 j=1,mdcy(kc,3)
3267 idc=j+mdcy(kc,2)-1
3268 brat(idc)=0d0
3269 IF(wdtp(0).GT.0d0) brat(idc)=wdtp(j)/wdtp(0)
3270 170 CONTINUE
3271 ENDIF
3272 180 CONTINUE
3273
3274C...Flavours of leptoquark: redefine charge and name.
3275 kflqq=kfdp(mdcy(39,2),1)
3276 kflql=kfdp(mdcy(39,2),2)
3277 kchg(39,1)=kchg(pycomp(kflqq),1)*isign(1,kflqq)+
3278 &kchg(pycomp(kflql),1)*isign(1,kflql)
3279 ll=1
3280 IF(iabs(kflql).EQ.13) ll=2
3281 IF(iabs(kflql).EQ.15) ll=3
3282 chaf(39,1)='LQ_'//chaf(iabs(kflqq),1)(1:1)//
3283 &chaf(iabs(kflql),1)(1:ll)//' '
3284 chaf(39,2)=chaf(39,2)(1:4+ll)//'bar '
3285
3286C...Special cases in treatment of gamma*/Z0: redefine process name.
3287 IF(mstp(43).EQ.1) THEN
3288 proc(1)='f + fbar -> gamma*'
3289 proc(15)='f + fbar -> g + gamma*'
3290 proc(19)='f + fbar -> gamma + gamma*'
3291 proc(30)='f + g -> f + gamma*'
3292 proc(35)='f + gamma -> f + gamma*'
3293 ELSEIF(mstp(43).EQ.2) THEN
3294 proc(1)='f + fbar -> Z0'
3295 proc(15)='f + fbar -> g + Z0'
3296 proc(19)='f + fbar -> gamma + Z0'
3297 proc(30)='f + g -> f + Z0'
3298 proc(35)='f + gamma -> f + Z0'
3299 ELSEIF(mstp(43).EQ.3) THEN
3300 proc(1)='f + fbar -> gamma*/Z0'
3301 proc(15)='f + fbar -> g + gamma*/Z0'
3302 proc(19)='f + fbar -> gamma + gamma*/Z0'
3303 proc(30)='f + g -> f + gamma*/Z0'
3304 proc(35)='f + gamma -> f + gamma*/Z0'
3305 ENDIF
3306
3307C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3308 IF(mstp(44).EQ.1) THEN
3309 proc(141)='f + fbar -> gamma*'
3310 ELSEIF(mstp(44).EQ.2) THEN
3311 proc(141)='f + fbar -> Z0'
3312 ELSEIF(mstp(44).EQ.3) THEN
3313 proc(141)='f + fbar -> Z''0'
3314 ELSEIF(mstp(44).EQ.4) THEN
3315 proc(141)='f + fbar -> gamma*/Z0'
3316 ELSEIF(mstp(44).EQ.5) THEN
3317 proc(141)='f + fbar -> gamma*/Z''0'
3318 ELSEIF(mstp(44).EQ.6) THEN
3319 proc(141)='f + fbar -> Z0/Z''0'
3320 ELSEIF(mstp(44).EQ.7) THEN
3321 proc(141)='f + fbar -> gamma*/Z0/Z''0'
3322 ENDIF
3323
3324C...Special cases in treatment of WW -> WW: redefine process name.
3325 IF(mstp(45).EQ.1) THEN
3326 proc(77)='W+ + W+ -> W+ + W+'
3327 ELSEIF(mstp(45).EQ.2) THEN
3328 proc(77)='W+ + W- -> W+ + W-'
3329 ELSEIF(mstp(45).EQ.3) THEN
3330 proc(77)='W+/- + W+/- -> W+/- + W+/-'
3331 ENDIF
3332
3333C...Format for error information.
3334 5000 FORMAT(1x,'Error: unphysical input tan^2(beta) and m_H ',
3335 &'combination'/1x,'Execution stopped!')
3336
3337 RETURN
3338 END
3339
3340C*********************************************************************
3341
3342C...PYINBM
3343C...Identifies the two incoming particles and the choice of frame.
3344
3345 SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)
3346
3347C...Double precision and integer declarations.
3348 IMPLICIT DOUBLE PRECISION(a-h, o-z)
3349 IMPLICIT INTEGER(I-N)
3350 INTEGER PYK,PYCHGE,PYCOMP
3351C...Commonblocks.
3352 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3353 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3354 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3355 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3356 common/pypars/mstp(200),parp(200),msti(200),pari(200)
3357 common/pyint1/mint(400),vint(400)
3358 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
3359C...Local arrays, character variables and data.
3360 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
3361 &CHIDNT(3)*12,CHTEMP*12,CHCDE(35)*12,CHINIT*76
3362 dimension len(3),kcde(35),pm(2)
3363 DATA chalp/'abcdefghijklmnopqrstuvwxyz',
3364 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3365 DATA chcde/ 'e- ','e+ ','nu_e ',
3366 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
3367 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
3368 &'nu_taubar ','pi+ ','pi- ','n0 ',
3369 &'nbar0 ','p+ ','pbar- ','gamma ',
3370 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
3371 &'xi- ','xi0 ','omega- ','pi0 ',
3372 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
3373 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ '/
3374 DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3375 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3376 &3312,3322,3334,111,28,29,6*22/
3377
3378C...Store initial energy. Default frame.
3379 vint(290)=win
3380 mint(111)=0
3381
3382C...Convert character variables to lowercase and find their length.
3383 chcom(1)=chfram
3384 chcom(2)=chbeam
3385 chcom(3)=chtarg
3386 DO 130 i=1,3
3387 len(i)=12
3388 DO 110 ll=12,1,-1
3389 IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1
3390 DO 100 la=1,26
3391 IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=
3392 & chalp(1)(la:la)
3393 100 CONTINUE
3394 110 CONTINUE
3395 chidnt(i)=chcom(i)
3396
3397C...Fix up bar, underscore and charge in particle name (if needed).
3398 DO 120 ll=1,10
3399 IF(chidnt(i)(ll:ll).EQ.'~') THEN
3400 chtemp=chidnt(i)
3401 chidnt(i)=chtemp(1:ll-1)//'bar'//chtemp(ll+1:10)//' '
3402 ENDIF
3403 120 CONTINUE
3404 IF(chidnt(i)(1:2).EQ.'nu'.AND.chidnt(i)(3:3).NE.'_') THEN
3405 chtemp=chidnt(i)
3406 chidnt(i)='nu_'//chtemp(3:7)
3407 ELSEIF(chidnt(i)(1:2).EQ.'n ') THEN
3408 chidnt(i)(1:3)='n0 '
3409 ELSEIF(chidnt(i)(1:4).EQ.'nbar') THEN
3410 chidnt(i)(1:5)='nbar0'
3411 ELSEIF(chidnt(i)(1:2).EQ.'p ') THEN
3412 chidnt(i)(1:3)='p+ '
3413 ELSEIF(chidnt(i)(1:4).EQ.'pbar'.OR.
3414 & chidnt(i)(1:2).EQ.'p-') THEN
3415 chidnt(i)(1:5)='pbar-'
3416 ELSEIF(chidnt(i)(1:6).EQ.'lambda') THEN
3417 chidnt(i)(7:7)='0'
3418 ELSEIF(chidnt(i)(1:3).EQ.'reg') THEN
3419 chidnt(i)(1:7)='reggeon'
3420 ELSEIF(chidnt(i)(1:3).EQ.'pom') THEN
3421 chidnt(i)(1:7)='pomeron'
3422 ENDIF
3423 130 CONTINUE
3424
3425C...Identify free initialization.
3426 IF(chcom(1)(1:2).EQ.'no') THEN
3427 mint(65)=1
3428 RETURN
3429 ENDIF
3430
3431C...Identify incoming beam and target particles.
3432 DO 160 i=1,2
3433 DO 140 j=1,35
3434 IF(chidnt(i+1).EQ.chcde(j)) mint(10+i)=kcde(j)
3435 140 CONTINUE
3436 pm(i)=pymass(mint(10+i))
3437 vint(2+i)=pm(i)
3438 mint(140+i)=0
3439 IF(mint(10+i).EQ.22.AND.chidnt(i+1)(6:6).EQ.'/') THEN
3440 chtemp=chidnt(i+1)(7:12)//' '
3441 DO 150 j=1,12
3442 IF(chtemp.EQ.chcde(j)) mint(140+i)=kcde(j)
3443 150 CONTINUE
3444 pm(i)=pymass(mint(140+i))
3445 vint(302+i)=pm(i)
3446 ENDIF
3447 160 CONTINUE
3448 IF(mint(11).EQ.0) WRITE(mstu(11),5000) chbeam(1:len(2))
3449 IF(mint(12).EQ.0) WRITE(mstu(11),5100) chtarg(1:len(3))
3450 IF(mint(11).EQ.0.OR.mint(12).EQ.0) stop
3451
3452C...Identify choice of frame and input energies.
3453 chinit=' '
3454
3455C...Events defined in the CM frame.
3456 IF(chcom(1)(1:2).EQ.'cm') THEN
3457 mint(111)=1
3458 s=win**2
3459 IF(mstp(122).GE.1) THEN
3460 IF(chcom(2)(1:1).NE.'e') THEN
3461 loffs=(31-(len(2)+len(3)))/2
3462 chinit(loffs+1:76)='PYTHIA will be initialized for a '//
3463 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3464 & ' collider'//' '
3465 ELSE
3466 loffs=(30-(len(2)+len(3)))/2
3467 chinit(loffs+1:76)='PYTHIA will be initialized for an '//
3468 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3469 & ' collider'//' '
3470 ENDIF
3471 WRITE(mstu(11),5200) chinit
3472 WRITE(mstu(11),5300) win
3473 ENDIF
3474
3475C...Events defined in fixed target frame.
3476 ELSEIF(chcom(1)(1:3).EQ.'fix') THEN
3477 mint(111)=2
3478 s=pm(1)**2+pm(2)**2+2d0*pm(2)*sqrt(pm(1)**2+win**2)
3479 IF(mstp(122).GE.1) THEN
3480 loffs=(29-(len(2)+len(3)))/2
3481 chinit(loffs+1:76)='PYTHIA will be initialized for '//
3482 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3483 & ' fixed target'//' '
3484 WRITE(mstu(11),5200) chinit
3485 WRITE(mstu(11),5400) win
3486 WRITE(mstu(11),5500) sqrt(s)
3487 ENDIF
3488
3489C...Frame defined by user three-vectors.
3490 ELSEIF(chcom(1)(1:3).EQ.'use') THEN
3491 mint(111)=3
3492 p(1,5)=pm(1)
3493 p(2,5)=pm(2)
3494 p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
3495 p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
3496 s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
3497 & (p(1,3)+p(2,3))**2
3498 IF(mstp(122).GE.1) THEN
3499 loffs=(22-(len(2)+len(3)))/2
3500 chinit(loffs+1:76)='PYTHIA will be initialized for '//
3501 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3502 & ' user configuration'//' '
3503 WRITE(mstu(11),5200) chinit
3504 WRITE(mstu(11),5600)
3505 WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
3506 WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
3507 WRITE(mstu(11),5500) sqrt(max(0d0,s))
3508 ENDIF
3509
3510C...Frame defined by user four-vectors.
3511 ELSEIF(chcom(1)(1:4).EQ.'four') THEN
3512 mint(111)=4
3513 pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
3514 p(1,5)=sign(sqrt(abs(pms1)),pms1)
3515 pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
3516 p(2,5)=sign(sqrt(abs(pms2)),pms2)
3517 s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
3518 & (p(1,3)+p(2,3))**2
3519 IF(mstp(122).GE.1) THEN
3520 loffs=(22-(len(2)+len(3)))/2
3521 chinit(loffs+1:76)='PYTHIA will be initialized for '//
3522 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3523 & ' user configuration'//' '
3524 WRITE(mstu(11),5200) chinit
3525 WRITE(mstu(11),5600)
3526 WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
3527 WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
3528 WRITE(mstu(11),5500) sqrt(max(0d0,s))
3529 ENDIF
3530
3531C...Frame defined by user five-vectors.
3532 ELSEIF(chcom(1)(1:4).EQ.'five') THEN
3533 mint(111)=5
3534 s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
3535 & (p(1,3)+p(2,3))**2
3536 IF(mstp(122).GE.1) THEN
3537 loffs=(22-(len(2)+len(3)))/2
3538 chinit(loffs+1:76)='PYTHIA will be initialized for '//
3539 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3540 & ' user configuration'//' '
3541 WRITE(mstu(11),5200) chinit
3542 WRITE(mstu(11),5600)
3543 WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
3544 WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
3545 WRITE(mstu(11),5500) sqrt(max(0d0,s))
3546 ENDIF
3547
3548C...Unknown frame. Error for too low CM energy.
3549 ELSE
3550 WRITE(mstu(11),5800) chfram(1:len(1))
3551 stop
3552 ENDIF
3553 IF(s.LT.parp(2)**2) THEN
3554 WRITE(mstu(11),5900) sqrt(s)
3555 stop
3556 ENDIF
3557
3558C...Formats for initialization and error information.
3559 5000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''D0'/
3560 &1x,'Execution stopped!')
3561 5100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''D0'/
3562 &1x,'Execution stopped!')
3563 5200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')
3564 5300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',
3565 &19x,'I'/1x,'I',76x,'I'/1x,78('='))
3566 5400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')
3567 5500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,
3568 &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))
3569 5600 FORMAT(1x,'I',76x,'I'/1x,'I',18x,'px (GeV/c)',3x,'py (GeV/c)',3x,
3570 &'pz (GeV/c)',6x,'E (GeV)',9x,'I')
3571 5700 FORMAT(1x,'I',8x,a8,4(2x,f10.3,1x),8x,'I')
3572 5800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''D0'/
3573 &1x,'Execution stopped!')
3574 5900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',
3575 &'generation.'/1x,'Execution stopped!')
3576
3577 RETURN
3578 END
3579
3580C*********************************************************************
3581
3582C...PYINKI
3583C...Sets up kinematics, including rotations and boosts to/from CM frame.
3584
3585 SUBROUTINE pyinki(MODKI)
3586
3587C...Double precision and integer declarations.
3588 IMPLICIT DOUBLE PRECISION(a-h, o-z)
3589 IMPLICIT INTEGER(I-N)
3590 INTEGER PYK,PYCHGE,PYCOMP
3591C...Commonblocks.
3592 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3593 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3594 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3595 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3596 common/pypars/mstp(200),parp(200),msti(200),pari(200)
3597 common/pyint1/mint(400),vint(400)
3598 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
3599
3600C...Set initial flavour state.
3601 n=2
3602 DO 100 i=1,2
3603 k(i,1)=1
3604 k(i,2)=mint(10+i)
3605 IF(mint(140+i).NE.0) k(i,2)=mint(140+i)
3606 100 CONTINUE
3607
3608C...Reset boost. Do kinematics for various cases.
3609 DO 110 j=6,10
3610 vint(j)=0d0
3611 110 CONTINUE
3612
3613C...Set up kinematics for events defined in CM frame.
3614 IF(mint(111).EQ.1) THEN
3615 win=vint(290)
3616 IF(modki.EQ.1) win=parp(171)*vint(290)
3617 s=win**2
3618 p(1,5)=vint(3)
3619 p(2,5)=vint(4)
3620 IF(mint(141).NE.0) p(1,5)=vint(303)
3621 IF(mint(142).NE.0) p(2,5)=vint(304)
3622 p(1,1)=0d0
3623 p(1,2)=0d0
3624 p(2,1)=0d0
3625 p(2,2)=0d0
3626 p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2d0*p(1,5)*p(2,5))**2)/
3627 & (4d0*s))
3628 p(2,3)=-p(1,3)
3629 p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
3630 p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
3631
3632C...Set up kinematics for fixed target events.
3633 ELSEIF(mint(111).EQ.2) THEN
3634 win=vint(290)
3635 IF(modki.EQ.1) win=parp(171)*vint(290)
3636 p(1,5)=vint(3)
3637 p(2,5)=vint(4)
3638 IF(mint(141).NE.0) p(1,5)=vint(303)
3639 IF(mint(142).NE.0) p(2,5)=vint(304)
3640 p(1,1)=0d0
3641 p(1,2)=0d0
3642 p(2,1)=0d0
3643 p(2,2)=0d0
3644 p(1,3)=win
3645 p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
3646 p(2,3)=0d0
3647 p(2,4)=p(2,5)
3648 s=p(1,5)**2+p(2,5)**2+2d0*p(2,4)*p(1,4)
3649 vint(10)=p(1,3)/(p(1,4)+p(2,4))
3650 CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
3651
3652C...Set up kinematics for events in user-defined frame.
3653 ELSEIF(mint(111).EQ.3) THEN
3654 p(1,5)=vint(3)
3655 p(2,5)=vint(4)
3656 IF(mint(141).NE.0) p(1,5)=vint(303)
3657 IF(mint(142).NE.0) p(2,5)=vint(304)
3658 p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
3659 p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
3660 DO 120 j=1,3
3661 vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
3662 120 CONTINUE
3663 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
3664 vint(7)=pyangl(p(1,1),p(1,2))
3665 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
3666 vint(6)=pyangl(p(1,3),p(1,1))
3667 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
3668 s=p(1,5)**2+p(2,5)**2+2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
3669
3670C...Set up kinematics for events with user-defined four-vectors.
3671 ELSEIF(mint(111).EQ.4) THEN
3672 pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
3673 p(1,5)=sign(sqrt(abs(pms1)),pms1)
3674 pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
3675 p(2,5)=sign(sqrt(abs(pms2)),pms2)
3676 DO 130 j=1,3
3677 vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
3678 130 CONTINUE
3679 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
3680 vint(7)=pyangl(p(1,1),p(1,2))
3681 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
3682 vint(6)=pyangl(p(1,3),p(1,1))
3683 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
3684 s=(p(1,4)+p(2,4))**2
3685
3686C...Set up kinematics for events with user-defined five-vectors.
3687 ELSEIF(mint(111).EQ.5) THEN
3688 DO 140 j=1,3
3689 vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
3690 140 CONTINUE
3691 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
3692 vint(7)=pyangl(p(1,1),p(1,2))
3693 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
3694 vint(6)=pyangl(p(1,3),p(1,1))
3695 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
3696 s=(p(1,4)+p(2,4))**2
3697 ENDIF
3698
3699C...Return or error for too low CM energy.
3700 IF(modki.EQ.1.AND.s.LT.parp(2)**2) THEN
3701 IF(mstp(172).LE.1) THEN
3702 CALL pyerrm(23,
3703 & '(PYINKI:) too low invariant mass in this event')
3704 ELSE
3705 msti(61)=1
3706 RETURN
3707 ENDIF
3708 ENDIF
3709
3710C...Save information on incoming particles.
3711 vint(1)=sqrt(s)
3712 vint(2)=s
3713 IF(mint(111).GE.4) THEN
3714 IF(mint(141).EQ.0) THEN
3715 vint(3)=p(1,5)
3716 IF(mint(11).EQ.22.AND.p(1,5).LT.0) vint(307)=p(1,5)**2
3717 ELSE
3718 vint(303)=p(1,5)
3719 ENDIF
3720 IF(mint(142).EQ.0) THEN
3721 vint(4)=p(2,5)
3722 IF(mint(12).EQ.22.AND.p(2,5).LT.0) vint(308)=p(2,5)**2
3723 ELSE
3724 vint(304)=p(2,5)
3725 ENDIF
3726 ENDIF
3727 vint(5)=p(1,3)
3728 IF(modki.EQ.0) vint(289)=s
3729 DO 150 j=1,5
3730 v(1,j)=0d0
3731 v(2,j)=0d0
3732 vint(290+j)=p(1,j)
3733 vint(295+j)=p(2,j)
3734 150 CONTINUE
3735
3736C...Store pT cut-off and related constants to be used in generation.
3737 IF(modki.EQ.0) vint(285)=ckin(3)
3738 IF(mstp(82).LE.1) THEN
3739 ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
3740 ELSE
3741 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
3742 ENDIF
3743 vint(149)=4d0*ptmn**2/s
3744 vint(154)=ptmn
3745
3746 RETURN
3747 END
3748
3749C*********************************************************************
3750
3751C...PYINPR
3752C...Selects partonic subprocesses to be included in the simulation.
3753
3754 SUBROUTINE pyinpr
3755
3756C...Double precision and integer declarations.
3757 IMPLICIT DOUBLE PRECISION(a-h, o-z)
3758 IMPLICIT INTEGER(I-N)
3759 INTEGER PYK,PYCHGE,PYCOMP
3760C...Commonblocks.
3761 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3762 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
3763 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3764 common/pypars/mstp(200),parp(200),msti(200),pari(200)
3765 common/pyint1/mint(400),vint(400)
3766 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3767 SAVE /pydat1/,/pydat3/,/pysubs/,/pypars/,/pyint1/,/pyint2/
3768
3769C...Reset processes to be included.
3770 IF(msel.NE.0) THEN
3771 DO 100 i=1,500
3772 msub(i)=0
3773 100 CONTINUE
3774 ENDIF
3775
3776C...Set running pTmin scale.
3777 IF(mstp(82).LE.1) THEN
3778 ptmrun=parp(81)*(vint(1)/parp(89))**parp(90)
3779 ELSE
3780 ptmrun=parp(82)*(vint(1)/parp(89))**parp(90)
3781 ENDIF
3782
3783C...Begin by assuming incoming photon to enter subprocess.
3784 IF(mint(11).EQ.22) mint(15)=22
3785 IF(mint(12).EQ.22) mint(16)=22
3786
3787C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
3788 IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
3789 msub(10)=1
3790 mint(123)=mint(122)+1
3791
3792C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
3793C...allow mixture.
3794C...Here also set a few parameters otherwise normally not touched.
3795 ELSEIF(mint(121).GT.1) THEN
3796
3797C...Parton distributions dampened at small Q2; go to low energies,
3798C...alpha_s <1; no minimum pT cut-off a priori.
3799 IF(mstp(18).EQ.2) THEN
3800 mstp(57)=3
3801 parp(2)=2d0
3802 paru(115)=1d0
3803 ckin(5)=0.2d0
3804 ckin(6)=0.2d0
3805 ENDIF
3806
3807C...Define pT cut-off parameters and whether run involves low-pT.
3808 ptmvmd=ptmrun
3809 vint(154)=ptmvmd
3810 ptmdir=ptmvmd
3811 IF(mstp(18).EQ.2) ptmdir=parp(15)
3812 ptmano=ptmvmd
3813 IF(mstp(15).EQ.5) ptmano=0.60d0+
3814 & 0.125d0*log(1d0+0.10d0*vint(1))**2
3815 iptl=1
3816 IF(vint(285).GT.max(ptmvmd,ptmdir,ptmano)) iptl=0
3817 IF(msel.EQ.2) iptl=1
3818
3819C...Set up for p/gamma * gamma; real or virtual photons.
3820 IF(mint(121).EQ.3.OR.mint(121).EQ.6.OR.(mint(121).EQ.4.AND.
3821 & mstp(14).EQ.30)) THEN
3822
3823C...Set up for p/VMD * VMD.
3824 IF(mint(122).EQ.1) THEN
3825 mint(123)=2
3826 msub(11)=1
3827 msub(12)=1
3828 msub(13)=1
3829 msub(28)=1
3830 msub(53)=1
3831 msub(68)=1
3832 IF(iptl.EQ.1) msub(95)=1
3833 IF(msel.EQ.2) THEN
3834 msub(91)=1
3835 msub(92)=1
3836 msub(93)=1
3837 msub(94)=1
3838 ENDIF
3839 IF(iptl.EQ.1) ckin(3)=0d0
3840
3841C...Set up for p/VMD * direct gamma.
3842 ELSEIF(mint(122).EQ.2) THEN
3843 mint(123)=0
3844 IF(mint(121).EQ.6) mint(123)=5
3845 msub(131)=1
3846 msub(132)=1
3847 msub(135)=1
3848 msub(136)=1
3849 IF(iptl.EQ.1) ckin(3)=ptmdir
3850
3851C...Set up for p/VMD * anomalous gamma.
3852 ELSEIF(mint(122).EQ.3) THEN
3853 mint(123)=3
3854 IF(mint(121).EQ.6) mint(123)=7
3855 msub(11)=1
3856 msub(12)=1
3857 msub(13)=1
3858 msub(28)=1
3859 msub(53)=1
3860 msub(68)=1
3861 IF(iptl.EQ.1) msub(95)=1
3862 IF(msel.EQ.2) THEN
3863 msub(91)=1
3864 msub(92)=1
3865 msub(93)=1
3866 msub(94)=1
3867 ENDIF
3868 IF(iptl.EQ.1) ckin(3)=0d0
3869
3870C...Set up for DIS * p.
3871 ELSEIF(mint(122).EQ.4.AND.(iabs(mint(11)).GE.28.OR.
3872 & iabs(mint(12)).GE.28)) THEN
3873 mint(123)=8
3874 IF(iptl.EQ.1) msub(99)=1
3875
3876C...Set up for direct * direct gamma (switch off leptons).
3877 ELSEIF(mint(122).EQ.4) THEN
3878 mint(123)=0
3879 msub(137)=1
3880 msub(138)=1
3881 msub(139)=1
3882 msub(140)=1
3883 DO 110 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
3884 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
3885 110 CONTINUE
3886 IF(iptl.EQ.1) ckin(3)=ptmdir
3887
3888C...Set up for direct * anomalous gamma.
3889 ELSEIF(mint(122).EQ.5) THEN
3890 mint(123)=6
3891 msub(131)=1
3892 msub(132)=1
3893 msub(135)=1
3894 msub(136)=1
3895 IF(iptl.EQ.1) ckin(3)=ptmano
3896
3897C...Set up for anomalous * anomalous gamma.
3898 ELSEIF(mint(122).EQ.6) THEN
3899 mint(123)=3
3900 msub(11)=1
3901 msub(12)=1
3902 msub(13)=1
3903 msub(28)=1
3904 msub(53)=1
3905 msub(68)=1
3906 IF(iptl.EQ.1) msub(95)=1
3907 IF(msel.EQ.2) THEN
3908 msub(91)=1
3909 msub(92)=1
3910 msub(93)=1
3911 msub(94)=1
3912 ENDIF
3913 IF(iptl.EQ.1) ckin(3)=0d0
3914 ENDIF
3915
3916C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
3917 ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
3918
3919C...Set up for direct * direct gamma (switch off leptons).
3920 IF(mint(122).EQ.1) THEN
3921 mint(123)=0
3922 msub(137)=1
3923 msub(138)=1
3924 msub(139)=1
3925 msub(140)=1
3926 DO 120 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
3927 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
3928 120 CONTINUE
3929 IF(iptl.EQ.1) ckin(3)=ptmdir
3930
3931C...Set up for direct * VMD and VMD * direct gamma.
3932 ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.4) THEN
3933 mint(123)=5
3934 msub(131)=1
3935 msub(132)=1
3936 msub(135)=1
3937 msub(136)=1
3938 IF(iptl.EQ.1) ckin(3)=ptmdir
3939
3940C...Set up for direct * anomalous and anomalous * direct gamma.
3941 ELSEIF(mint(122).EQ.3.OR.mint(122).EQ.7) THEN
3942 mint(123)=6
3943 msub(131)=1
3944 msub(132)=1
3945 msub(135)=1
3946 msub(136)=1
3947 IF(iptl.EQ.1) ckin(3)=ptmano
3948
3949C...Set up for VMD*VMD.
3950 ELSEIF(mint(122).EQ.5) THEN
3951 mint(123)=2
3952 msub(11)=1
3953 msub(12)=1
3954 msub(13)=1
3955 msub(28)=1
3956 msub(53)=1
3957 msub(68)=1
3958 IF(iptl.EQ.1) msub(95)=1
3959 IF(msel.EQ.2) THEN
3960 msub(91)=1
3961 msub(92)=1
3962 msub(93)=1
3963 msub(94)=1
3964 ENDIF
3965 IF(iptl.EQ.1) ckin(3)=0d0
3966
3967C...Set up for VMD * anomalous and anomalous * VMD gamma.
3968 ELSEIF(mint(122).EQ.6.OR.mint(122).EQ.8) THEN
3969 mint(123)=7
3970 msub(11)=1
3971 msub(12)=1
3972 msub(13)=1
3973 msub(28)=1
3974 msub(53)=1
3975 msub(68)=1
3976 IF(iptl.EQ.1) msub(95)=1
3977 IF(msel.EQ.2) THEN
3978 msub(91)=1
3979 msub(92)=1
3980 msub(93)=1
3981 msub(94)=1
3982 ENDIF
3983 IF(iptl.EQ.1) ckin(3)=0d0
3984
3985C...Set up for anomalous * anomalous gamma.
3986 ELSEIF(mint(122).EQ.9) THEN
3987 mint(123)=3
3988 msub(11)=1
3989 msub(12)=1
3990 msub(13)=1
3991 msub(28)=1
3992 msub(53)=1
3993 msub(68)=1
3994 IF(iptl.EQ.1) msub(95)=1
3995 IF(msel.EQ.2) THEN
3996 msub(91)=1
3997 msub(92)=1
3998 msub(93)=1
3999 msub(94)=1
4000 ENDIF
4001 IF(iptl.EQ.1) ckin(3)=0d0
4002
4003C...Set up for DIS * VMD and VMD * DIS gamma.
4004 ELSEIF(mint(122).EQ.10.OR.mint(122).EQ.12) THEN
4005 mint(123)=8
4006 IF(iptl.EQ.1) msub(99)=1
4007
4008C...Set up for DIS * anomalous and anomalous * DIS gamma.
4009 ELSEIF(mint(122).EQ.11.OR.mint(122).EQ.13) THEN
4010 mint(123)=9
4011 IF(iptl.EQ.1) msub(99)=1
4012 ENDIF
4013
4014C...Set up for gamma* * p; virtual photons = dir, res.
4015 ELSEIF(mint(121).EQ.2) THEN
4016
4017C...Set up for direct * p.
4018 IF(mint(122).EQ.1) THEN
4019 mint(123)=0
4020 msub(131)=1
4021 msub(132)=1
4022 msub(135)=1
4023 msub(136)=1
4024 IF(iptl.EQ.1) ckin(3)=ptmdir
4025
4026C...Set up for resolved * p.
4027 ELSEIF(mint(122).EQ.2) THEN
4028 mint(123)=1
4029 msub(11)=1
4030 msub(12)=1
4031 msub(13)=1
4032 msub(28)=1
4033 msub(53)=1
4034 msub(68)=1
4035 IF(iptl.EQ.1) msub(95)=1
4036 IF(msel.EQ.2) THEN
4037 msub(91)=1
4038 msub(92)=1
4039 msub(93)=1
4040 msub(94)=1
4041 ENDIF
4042 IF(iptl.EQ.1) ckin(3)=0d0
4043 ENDIF
4044
4045C...Set up for gamma* * gamma*; virtual photons = dir, res.
4046 ELSEIF(mint(121).EQ.4) THEN
4047
4048C...Set up for direct * direct gamma (switch off leptons).
4049 IF(mint(122).EQ.1) THEN
4050 mint(123)=0
4051 msub(137)=1
4052 msub(138)=1
4053 msub(139)=1
4054 msub(140)=1
4055 DO 130 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
4056 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
4057 130 CONTINUE
4058 IF(iptl.EQ.1) ckin(3)=ptmdir
4059
4060C...Set up for direct * resolved and resolved * direct gamma.
4061 ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.3) THEN
4062 mint(123)=5
4063 msub(131)=1
4064 msub(132)=1
4065 msub(135)=1
4066 msub(136)=1
4067 IF(iptl.EQ.1) ckin(3)=ptmdir
4068
4069C...Set up for resolved * resolved gamma.
4070 ELSEIF(mint(122).EQ.4) THEN
4071 mint(123)=2
4072 msub(11)=1
4073 msub(12)=1
4074 msub(13)=1
4075 msub(28)=1
4076 msub(53)=1
4077 msub(68)=1
4078 IF(iptl.EQ.1) msub(95)=1
4079 IF(msel.EQ.2) THEN
4080 msub(91)=1
4081 msub(92)=1
4082 msub(93)=1
4083 msub(94)=1
4084 ENDIF
4085 IF(iptl.EQ.1) ckin(3)=0d0
4086 ENDIF
4087
4088C...End of special set up for gamma-p and gamma-gamma.
4089 ENDIF
4090 ckin(1)=2d0*ckin(3)
4091 ENDIF
4092
4093C...Flavour information for individual beams.
4094 DO 140 i=1,2
4095 mint(40+i)=1
4096 IF(mint(123).GE.1.AND.mint(10+i).EQ.22) mint(40+i)=2
4097 IF(iabs(mint(10+i)).GT.100) mint(40+i)=2
4098 IF(mint(10+i).EQ.28.OR.mint(10+i).EQ.29) mint(40+i)=2
4099 mint(44+i)=mint(40+i)
4100 IF(mstp(11).GE.1.AND.(iabs(mint(10+i)).EQ.11.OR.
4101 & iabs(mint(10+i)).EQ.13.OR.iabs(mint(10+i)).EQ.15)) mint(44+i)=3
4102 140 CONTINUE
4103
4104C...If two real gammas, whereof one direct, pick the first.
4105C...For two virtual photons, keep requested order.
4106 IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
4107 IF(mstp(14).LE.10.AND.mint(123).GE.4.AND.mint(123).LE.6) THEN
4108 mint(41)=1
4109 mint(45)=1
4110 ELSEIF(mstp(14).EQ.12.OR.mstp(14).EQ.13.OR.mstp(14).EQ.22.OR.
4111 & mstp(14).EQ.26.OR.mstp(14).EQ.27) THEN
4112 mint(41)=1
4113 mint(45)=1
4114 ELSEIF(mstp(14).EQ.14.OR.mstp(14).EQ.17.OR.mstp(14).EQ.23.OR.
4115 & mstp(14).EQ.28.OR.mstp(14).EQ.29) THEN
4116 mint(42)=1
4117 mint(46)=1
4118 ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.2
4119 & .OR.mint(122).EQ.3.OR.mint(122).EQ.10.OR.mint(122).EQ.11)) THEN
4120 mint(41)=1
4121 mint(45)=1
4122 ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.4
4123 & .OR.mint(122).EQ.7.OR.mint(122).EQ.12.OR.mint(122).EQ.13)) THEN
4124 mint(42)=1
4125 mint(46)=1
4126 ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.2) THEN
4127 mint(41)=1
4128 mint(45)=1
4129 ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.3) THEN
4130 mint(42)=1
4131 mint(46)=1
4132 ENDIF
4133 ELSEIF(mint(11).EQ.22.OR.mint(12).EQ.22) THEN
4134 IF(mstp(14).EQ.26.OR.mstp(14).EQ.28.OR.mint(122).EQ.4) THEN
4135 IF(mint(11).EQ.22) THEN
4136 mint(41)=1
4137 mint(45)=1
4138 ELSE
4139 mint(42)=1
4140 mint(46)=1
4141 ENDIF
4142 ENDIF
4143 IF(mint(123).GE.4.AND.mint(123).LE.7) CALL pyerrm(26,
4144 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4145 ENDIF
4146
4147C...Flavour information on combination of incoming particles.
4148 mint(43)=2*mint(41)+mint(42)-2
4149 mint(44)=mint(43)
4150 IF(mint(123).LE.0) THEN
4151 IF(mint(11).EQ.22) mint(43)=mint(43)+2
4152 IF(mint(12).EQ.22) mint(43)=mint(43)+1
4153 ELSEIF(mint(123).LE.3) THEN
4154 IF(mint(11).EQ.22) mint(44)=mint(44)-2
4155 IF(mint(12).EQ.22) mint(44)=mint(44)-1
4156 ELSEIF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
4157 mint(43)=4
4158 mint(44)=1
4159 ENDIF
4160 mint(47)=2*min(2,mint(45))+min(2,mint(46))-2
4161 IF(min(mint(45),mint(46)).EQ.3) mint(47)=5
4162 IF(mint(45).EQ.1.AND.mint(46).EQ.3) mint(47)=6
4163 IF(mint(45).EQ.3.AND.mint(46).EQ.1) mint(47)=7
4164 mint(50)=0
4165 IF(mint(41).EQ.2.AND.mint(42).EQ.2) mint(50)=1
4166 mint(107)=0
4167 mint(108)=0
4168 IF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
4169 IF((mint(122).GE.4.AND.mint(122).LE.6).OR.mint(122).EQ.12)
4170 & mint(107)=2
4171 IF((mint(122).GE.7.AND.mint(122).LE.9).OR.mint(122).EQ.13)
4172 & mint(107)=3
4173 IF(mint(122).EQ.10.OR.mint(122).EQ.11) mint(107)=4
4174 IF(mint(122).EQ.2.OR.mint(122).EQ.5.OR.mint(122).EQ.8.OR.
4175 & mint(122).EQ.10) mint(108)=2
4176 IF(mint(122).EQ.3.OR.mint(122).EQ.6.OR.mint(122).EQ.9.OR.
4177 & mint(122).EQ.11) mint(108)=3
4178 IF(mint(122).EQ.12.OR.mint(122).EQ.13) mint(108)=4
4179 ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.25) THEN
4180 IF(mint(122).GE.3) mint(107)=1
4181 IF(mint(122).EQ.2.OR.mint(122).EQ.4) mint(108)=1
4182 ELSEIF(mint(121).EQ.2) THEN
4183 IF(mint(122).EQ.2.AND.mint(11).EQ.22) mint(107)=1
4184 IF(mint(122).EQ.2.AND.mint(12).EQ.22) mint(108)=1
4185 ELSE
4186 IF(mint(11).EQ.22) THEN
4187 mint(107)=mint(123)
4188 IF(mint(123).GE.4) mint(107)=0
4189 IF(mint(123).EQ.7) mint(107)=2
4190 IF(mstp(14).EQ.26.OR.mstp(14).EQ.27) mint(107)=4
4191 IF(mstp(14).EQ.28) mint(107)=2
4192 IF(mstp(14).EQ.29) mint(107)=3
4193 IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
4194 & mint(107)=4
4195 ENDIF
4196 IF(mint(12).EQ.22) THEN
4197 mint(108)=mint(123)
4198 IF(mint(123).GE.4) mint(108)=mint(123)-3
4199 IF(mint(123).EQ.7) mint(108)=3
4200 IF(mstp(14).EQ.26) mint(108)=2
4201 IF(mstp(14).EQ.27) mint(108)=3
4202 IF(mstp(14).EQ.28.OR.mstp(14).EQ.29) mint(108)=4
4203 IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
4204 & mint(108)=4
4205 ENDIF
4206 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.(mstp(14).EQ.14.OR.
4207 & mstp(14).EQ.17.OR.mstp(14).EQ.18.OR.mstp(14).EQ.23)) THEN
4208 minttp=mint(107)
4209 mint(107)=mint(108)
4210 mint(108)=minttp
4211 ENDIF
4212 ENDIF
4213 IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
4214 IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
4215
4216C...Select default processes according to incoming beams
4217C...(already done for gamma-p and gamma-gamma with
4218C...MSTP(14) = 10, 20, 25 or 30).
4219 IF(mint(121).GT.1) THEN
4220 ELSEIF(msel.EQ.1.OR.msel.EQ.2) THEN
4221
4222 IF(mint(43).EQ.1) THEN
4223C...Lepton + lepton -> gamma/Z0 or W.
4224 IF(mint(11)+mint(12).EQ.0) msub(1)=1
4225 IF(mint(11)+mint(12).NE.0) msub(2)=1
4226
4227 ELSEIF(mint(43).LE.3.AND.mint(123).EQ.0.AND.
4228 & (mint(11).EQ.22.OR.mint(12).EQ.22)) THEN
4229C...Unresolved photon + lepton: Compton scattering.
4230 msub(133)=1
4231 msub(134)=1
4232
4233 ELSEIF((mint(123).EQ.8.OR.mint(123).EQ.9).AND.(mint(11).EQ.22
4234 & .OR.mint(12).EQ.22)) THEN
4235C...DIS as pure gamma* + f -> f process.
4236 msub(99)=1
4237
4238 ELSEIF(mint(43).LE.3) THEN
4239C...Lepton + hadron: deep inelastic scattering.
4240 msub(10)=1
4241
4242 ELSEIF(mint(123).EQ.0.AND.mint(11).EQ.22.AND.
4243 & mint(12).EQ.22) THEN
4244C...Two unresolved photons: fermion pair production,
4245C...exclude lepton pairs.
4246 DO 150 isub=137,140
4247 msub(isub)=1
4248 150 CONTINUE
4249 DO 155 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
4250 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
4251 155 CONTINUE
4252 ptmdir=ptmrun
4253 IF(mstp(18).EQ.2) ptmdir=parp(15)
4254 IF(ckin(3).LT.ptmrun.OR.msel.EQ.2) ckin(3)=ptmdir
4255 ckin(1)=max(ckin(1),2d0*ckin(3))
4256
4257 ELSEIF((mint(123).EQ.0.AND.(mint(11).EQ.22.OR.mint(12).EQ.22))
4258 & .OR.(mint(123).GE.4.AND.mint(123).LE.6.AND.mint(11).EQ.22.AND.
4259 & mint(12).EQ.22)) THEN
4260C...Unresolved photon + hadron: photon-parton scattering.
4261 DO 160 isub=131,136
4262 msub(isub)=1
4263 160 CONTINUE
4264
4265 ELSEIF(msel.EQ.1) THEN
4266C...High-pT QCD processes:
4267 msub(11)=1
4268 msub(12)=1
4269 msub(13)=1
4270 msub(28)=1
4271 msub(53)=1
4272 msub(68)=1
4273 ptmn=ptmrun
4274 vint(154)=ptmn
4275 IF(ckin(3).LT.ptmn) msub(95)=1
4276 IF(msub(95).EQ.1.AND.mint(50).EQ.0) msub(95)=0
4277
4278 ELSE
4279C...All QCD processes:
4280 msub(11)=1
4281 msub(12)=1
4282 msub(13)=1
4283 msub(28)=1
4284 msub(53)=1
4285 msub(68)=1
4286 msub(91)=1
4287 msub(92)=1
4288 msub(93)=1
4289 msub(94)=1
4290 msub(95)=1
4291 ENDIF
4292
4293 ELSEIF(msel.GE.4.AND.msel.LE.8) THEN
4294C...Heavy quark production.
4295 msub(81)=1
4296 msub(82)=1
4297 msub(84)=1
4298 DO 170 j=1,min(8,mdcy(21,3))
4299 mdme(mdcy(21,2)+j-1,1)=0
4300 170 CONTINUE
4301 mdme(mdcy(21,2)+msel-1,1)=1
4302 msub(85)=1
4303 DO 180 j=1,min(12,mdcy(22,3))
4304 mdme(mdcy(22,2)+j-1,1)=0
4305 180 CONTINUE
4306 mdme(mdcy(22,2)+msel-1,1)=1
4307
4308 ELSEIF(msel.EQ.10) THEN
4309C...Prompt photon production:
4310 msub(14)=1
4311 msub(18)=1
4312 msub(29)=1
4313
4314 ELSEIF(msel.EQ.11) THEN
4315C...Z0/gamma* production:
4316 msub(1)=1
4317
4318 ELSEIF(msel.EQ.12) THEN
4319C...W+/- production:
4320 msub(2)=1
4321
4322 ELSEIF(msel.EQ.13) THEN
4323C...Z0 + jet:
4324 msub(15)=1
4325 msub(30)=1
4326
4327 ELSEIF(msel.EQ.14) THEN
4328C...W+/- + jet:
4329 msub(16)=1
4330 msub(31)=1
4331
4332 ELSEIF(msel.EQ.15) THEN
4333C...Z0 & W+/- pair production:
4334 msub(19)=1
4335 msub(20)=1
4336 msub(22)=1
4337 msub(23)=1
4338 msub(25)=1
4339
4340 ELSEIF(msel.EQ.16) THEN
4341C...h0 production:
4342 msub(3)=1
4343 msub(102)=1
4344 msub(103)=1
4345 msub(123)=1
4346 msub(124)=1
4347
4348 ELSEIF(msel.EQ.17) THEN
4349C...h0 & Z0 or W+/- pair production:
4350 msub(24)=1
4351 msub(26)=1
4352
4353 ELSEIF(msel.EQ.18) THEN
4354C...h0 production; interesting processes in e+e-.
4355 msub(24)=1
4356 msub(103)=1
4357 msub(123)=1
4358 msub(124)=1
4359
4360 ELSEIF(msel.EQ.19) THEN
4361C...h0, H0 and A0 production; interesting processes in e+e-.
4362 msub(24)=1
4363 msub(103)=1
4364 msub(123)=1
4365 msub(124)=1
4366 msub(153)=1
4367 msub(171)=1
4368 msub(173)=1
4369 msub(174)=1
4370 msub(158)=1
4371 msub(176)=1
4372 msub(178)=1
4373 msub(179)=1
4374
4375 ELSEIF(msel.EQ.21) THEN
4376C...Z'0 production:
4377 msub(141)=1
4378
4379 ELSEIF(msel.EQ.22) THEN
4380C...W'+/- production:
4381 msub(142)=1
4382
4383 ELSEIF(msel.EQ.23) THEN
4384C...H+/- production:
4385 msub(143)=1
4386
4387 ELSEIF(msel.EQ.24) THEN
4388C...R production:
4389 msub(144)=1
4390
4391 ELSEIF(msel.EQ.25) THEN
4392C...LQ (leptoquark) production.
4393 msub(145)=1
4394 msub(162)=1
4395 msub(163)=1
4396 msub(164)=1
4397
4398 ELSEIF(msel.GE.35.AND.msel.LE.38) THEN
4399C...Production of one heavy quark (W exchange):
4400 msub(83)=1
4401 DO 190 j=1,min(8,mdcy(21,3))
4402 mdme(mdcy(21,2)+j-1,1)=0
4403 190 CONTINUE
4404 mdme(mdcy(21,2)+msel-31,1)=1
4405
4406CMRENNA++Define SUSY alternatives.
4407 ELSEIF(msel.EQ.39) THEN
4408C...Turn on all SUSY processes.
4409 IF(mint(43).EQ.4) THEN
4410C...Hadron-hadron processes.
4411 DO 200 i=201,301
4412 IF(iset(i).GE.0) msub(i)=1
4413 200 CONTINUE
4414 ELSEIF(mint(43).EQ.1) THEN
4415C...Lepton-lepton processes: QED production of squarks.
4416 DO 210 i=201,214
4417 msub(i)=1
4418 210 CONTINUE
4419 msub(210)=0
4420 msub(211)=0
4421 msub(212)=0
4422 DO 220 i=216,228
4423 msub(i)=1
4424 220 CONTINUE
4425 DO 230 i=261,263
4426 msub(i)=1
4427 230 CONTINUE
4428 msub(277)=1
4429 msub(278)=1
4430 ENDIF
4431
4432 ELSEIF(msel.EQ.40) THEN
4433C...Gluinos and squarks.
4434 IF(mint(43).EQ.4) THEN
4435 msub(243)=1
4436 msub(244)=1
4437 msub(258)=1
4438 msub(259)=1
4439 msub(261)=1
4440 msub(262)=1
4441 msub(264)=1
4442 msub(265)=1
4443 DO 240 i=271,296
4444 msub(i)=1
4445 240 CONTINUE
4446 ELSEIF(mint(43).EQ.1) THEN
4447 msub(277)=1
4448 msub(278)=1
4449 ENDIF
4450
4451 ELSEIF(msel.EQ.41) THEN
4452C...Stop production.
4453 msub(261)=1
4454 msub(262)=1
4455 msub(263)=1
4456 IF(mint(43).EQ.4) THEN
4457 msub(264)=1
4458 msub(265)=1
4459 ENDIF
4460
4461 ELSEIF(msel.EQ.42) THEN
4462C...Slepton production.
4463 DO 250 i=201,214
4464 msub(i)=1
4465 250 CONTINUE
4466 IF(mint(43).NE.4) THEN
4467 msub(210)=0
4468 msub(211)=0
4469 msub(212)=0
4470 ENDIF
4471
4472 ELSEIF(msel.EQ.43) THEN
4473C...Neutralino/Chargino + Gluino/Squark.
4474 IF(mint(43).EQ.4) THEN
4475 DO 260 i=237,242
4476 msub(i)=1
4477 260 CONTINUE
4478 DO 270 i=246,257
4479 msub(i)=1
4480 270 CONTINUE
4481 ENDIF
4482
4483 ELSEIF(msel.EQ.44) THEN
4484C...Neutralino/Chargino pair production.
4485 IF(mint(43).EQ.4) THEN
4486 DO 280 i=216,236
4487 msub(i)=1
4488 280 CONTINUE
4489 ELSEIF(mint(43).EQ.1) THEN
4490 DO 290 i=216,228
4491 msub(i)=1
4492 290 CONTINUE
4493 ENDIF
4494
4495 ELSEIF(msel.EQ.45) THEN
4496C...Sbottom production.
4497 msub(287)=1
4498 msub(288)=1
4499 IF(mint(43).EQ.4) THEN
4500 DO 300 i=281,296
4501 msub(i)=1
4502 300 CONTINUE
4503 ENDIF
4504
4505 ELSEIF(msel.EQ.50) THEN
4506 DO 305 i=361,368
4507 msub(i)=1
4508 305 CONTINUE
4509 IF(mint(43).EQ.4) THEN
4510 DO 307 i=370,377
4511 msub(i)=1
4512 307 CONTINUE
4513 ENDIF
4514
4515 ENDIF
4516
4517C...Find heaviest new quark flavour allowed in processes 81-84.
4518 kflqm=1
4519 DO 310 i=1,min(8,mdcy(21,3))
4520 idc=i+mdcy(21,2)-1
4521 IF(mdme(idc,1).LE.0) GOTO 310
4522 kflqm=i
4523 310 CONTINUE
4524 IF(mstp(7).GE.1.AND.mstp(7).LE.8.AND.(msel.LE.3.OR.msel.GE.9))
4525 &kflqm=mstp(7)
4526 mint(55)=kflqm
4527 kfpr(81,1)=kflqm
4528 kfpr(81,2)=kflqm
4529 kfpr(82,1)=kflqm
4530 kfpr(82,2)=kflqm
4531 kfpr(83,1)=kflqm
4532 kfpr(84,1)=kflqm
4533 kfpr(84,2)=kflqm
4534
4535C...Find heaviest new fermion flavour allowed in process 85.
4536 kflfm=1
4537 DO 320 i=1,min(12,mdcy(22,3))
4538 idc=i+mdcy(22,2)-1
4539 IF(mdme(idc,1).LE.0) GOTO 320
4540 kflfm=kfdp(idc,1)
4541 320 CONTINUE
4542 IF(((mstp(7).GE.1.AND.mstp(7).LE.8).OR.(mstp(7).GE.11.AND.
4543 &mstp(7).LE.18)).AND.(msel.LE.3.OR.msel.GE.9)) kflfm=mstp(7)
4544 mint(56)=kflfm
4545 kfpr(85,1)=kflfm
4546 kfpr(85,2)=kflfm
4547
4548 RETURN
4549 END
4550
4551C*********************************************************************
4552
4553C...PYXTOT
4554C...Parametrizes total, elastic and diffractive cross-sections
4555C...for different energies and beams. Donnachie-Landshoff for
4556C...total and Schuler-Sjostrand for elastic and diffractive.
4557C...Process code IPROC:
4558C...= 1 : p + p;
4559C...= 2 : pbar + p;
4560C...= 3 : pi+ + p;
4561C...= 4 : pi- + p;
4562C...= 5 : pi0 + p;
4563C...= 6 : phi + p;
4564C...= 7 : J/psi + p;
4565C...= 11 : rho + rho;
4566C...= 12 : rho + phi;
4567C...= 13 : rho + J/psi;
4568C...= 14 : phi + phi;
4569C...= 15 : phi + J/psi;
4570C...= 16 : J/psi + J/psi;
4571C...= 21 : gamma + p (DL);
4572C...= 22 : gamma + p (VDM).
4573C...= 23 : gamma + pi (DL);
4574C...= 24 : gamma + pi (VDM);
4575C...= 25 : gamma + gamma (DL);
4576C...= 26 : gamma + gamma (VDM).
4577
4578 SUBROUTINE pyxtot
4579
4580C...Double precision and integer declarations.
4581 IMPLICIT DOUBLE PRECISION(a-h, o-z)
4582 IMPLICIT INTEGER(I-N)
4583 INTEGER PYK,PYCHGE,PYCOMP
4584C...Commonblocks.
4585 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4586 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4587 common/pypars/mstp(200),parp(200),msti(200),pari(200)
4588 common/pyint1/mint(400),vint(400)
4589 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4590 common/pyint7/sigt(0:6,0:6,0:5)
4591 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint5/,/pyint7/
4592C...Local arrays.
4593 dimension nproc(30),xpar(30),ypar(30),ihada(20),ihadb(20),
4594 &pmhad(4),bhad(4),betp(4),ifitsd(20),ifitdd(20),ceffs(10,8),
4595 &ceffd(10,9),sigtmp(6,0:5)
4596
4597C...Common constants.
4598 DATA eps/0.0808d0/, eta/-0.4525d0/, alp/0.25d0/, cres/2d0/,
4599 &pmrc/1.062d0/, smp/0.880d0/, facel/0.0511d0/, facsd/0.0336d0/,
4600 &facdd/0.0084d0/
4601
4602C...Number of multiple processes to be evaluated (= 0 : undefined).
4603 DATA nproc/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4604C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4605 DATA xpar/2*21.70d0,3*13.63d0,10.01d0,0.970d0,3*0d0,
4606 &8.56d0,6.29d0,0.609d0,4.62d0,0.447d0,0.0434d0,4*0d0,
4607 &0.0677d0,0.0534d0,0.0425d0,0.0335d0,2.11d-4,1.31d-4,4*0d0/
4608 DATA ypar/
4609 &56.08d0,98.39d0,27.56d0,36.02d0,31.79d0,-1.51d0,-0.146d0,3*0d0,
4610 &13.08d0,-0.62d0,-0.060d0,0.030d0,-0.0028d0,0.00028d0,4*0d0,
4611 &0.129d0,0.115d0,0.081d0,0.072d0,2.15d-4,1.70d-4,4*0d0/
4612
4613C...Beam and target hadron class:
4614C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4615 DATA ihada/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4616 DATA ihadb/7*1,3*0,2,3,4,3,2*4,4*0/
4617C...Characteristic class masses, slope parameters, beta = sqrt(X).
4618 DATA pmhad/0.938d0,0.770d0,1.020d0,3.097d0/
4619 DATA bhad/2.3d0,1.4d0,1.4d0,0.23d0/
4620 DATA betp/4.658d0,2.926d0,2.149d0,0.208d0/
4621
4622C...Fitting constants used in parametrizations of diffractive results.
4623 DATA ifitsd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4624 DATA ifitdd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4625 DATA ((ceffs(j1,j2),j2=1,8),j1=1,10)/
4626 &0.213d0, 0.0d0, -0.47d0, 150d0, 0.213d0, 0.0d0, -0.47d0, 150d0,
4627 &0.213d0, 0.0d0, -0.47d0, 150d0, 0.267d0, 0.0d0, -0.47d0, 100d0,
4628 &0.213d0, 0.0d0, -0.47d0, 150d0, 0.232d0, 0.0d0, -0.47d0, 110d0,
4629 &0.213d0, 7.0d0, -0.55d0, 800d0, 0.115d0, 0.0d0, -0.47d0, 110d0,
4630 &0.267d0, 0.0d0, -0.46d0, 75d0, 0.267d0, 0.0d0, -0.46d0, 75d0,
4631 &0.232d0, 0.0d0, -0.46d0, 85d0, 0.267d0, 0.0d0, -0.48d0, 100d0,
4632 &0.115d0, 0.0d0, -0.50d0, 90d0, 0.267d0, 6.0d0, -0.56d0, 420d0,
4633 &0.232d0, 0.0d0, -0.48d0, 110d0, 0.232d0, 0.0d0, -0.48d0, 110d0,
4634 &0.115d0, 0.0d0, -0.52d0, 120d0, 0.232d0, 6.0d0, -0.56d0, 470d0,
4635 &0.115d0, 5.5d0, -0.58d0, 570d0, 0.115d0, 5.5d0, -0.58d0, 570d0/
4636 DATA ((ceffd(j1,j2),j2=1,9),j1=1,10)/
4637 &3.11d0, -7.34d0, 9.71d0, 0.068d0, -0.42d0, 1.31d0,
4638 &-1.37d0, 35.0d0, 118d0, 3.11d0, -7.10d0, 10.6d0,
4639 &0.073d0, -0.41d0, 1.17d0, -1.41d0, 31.6d0, 95d0,
4640 &3.12d0, -7.43d0, 9.21d0, 0.067d0, -0.44d0, 1.41d0,
4641 &-1.35d0, 36.5d0, 132d0, 3.13d0, -8.18d0, -4.20d0,
4642 &0.056d0, -0.71d0, 3.12d0, -1.12d0, 55.2d0, 1298d0,
4643 &3.11d0, -6.90d0, 11.4d0, 0.078d0, -0.40d0, 1.05d0,
4644 &-1.40d0, 28.4d0, 78d0, 3.11d0, -7.13d0, 10.0d0,
4645 &0.071d0, -0.41d0, 1.23d0, -1.34d0, 33.1d0, 105d0,
4646 &3.12d0, -7.90d0, -1.49d0, 0.054d0, -0.64d0, 2.72d0,
4647 &-1.13d0, 53.1d0, 995d0, 3.11d0, -7.39d0, 8.22d0,
4648 &0.065d0, -0.44d0, 1.45d0, -1.36d0, 38.1d0, 148d0,
4649 &3.18d0, -8.95d0, -3.37d0, 0.057d0, -0.76d0, 3.32d0,
4650 &-1.12d0, 55.6d0, 1472d0, 4.18d0, -29.2d0, 56.2d0,
4651 &0.074d0, -1.36d0, 6.67d0, -1.14d0, 116.2d0, 6532d0/
4652
4653C...Parameters. Combinations of the energy.
4654 aem=paru(101)
4655 pmth=parp(102)
4656 s=vint(2)
4657 srt=vint(1)
4658 seps=s**eps
4659 seta=s**eta
4660 slog=log(s)
4661
4662C...Ratio of gamma/pi (for rescaling in parton distributions).
4663 vint(281)=(xpar(22)*seps+ypar(22)*seta)/
4664 &(xpar(5)*seps+ypar(5)*seta)
4665 vint(317)=1d0
4666 IF(mint(50).NE.1) RETURN
4667
4668C...Order flavours of incoming particles: KF1 < KF2.
4669 IF(iabs(mint(11)).LE.iabs(mint(12))) THEN
4670 kf1=iabs(mint(11))
4671 kf2=iabs(mint(12))
4672 iord=1
4673 ELSE
4674 kf1=iabs(mint(12))
4675 kf2=iabs(mint(11))
4676 iord=2
4677 ENDIF
4678 isgn12=isign(1,mint(11)*mint(12))
4679
4680C...Find process number (for lookup tables).
4681 IF(kf1.GT.1000) THEN
4682 iproc=1
4683 IF(isgn12.LT.0) iproc=2
4684 ELSEIF(kf1.GT.100.AND.kf2.GT.1000) THEN
4685 iproc=3
4686 IF(isgn12.LT.0) iproc=4
4687 IF(kf1.EQ.111) iproc=5
4688 ELSEIF(kf1.GT.100) THEN
4689 iproc=11
4690 ELSEIF(kf2.GT.1000) THEN
4691 iproc=21
4692 IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=22
4693 ELSEIF(kf2.GT.100) THEN
4694 iproc=23
4695 IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=24
4696 ELSE
4697 iproc=25
4698 IF(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7) iproc=26
4699 ENDIF
4700
4701C... Number of multiple processes to be stored; beam/target side.
4702 npr=nproc(iproc)
4703 mint(101)=1
4704 mint(102)=1
4705 IF(npr.EQ.3) THEN
4706 mint(100+iord)=4
4707 ELSEIF(npr.EQ.6) THEN
4708 mint(101)=4
4709 mint(102)=4
4710 ENDIF
4711 n1=0
4712 IF(mint(101).EQ.4) n1=4
4713 n2=0
4714 IF(mint(102).EQ.4) n2=4
4715
4716C...Do not do any more for user-set or undefined cross-sections.
4717 IF(mstp(31).LE.0) RETURN
4718 IF(npr.EQ.0) CALL pyerrm(26,
4719 &'(PYXTOT:) cross section for this process not yet implemented')
4720
4721C...Parameters. Combinations of the energy.
4722 aem=paru(101)
4723 pmth=parp(102)
4724 s=vint(2)
4725 srt=vint(1)
4726 seps=s**eps
4727 seta=s**eta
4728 slog=log(s)
4729
4730C...Loop over multiple processes (for VDM).
4731 DO 110 i=1,npr
4732 IF(npr.EQ.1) THEN
4733 ipr=iproc
4734 ELSEIF(npr.EQ.3) THEN
4735 ipr=i+4
4736 IF(kf2.LT.1000) ipr=i+10
4737 ELSEIF(npr.EQ.6) THEN
4738 ipr=i+10
4739 ENDIF
4740
4741C...Evaluate hadron species, mass, slope contribution and fit number.
4742 iha=ihada(ipr)
4743 ihb=ihadb(ipr)
4744 pma=pmhad(iha)
4745 pmb=pmhad(ihb)
4746 bha=bhad(iha)
4747 bhb=bhad(ihb)
4748 isd=ifitsd(ipr)
4749 idd=ifitdd(ipr)
4750
4751C...Skip if energy too low relative to masses.
4752 DO 100 j=0,5
4753 sigtmp(i,j)=0d0
4754 100 CONTINUE
4755 IF(srt.LT.pma+pmb+parp(104)) GOTO 110
4756
4757C...Total cross-section. Elastic slope parameter and cross-section.
4758 sigtmp(i,0)=xpar(ipr)*seps+ypar(ipr)*seta
4759 bel=2d0*bha+2d0*bhb+4d0*seps-4.2d0
4760 sigtmp(i,1)=facel*sigtmp(i,0)**2/bel
4761
4762C...Diffractive scattering A + B -> X + B.
4763 bsd=2d0*bhb
4764 sqml=(pma+pmth)**2
4765 sqmu=s*ceffs(isd,1)+ceffs(isd,2)
4766 sum1=log((bsd+2d0*alp*log(s/sqml))/
4767 & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
4768 bxb=ceffs(isd,3)+ceffs(isd,4)/s
4769 sum2=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)/
4770 & (bsd+2d0*alp*log(s/((pma+pmth)*(pma+pmrc)))+bxb)
4771 sigtmp(i,2)=facsd*xpar(ipr)*betp(ihb)*max(0d0,sum1+sum2)
4772
4773C...Diffractive scattering A + B -> A + X.
4774 bsd=2d0*bha
4775 sqml=(pmb+pmth)**2
4776 sqmu=s*ceffs(isd,5)+ceffs(isd,6)
4777 sum1=log((bsd+2d0*alp*log(s/sqml))/
4778 & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
4779 bax=ceffs(isd,7)+ceffs(isd,8)/s
4780 sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/
4781 & (bsd+2d0*alp*log(s/((pmb+pmth)*(pmb+pmrc)))+bax)
4782 sigtmp(i,3)=facsd*xpar(ipr)*betp(iha)*max(0d0,sum1+sum2)
4783
4784C...Order single diffractive correctly.
4785 IF(iord.EQ.2) THEN
4786 sigsav=sigtmp(i,2)
4787 sigtmp(i,2)=sigtmp(i,3)
4788 sigtmp(i,3)=sigsav
4789 ENDIF
4790
4791C...Double diffractive scattering A + B -> X1 + X2.
4792 yeff=log(s*smp/((pma+pmth)*(pmb+pmth))**2)
4793 deff=ceffd(idd,1)+ceffd(idd,2)/slog+ceffd(idd,3)/slog**2
4794 sum1=deff+yeff*(log(max(1d-10,yeff/deff))-1d0)/(2d0*alp)
4795 IF(yeff.LE.0) sum1=0d0
4796 sqmu=s*(ceffd(idd,4)+ceffd(idd,5)/slog+ceffd(idd,6)/slog**2)
4797 slup=log(max(1.1d0,s/(alp*(pma+pmth)**2*(pmb+pmth)*(pmb+pmrc))))
4798 sldn=log(max(1.1d0,s/(alp*sqmu*(pmb+pmth)*(pmb+pmrc))))
4799 sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)*log(slup/sldn)/
4800 & (2d0*alp)
4801 slup=log(max(1.1d0,s/(alp*(pmb+pmth)**2*(pma+pmth)*(pma+pmrc))))
4802 sldn=log(max(1.1d0,s/(alp*sqmu*(pma+pmth)*(pma+pmrc))))
4803 sum3=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)*log(slup/sldn)/
4804 & (2d0*alp)
4805 bxx=ceffd(idd,7)+ceffd(idd,8)/srt+ceffd(idd,9)/s
4806 slrr=log(s/(alp*(pma+pmth)*(pma+pmrc)*(pmb+pmth)*(pmb*pmrc)))
4807 sum4=cres**2*log(1d0+((pma+pmrc)/(pma+pmth))**2)*
4808 & log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/max(0.1d0,2d0*alp*slrr+bxx)
4809 sigtmp(i,4)=facdd*xpar(ipr)*max(0d0,sum1+sum2+sum3+sum4)
4810
4811C...Non-diffractive by unitarity.
4812 sigtmp(i,5)=sigtmp(i,0)-sigtmp(i,1)-sigtmp(i,2)-sigtmp(i,3)-
4813 & sigtmp(i,4)
4814 110 CONTINUE
4815
4816C...Put temporary results in output array: only one process.
4817 IF(mint(101).EQ.1.AND.mint(102).EQ.1) THEN
4818 DO 120 j=0,5
4819 sigt(0,0,j)=sigtmp(1,j)
4820 120 CONTINUE
4821
4822C...Beam multiple processes.
4823 ELSEIF(mint(101).EQ.4.AND.mint(102).EQ.1) THEN
4824 IF(mint(107).EQ.2) THEN
4825 vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
4826 ELSE
4827 vint(317)=16d0*parp(15)**2*vint(154)**2/
4828 & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
4829 ENDIF
4830 IF(mstp(20).GT.0) THEN
4831 vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)))**mstp(20)
4832 ENDIF
4833 DO 140 i=1,4
4834 IF(mint(107).EQ.2) THEN
4835 conv=(aem/parp(160+i))*vint(317)
4836 ELSEIF(vint(154).GT.parp(15)) THEN
4837 conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
4838 & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
4839 ELSE
4840 conv=0d0
4841 ENDIF
4842 i1=max(1,i-1)
4843 DO 130 j=0,5
4844 sigt(i,0,j)=conv*sigtmp(i1,j)
4845 130 CONTINUE
4846 140 CONTINUE
4847 DO 150 j=0,5
4848 sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
4849 150 CONTINUE
4850
4851C...Target multiple processes.
4852 ELSEIF(mint(101).EQ.1.AND.mint(102).EQ.4) THEN
4853 IF(mint(108).EQ.2) THEN
4854 vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
4855 ELSE
4856 vint(317)=16d0*parp(15)**2*vint(154)**2/
4857 & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
4858 ENDIF
4859 IF(mstp(20).GT.0) THEN
4860 vint(317)=vint(317)*(vint(2)/(vint(2)+vint(308)))**mstp(20)
4861 ENDIF
4862 DO 170 i=1,4
4863 IF(mint(108).EQ.2) THEN
4864 conv=(aem/parp(160+i))*vint(317)
4865 ELSEIF(vint(154).GT.parp(15)) THEN
4866 conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
4867 & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
4868 ELSE
4869 conv=0d0
4870 ENDIF
4871 iv=max(1,i-1)
4872 DO 160 j=0,5
4873 sigt(0,i,j)=conv*sigtmp(iv,j)
4874 160 CONTINUE
4875 170 CONTINUE
4876 DO 180 j=0,5
4877 sigt(0,0,j)=sigt(0,1,j)+sigt(0,2,j)+sigt(0,3,j)+sigt(0,4,j)
4878 180 CONTINUE
4879
4880C...Both beam and target multiple processes.
4881 ELSE
4882 IF(mint(107).EQ.2) THEN
4883 vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
4884 ELSE
4885 vint(317)=16d0*parp(15)**2*vint(154)**2/
4886 & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
4887 ENDIF
4888 IF(mint(108).EQ.2) THEN
4889 vint(317)=vint(317)*(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
4890 ELSE
4891 vint(317)=vint(317)*16d0*parp(15)**2*vint(154)**2/
4892 & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
4893 ENDIF
4894 IF(mstp(20).GT.0) THEN
4895 vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)+
4896 & vint(308)))**mstp(20)
4897 ENDIF
4898 DO 210 i1=1,4
4899 DO 200 i2=1,4
4900 IF(mint(107).EQ.2) THEN
4901 conv=(aem/parp(160+i1))*vint(317)
4902 ELSEIF(vint(154).GT.parp(15)) THEN
4903 conv=(aem/paru(1))*(kchg(i1,1)/3d0)**2*parp(18)**2*
4904 & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
4905 ELSE
4906 conv=0d0
4907 ENDIF
4908 IF(mint(108).EQ.2) THEN
4909 conv=conv*(aem/parp(160+i2))
4910 ELSEIF(vint(154).GT.parp(15)) THEN
4911 conv=conv*(aem/paru(1))*(kchg(i2,1)/3d0)**2*parp(18)**2*
4912 & (1d0/parp(15)**2-1d0/vint(154)**2)
4913 ELSE
4914 conv=0d0
4915 ENDIF
4916 IF(i1.LE.2) THEN
4917 iv=max(1,i2-1)
4918 ELSEIF(i2.LE.2) THEN
4919 iv=max(1,i1-1)
4920 ELSEIF(i1.EQ.i2) THEN
4921 iv=2*i1-2
4922 ELSE
4923 iv=5
4924 ENDIF
4925 DO 190 j=0,5
4926 jv=j
4927 IF(i2.GT.i1.AND.(j.EQ.2.OR.j.EQ.3)) jv=5-j
4928 sigt(i1,i2,j)=conv*sigtmp(iv,jv)
4929 190 CONTINUE
4930 200 CONTINUE
4931 210 CONTINUE
4932 DO 230 j=0,5
4933 DO 220 i=1,4
4934 sigt(i,0,j)=sigt(i,1,j)+sigt(i,2,j)+sigt(i,3,j)+sigt(i,4,j)
4935 sigt(0,i,j)=sigt(1,i,j)+sigt(2,i,j)+sigt(3,i,j)+sigt(4,i,j)
4936 220 CONTINUE
4937 sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
4938 230 CONTINUE
4939 ENDIF
4940
4941C...Scale up uniformly for Donnachie-Landshoff parametrization.
4942 IF(iproc.EQ.21.OR.iproc.EQ.23.OR.iproc.EQ.25) THEN
4943 rfac=(xpar(iproc)*seps+ypar(iproc)*seta)/sigt(0,0,0)
4944 DO 260 i1=0,n1
4945 DO 250 i2=0,n2
4946 DO 240 j=0,5
4947 sigt(i1,i2,j)=rfac*sigt(i1,i2,j)
4948 240 CONTINUE
4949 250 CONTINUE
4950 260 CONTINUE
4951 ENDIF
4952
4953 RETURN
4954 END
4955
4956C*********************************************************************
4957
4958C...PYMAXI
4959C...Finds optimal set of coefficients for kinematical variable selection
4960C...and the maximum of the part of the differential cross-section used
4961C...in the event weighting.
4962
4963 SUBROUTINE pymaxi
4964
4965C...Double precision and integer declarations.
4966 IMPLICIT DOUBLE PRECISION(a-h, o-z)
4967 IMPLICIT INTEGER(I-N)
4968 INTEGER PYK,PYCHGE,PYCOMP
4969C...Parameter statement to help give large particle numbers.
4970 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
4971C...Commonblocks.
4972 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4973 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4974 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
4975 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
4976 common/pypars/mstp(200),parp(200),msti(200),pari(200)
4977 common/pyint1/mint(400),vint(400)
4978 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4979 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
4980 common/pyint4/mwid(500),wids(500,5)
4981 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4982 common/pyint6/proc(0:500)
4983 CHARACTER PROC*28
4984 common/pyint7/sigt(0:6,0:6,0:5)
4985 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
4986 &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint6/,/pyint7/
4987C...Local arrays, character variables and data.
4988 CHARACTER CVAR(4)*4
4989 dimension npts(4),mvarpt(500,4),vintpt(500,30),sigspt(500),
4990 &narel(7),wtrel(7),wtmat(7,7),wtreln(7),coefu(7),coefo(7),
4991 &iaccmx(4),sigsmx(4),sigssm(3),pmmn(2)
4992 DATA cvar/'tau ','tau''','y* ','cth '/
4993 DATA sigssm/3*0d0/
4994
4995C...Initial values and loop over subprocesses.
4996 nposi=0
4997 vint(143)=1d0
4998 vint(144)=1d0
4999 xsec(0,1)=0d0
5000 DO 460 isub=1,500
5001 mint(1)=isub
5002 mint(51)=0
5003
5004C...Find maximum weight factors for photon flux.
5005 IF(msub(isub).EQ.1.OR.(isub.GE.91.AND.isub.LE.100)) THEN
5006 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(2,wtgaga)
5007 ENDIF
5008
5009C...Select subprocess to study: skip cases not applicable.
5010 IF(iset(isub).EQ.11) THEN
5011 IF(msub(isub).NE.1) GOTO 460
5012 xsec(isub,1)=1.00001d0*coef(isub,1)
5013 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
5014 & wtgaga*xsec(isub,1)
5015 nposi=nposi+1
5016 GOTO 450
5017 ELSEIF(isub.GE.91.AND.isub.LE.95) THEN
5018 CALL pysigh(nchn,sigs)
5019 xsec(isub,1)=sigs
5020 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
5021 & wtgaga*xsec(isub,1)
5022 IF(msub(isub).NE.1) GOTO 460
5023 nposi=nposi+1
5024 GOTO 450
5025 ELSEIF(isub.EQ.99.AND.msub(isub).EQ.1) THEN
5026 CALL pysigh(nchn,sigs)
5027 xsec(isub,1)=sigs
5028 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
5029 & wtgaga*xsec(isub,1)
5030 IF(xsec(isub,1).EQ.0d0) THEN
5031 msub(isub)=0
5032 ELSE
5033 nposi=nposi+1
5034 ENDIF
5035 GOTO 450
5036 ELSEIF(isub.EQ.96) THEN
5037 IF(mint(50).EQ.0) GOTO 460
5038 IF(msub(95).NE.1.AND.mstp(81).LE.0.AND.mstp(131).LE.0)
5039 & GOTO 460
5040 IF(mint(49).EQ.0.AND.mstp(131).EQ.0) GOTO 460
5041 ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.
5042 & isub.EQ.53.OR.isub.EQ.68) THEN
5043 IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 460
5044 ELSE
5045 IF(msub(isub).NE.1) GOTO 460
5046 ENDIF
5047 istsb=iset(isub)
5048 IF(isub.EQ.96) istsb=2
5049 IF(mstp(122).GE.2) WRITE(mstu(11),5000) isub
5050 mwtxs=0
5051 IF(mstp(142).GE.1.AND.isub.NE.96.AND.msub(91)+msub(92)+msub(93)+
5052 & msub(94)+msub(95).EQ.0) mwtxs=1
5053
5054C...Find resonances (explicit or implicit in cross-section).
5055 mint(72)=0
5056 kfr1=0
5057 IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
5058 kfr1=kfpr(isub,1)
5059 ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165
5060 & .OR.isub.EQ.171.OR.isub.EQ.176) THEN
5061 kfr1=23
5062 ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172
5063 & .OR.isub.EQ.177) THEN
5064 kfr1=24
5065 ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
5066 kfr1=25
5067 IF(mstp(46).EQ.5) THEN
5068 kfr1=30
5069 pmas(30,1)=parp(45)
5070 pmas(30,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
5071 ENDIF
5072 ELSEIF(isub.EQ.194) THEN
5073 kfr1=54
5074 ELSEIF(isub.EQ.195) THEN
5075 kfr1=55
5076 ELSEIF(isub.GE.361.AND.isub.LE.368) THEN
5077 kfr1=54
5078 ELSEIF(isub.GE.370.AND.isub.LE.377) THEN
5079 kfr1=55
5080 ENDIF
5081 ckmx=ckin(2)
5082 IF(ckmx.LE.0d0) ckmx=vint(1)
5083 kcr1=pycomp(kfr1)
5084 IF(kfr1.NE.0) THEN
5085 IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
5086 & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
5087 ENDIF
5088 IF(kfr1.NE.0) THEN
5089 taur1=pmas(kcr1,1)**2/vint(2)
5090 IF(kfr1.EQ.54) THEN
5091 CALL pytecm(s1,s2)
5092 taur1=s1/vint(2)
5093 ENDIF
5094 gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
5095 mint(72)=1
5096 mint(73)=kfr1
5097 vint(73)=taur1
5098 vint(74)=gamr1
5099 ENDIF
5100 kfr2=0
5101 IF(isub.EQ.141.OR.isub.EQ.194.OR.(isub.GE.364.AND.isub.LE.368))
5102 $ THEN
5103 kfr2=23
5104 IF(isub.EQ.194) THEN
5105 kfr2=56
5106 ELSEIF(isub.GE.364.AND.isub.LE.368) THEN
5107 kfr2=56
5108 ENDIF
5109 kcr2=pycomp(kfr2)
5110 taur2=pmas(kcr2,1)**2/vint(2)
5111 IF(kfr2.EQ.56) THEN
5112 CALL pytecm(s1,s2)
5113 taur2=s2/vint(2)
5114 ENDIF
5115 gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
5116 IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
5117 & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) kfr2=0
5118 IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
5119 mint(72)=2
5120 mint(74)=kfr2
5121 vint(75)=taur2
5122 vint(76)=gamr2
5123 ELSEIF(kfr2.NE.0) THEN
5124 kfr1=kfr2
5125 taur1=taur2
5126 gamr1=gamr2
5127 mint(72)=1
5128 mint(73)=kfr1
5129 vint(73)=taur1
5130 vint(74)=gamr1
5131 kfr2=0
5132 ENDIF
5133 ENDIF
5134
5135C...Find product masses and minimum pT of process.
5136 sqm3=0d0
5137 sqm4=0d0
5138 mint(71)=0
5139 vint(71)=ckin(3)
5140 vint(80)=1d0
5141 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
5142 nbw=0
5143 DO 110 i=1,2
5144 pmmn(i)=0d0
5145 IF(kfpr(isub,i).EQ.0) THEN
5146 ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
5147 & parp(41)) THEN
5148 IF(i.EQ.1) sqm3=pmas(pycomp(kfpr(isub,i)),1)**2
5149 IF(i.EQ.2) sqm4=pmas(pycomp(kfpr(isub,i)),1)**2
5150 ELSE
5151 nbw=nbw+1
5152C...This prevents SUSY/t particles from becoming too light.
5153 kflw=kfpr(isub,i)
5154 IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
5155 kcw=pycomp(kflw)
5156 pmmn(i)=pmas(kcw,1)
5157 DO 100 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
5158 IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
5159 pmsum=pmas(pycomp(kfdp(idc,1)),1)+
5160 & pmas(pycomp(kfdp(idc,2)),1)
5161 IF(kfdp(idc,3).NE.0) pmsum=pmsum+
5162 & pmas(pycomp(kfdp(idc,3)),1)
5163 pmmn(i)=min(pmmn(i),pmsum)
5164 ENDIF
5165 100 CONTINUE
5166 ELSEIF(kflw.EQ.6) THEN
5167 pmmn(i)=pmas(24,1)+pmas(5,1)
5168 ENDIF
5169 ENDIF
5170 110 CONTINUE
5171 IF(nbw.GE.1) THEN
5172 ckin41=ckin(41)
5173 ckin43=ckin(43)
5174 ckin(41)=max(pmmn(1),ckin(41))
5175 ckin(43)=max(pmmn(2),ckin(43))
5176 CALL pyofsh(3,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
5177 ckin(41)=ckin41
5178 ckin(43)=ckin43
5179 IF(mint(51).EQ.1) THEN
5180 WRITE(mstu(11),5100) isub
5181 msub(isub)=0
5182 GOTO 460
5183 ENDIF
5184 sqm3=pqm3**2
5185 sqm4=pqm4**2
5186 ENDIF
5187 IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1
5188 IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
5189 IF(isub.EQ.96.AND.mstp(82).LE.1) THEN
5190 vint(71)=parp(81)*(vint(1)/parp(89))**parp(90)
5191 ELSEIF(isub.EQ.96) THEN
5192 vint(71)=0.08d0*parp(82)*(vint(1)/parp(89))**parp(90)
5193 ENDIF
5194 ENDIF
5195 vint(63)=sqm3
5196 vint(64)=sqm4
5197
5198C...Prepare for additional variable choices in 2 -> 3.
5199 IF(istsb.EQ.5) THEN
5200 vint(201)=0d0
5201 IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
5202 vint(206)=vint(201)
5203 vint(204)=pmas(23,1)
5204 IF(isub.EQ.124.OR.isub.EQ.351) vint(204)=pmas(24,1)
5205 IF(isub.EQ.352) vint(204)=pmas(63,1)
5206 IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182
5207 & .OR.isub.EQ.186.OR.isub.EQ.187) vint(204)=vint(201)
5208 vint(209)=vint(204)
5209 ENDIF
5210
5211C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
5212 npts(1)=2+2*mint(72)
5213 IF(mint(47).EQ.1) THEN
5214 IF(istsb.EQ.1.OR.istsb.EQ.2) npts(1)=1
5215 ELSEIF(mint(47).GE.5) THEN
5216 IF(istsb.LE.2.OR.istsb.GT.5) npts(1)=npts(1)+1
5217 ENDIF
5218 npts(2)=1
5219 IF(istsb.GE.3.AND.istsb.LE.5) THEN
5220 IF(mint(47).GE.2) npts(2)=2
5221 IF(mint(47).GE.5) npts(2)=3
5222 ENDIF
5223 npts(3)=1
5224 IF(mint(47).EQ.4.OR.mint(47).EQ.5) THEN
5225 npts(3)=3
5226 IF(mint(45).EQ.3) npts(3)=npts(3)+1
5227 IF(mint(46).EQ.3) npts(3)=npts(3)+1
5228 ENDIF
5229 npts(4)=1
5230 IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5
5231 ntry=npts(1)*npts(2)*npts(3)*npts(4)
5232
5233C...Reset coefficients of cross-section weighting.
5234 DO 120 j=1,20
5235 coef(isub,j)=0d0
5236 120 CONTINUE
5237 coef(isub,1)=1d0
5238 coef(isub,8)=0.5d0
5239 coef(isub,9)=0.5d0
5240 coef(isub,13)=1d0
5241 coef(isub,18)=1d0
5242 mcth=0
5243 mtaup=0
5244 metaup=0
5245 vint(23)=0d0
5246 vint(26)=0d0
5247 sigsam=0d0
5248
5249C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5250C...in grid of phase space points.
5251 CALL pyklim(1)
5252 metau=mint(51)
5253 nacc=0
5254 DO 150 itry=1,ntry
5255 mint(51)=0
5256 IF(metau.EQ.1) GOTO 150
5257 IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN
5258 mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))
5259 IF(mtau.GT.2+2*mint(72)) mtau=7
5260 rtau=0.5d0
5261C...Special case when both resonances have same mass,
5262C...as is often the case in process 194.
5263 IF(mint(72).EQ.2) THEN
5264 IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LT.
5265 & 0.01d0*(pmas(kcr2,1)+pmas(kcr1,1))) THEN
5266 IF(mtau.EQ.3.OR.mtau.EQ.4) THEN
5267 rtau=0.4d0
5268 ELSEIF(mtau.EQ.5.OR.mtau.EQ.6) THEN
5269 rtau=0.6d0
5270 ENDIF
5271 ENDIF
5272 ENDIF
5273 CALL pykmap(1,mtau,rtau)
5274 IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)
5275 metaup=mint(51)
5276 ENDIF
5277 IF(metaup.EQ.1) GOTO 150
5278 IF(istsb.GE.3.AND.istsb.LE.5.AND.mod(itry-1,npts(3)*npts(4))
5279 & .EQ.0) THEN
5280 mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))
5281 CALL pykmap(4,mtaup,0.5d0)
5282 ENDIF
5283 IF(mod(itry-1,npts(3)*npts(4)).EQ.0) THEN
5284 CALL pyklim(2)
5285 meyst=mint(51)
5286 ENDIF
5287 IF(meyst.EQ.1) GOTO 150
5288 IF(mod(itry-1,npts(4)).EQ.0) THEN
5289 myst=1+mod((itry-1)/npts(4),npts(3))
5290 IF(myst.EQ.4.AND.mint(45).NE.3) myst=5
5291 CALL pykmap(2,myst,0.5d0)
5292 CALL pyklim(3)
5293 mecth=mint(51)
5294 ENDIF
5295 IF(mecth.EQ.1) GOTO 150
5296 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
5297 mcth=1+mod(itry-1,npts(4))
5298 CALL pykmap(3,mcth,0.5d0)
5299 ENDIF
5300 IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)
5301
5302C...Store position and limits.
5303 mint(51)=0
5304 CALL pyklim(0)
5305 IF(mint(51).EQ.1) GOTO 150
5306 nacc=nacc+1
5307 mvarpt(nacc,1)=mtau
5308 mvarpt(nacc,2)=mtaup
5309 mvarpt(nacc,3)=myst
5310 mvarpt(nacc,4)=mcth
5311 DO 130 j=1,30
5312 vintpt(nacc,j)=vint(10+j)
5313 130 CONTINUE
5314
5315C...Normal case: calculate cross-section.
5316 IF(istsb.NE.5) THEN
5317 CALL pysigh(nchn,sigs)
5318 IF(mwtxs.EQ.1) THEN
5319 CALL pyevwt(wtxs)
5320 sigs=wtxs*sigs
5321 ENDIF
5322
5323C..2 -> 3: find highest value out of a number of tries.
5324 ELSE
5325 sigs=0d0
5326 DO 140 ikin3=1,mstp(129)
5327 CALL pykmap(5,0,0d0)
5328 IF(mint(51).EQ.1) GOTO 140
5329 CALL pysigh(nchn,sigtmp)
5330 IF(mwtxs.EQ.1) THEN
5331 CALL pyevwt(wtxs)
5332 sigtmp=wtxs*sigtmp
5333 ENDIF
5334 IF(sigtmp.GT.sigs) sigs=sigtmp
5335 140 CONTINUE
5336 ENDIF
5337
5338C...Store cross-section.
5339 sigspt(nacc)=sigs
5340 IF(sigs.GT.sigsam) sigsam=sigs
5341 IF(mstp(122).GE.2) WRITE(mstu(11),5200) mtau,myst,mcth,mtaup,
5342 & vint(21),vint(22),vint(23),vint(26),sigs
5343 150 CONTINUE
5344 IF(nacc.EQ.0) THEN
5345 WRITE(mstu(11),5100) isub
5346 msub(isub)=0
5347 GOTO 460
5348 ELSEIF(sigsam.EQ.0d0) THEN
5349 WRITE(mstu(11),5300) isub
5350 msub(isub)=0
5351 GOTO 460
5352 ENDIF
5353 IF(isub.NE.96) nposi=nposi+1
5354
5355C...Calculate integrals in tau over maximal phase space limits.
5356 taumin=vint(11)
5357 taumax=vint(31)
5358 atau1=log(taumax/taumin)
5359 IF(npts(1).GE.2) THEN
5360 atau2=(taumax-taumin)/(taumax*taumin)
5361 ENDIF
5362 IF(npts(1).GE.4) THEN
5363 atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
5364 atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
5365 & gamr1
5366 ENDIF
5367 IF(npts(1).GE.6) THEN
5368 atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
5369 atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
5370 & gamr2
5371 ENDIF
5372 IF(npts(1).GT.2+2*mint(72)) THEN
5373 atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
5374 ENDIF
5375
5376C...Reset. Sum up cross-sections in points calculated.
5377 DO 320 ivar=1,4
5378 IF(npts(ivar).EQ.1) GOTO 320
5379 IF(isub.EQ.96.AND.ivar.EQ.4) GOTO 320
5380 nbin=npts(ivar)
5381 DO 170 j1=1,nbin
5382 narel(j1)=0
5383 wtrel(j1)=0d0
5384 coefu(j1)=0d0
5385 DO 160 j2=1,nbin
5386 wtmat(j1,j2)=0d0
5387 160 CONTINUE
5388 170 CONTINUE
5389 DO 180 iacc=1,nacc
5390 ibin=mvarpt(iacc,ivar)
5391 IF(ivar.EQ.1.AND.ibin.EQ.7) ibin=3+2*mint(72)
5392 IF(ivar.EQ.3.AND.ibin.EQ.5.AND.mint(45).NE.3) ibin=4
5393 narel(ibin)=narel(ibin)+1
5394 wtrel(ibin)=wtrel(ibin)+sigspt(iacc)
5395
5396C...Sum up tau cross-section pieces in points used.
5397 IF(ivar.EQ.1) THEN
5398 tau=vintpt(iacc,11)
5399 wtmat(ibin,1)=wtmat(ibin,1)+1d0
5400 wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau
5401 IF(nbin.GE.4) THEN
5402 wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)
5403 wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/
5404 & ((tau-taur1)**2+gamr1**2)
5405 ENDIF
5406 IF(nbin.GE.6) THEN
5407 wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)
5408 wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/
5409 & ((tau-taur2)**2+gamr2**2)
5410 ENDIF
5411 IF(nbin.GT.2+2*mint(72)) THEN
5412 wtmat(ibin,nbin)=wtmat(ibin,nbin)+(atau1/atau7)*
5413 & tau/max(2d-10,1d0-tau)
5414 ENDIF
5415
5416C...Sum up tau' cross-section pieces in points used.
5417 ELSEIF(ivar.EQ.2) THEN
5418 tau=vintpt(iacc,11)
5419 taup=vintpt(iacc,16)
5420 taupmn=vintpt(iacc,6)
5421 taupmx=vintpt(iacc,26)
5422 ataup1=log(taupmx/taupmn)
5423 ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
5424 wtmat(ibin,1)=wtmat(ibin,1)+1d0
5425 wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*
5426 & (1d0-tau/taup)**3/taup
5427 IF(nbin.GE.3) THEN
5428 ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
5429 wtmat(ibin,3)=wtmat(ibin,3)+(ataup1/ataup3)*
5430 & taup/max(2d-10,1d0-taup)
5431 ENDIF
5432
5433C...Sum up y* cross-section pieces in points used.
5434 ELSEIF(ivar.EQ.3) THEN
5435 yst=vintpt(iacc,12)
5436 ystmin=vintpt(iacc,2)
5437 ystmax=vintpt(iacc,22)
5438 ayst0=ystmax-ystmin
5439 ayst1=0.5d0*(ystmax-ystmin)**2
5440 ayst2=ayst1
5441 ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
5442 wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)
5443 wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst2)*(ystmax-yst)
5444 wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)
5445 IF(mint(45).EQ.3) THEN
5446 taue=vintpt(iacc,11)
5447 IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
5448 yst0=-0.5d0*log(taue)
5449 ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
5450 & max(1d-10,exp(yst0-ystmax)-1d0))
5451 wtmat(ibin,4)=wtmat(ibin,4)+(ayst0/ayst4)/
5452 & max(1d-10,1d0-exp(yst-yst0))
5453 ENDIF
5454 IF(mint(46).EQ.3) THEN
5455 taue=vintpt(iacc,11)
5456 IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
5457 yst0=-0.5d0*log(taue)
5458 ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
5459 & max(1d-10,exp(yst0+ystmin)-1d0))
5460 wtmat(ibin,nbin)=wtmat(ibin,nbin)+(ayst0/ayst5)/
5461 & max(1d-10,1d0-exp(-yst-yst0))
5462 ENDIF
5463
5464C...Sum up cos(theta-hat) cross-section pieces in points used.
5465 ELSE
5466 rm34=max(1d-20,2d0*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2)
5467 rsqm=1d0+rm34
5468 cthmax=sqrt(1d0-4d0*vint(71)**2/(taumax*vint(2)))
5469 cthmin=-cthmax
5470 IF(cthmax.GT.0.9999d0) rm34=max(rm34,2d0*vint(71)**2/
5471 & (taumax*vint(2)))
5472 acth1=cthmax-cthmin
5473 acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
5474 acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
5475 acth4=1d0/max(rm34,rsqm-cthmax)-1d0/max(rm34,rsqm-cthmin)
5476 acth5=1d0/max(rm34,rsqm+cthmin)-1d0/max(rm34,rsqm+cthmax)
5477 cth=vintpt(iacc,13)
5478 wtmat(ibin,1)=wtmat(ibin,1)+1d0
5479 wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/
5480 & max(rm34,rsqm-cth)
5481 wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/
5482 & max(rm34,rsqm+cth)
5483 wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/
5484 & max(rm34,rsqm-cth)**2
5485 wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/
5486 & max(rm34,rsqm+cth)**2
5487 ENDIF
5488 180 CONTINUE
5489
5490C...Check that equation system solvable.
5491 IF(mstp(122).GE.2) WRITE(mstu(11),5400) cvar(ivar)
5492 msolv=1
5493 wtrels=0d0
5494 DO 190 ibin=1,nbin
5495 IF(mstp(122).GE.2) WRITE(mstu(11),5500) (wtmat(ibin,ired),
5496 & ired=1,nbin),wtrel(ibin)
5497 IF(narel(ibin).EQ.0) msolv=0
5498 wtrels=wtrels+wtrel(ibin)
5499 190 CONTINUE
5500 IF(abs(wtrels).LT.1d-20) msolv=0
5501
5502C...Solve to find relative importance of cross-section pieces.
5503 IF(msolv.EQ.1) THEN
5504 DO 200 ibin=1,nbin
5505 wtreln(ibin)=max(0.1d0,wtrel(ibin)/wtrels)
5506 200 CONTINUE
5507 DO 230 ired=1,nbin-1
5508 DO 220 ibin=ired+1,nbin
5509 IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
5510 msolv=0
5511 GOTO 260
5512 ENDIF
5513 rqt=wtmat(ibin,ired)/wtmat(ired,ired)
5514 wtrel(ibin)=wtrel(ibin)-rqt*wtrel(ired)
5515 DO 210 icoe=ired,nbin
5516 wtmat(ibin,icoe)=wtmat(ibin,icoe)-rqt*wtmat(ired,icoe)
5517 210 CONTINUE
5518 220 CONTINUE
5519 230 CONTINUE
5520 DO 250 ired=nbin,1,-1
5521 DO 240 icoe=ired+1,nbin
5522 wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)
5523 240 CONTINUE
5524 coefu(ired)=wtrel(ired)/wtmat(ired,ired)
5525 250 CONTINUE
5526 ENDIF
5527
5528C...Share evenly if failure.
5529 260 IF(msolv.EQ.0) THEN
5530 DO 270 ibin=1,nbin
5531 coefu(ibin)=1d0
5532 wtreln(ibin)=0.1d0
5533 IF(wtrels.GT.0d0) wtreln(ibin)=max(0.1d0,
5534 & wtrel(ibin)/wtrels)
5535 270 CONTINUE
5536 ENDIF
5537
5538C...Normalize coefficients, with piece shared democratically.
5539 coefsu=0d0
5540 wtrels=0d0
5541 DO 280 ibin=1,nbin
5542 coefu(ibin)=max(0d0,coefu(ibin))
5543 coefsu=coefsu+coefu(ibin)
5544 wtrels=wtrels+wtreln(ibin)
5545 280 CONTINUE
5546 IF(coefsu.GT.0d0) THEN
5547 DO 290 ibin=1,nbin
5548 coefo(ibin)=parp(122)/nbin+(1d0-parp(122))*0.5d0*
5549 & (coefu(ibin)/coefsu+wtreln(ibin)/wtrels)
5550 290 CONTINUE
5551 ELSE
5552 DO 300 ibin=1,nbin
5553 coefo(ibin)=1d0/nbin
5554 300 CONTINUE
5555 ENDIF
5556 IF(ivar.EQ.1) ioff=0
5557 IF(ivar.EQ.2) ioff=17
5558 IF(ivar.EQ.3) ioff=7
5559 IF(ivar.EQ.4) ioff=12
5560 DO 310 ibin=1,nbin
5561 icof=ioff+ibin
5562 IF(ivar.EQ.1.AND.ibin.GT.2+2*mint(72)) icof=7
5563 IF(ivar.EQ.3.AND.ibin.EQ.4.AND.mint(45).NE.3) icof=icof+1
5564 coef(isub,icof)=coefo(ibin)
5565 310 CONTINUE
5566 IF(mstp(122).GE.2) WRITE(mstu(11),5600) cvar(ivar),
5567 & (coefo(ibin),ibin=1,nbin)
5568 320 CONTINUE
5569
5570C...Find two most promising maxima among points previously determined.
5571 DO 330 j=1,4
5572 iaccmx(j)=0
5573 sigsmx(j)=0d0
5574 330 CONTINUE
5575 nmax=0
5576 DO 390 iacc=1,nacc
5577 DO 340 j=1,30
5578 vint(10+j)=vintpt(iacc,j)
5579 340 CONTINUE
5580 IF(istsb.NE.5) THEN
5581 CALL pysigh(nchn,sigs)
5582 IF(mwtxs.EQ.1) THEN
5583 CALL pyevwt(wtxs)
5584 sigs=wtxs*sigs
5585 ENDIF
5586 ELSE
5587 sigs=0d0
5588 DO 350 ikin3=1,mstp(129)
5589 CALL pykmap(5,0,0d0)
5590 IF(mint(51).EQ.1) GOTO 350
5591 CALL pysigh(nchn,sigtmp)
5592 IF(mwtxs.EQ.1) THEN
5593 CALL pyevwt(wtxs)
5594 sigtmp=wtxs*sigtmp
5595 ENDIF
5596 IF(sigtmp.GT.sigs) sigs=sigtmp
5597 350 CONTINUE
5598 ENDIF
5599 ieq=0
5600 DO 360 imv=1,nmax
5601 IF(abs(sigs-sigsmx(imv)).LT.1d-4*(sigs+sigsmx(imv))) ieq=imv
5602 360 CONTINUE
5603 IF(ieq.EQ.0) THEN
5604 DO 370 imv=nmax,1,-1
5605 iin=imv+1
5606 IF(sigs.LE.sigsmx(imv)) GOTO 380
5607 iaccmx(imv+1)=iaccmx(imv)
5608 sigsmx(imv+1)=sigsmx(imv)
5609 370 CONTINUE
5610 iin=1
5611 380 iaccmx(iin)=iacc
5612 sigsmx(iin)=sigs
5613 IF(nmax.LE.1) nmax=nmax+1
5614 ENDIF
5615 390 CONTINUE
5616
5617C...Read out starting position for search.
5618 IF(mstp(122).GE.2) WRITE(mstu(11),5700)
5619 sigsam=sigsmx(1)
5620 DO 440 imax=1,nmax
5621 iacc=iaccmx(imax)
5622 mtau=mvarpt(iacc,1)
5623 mtaup=mvarpt(iacc,2)
5624 myst=mvarpt(iacc,3)
5625 mcth=mvarpt(iacc,4)
5626 vtau=0.5d0
5627 vyst=0.5d0
5628 vcth=0.5d0
5629 vtaup=0.5d0
5630
5631C...Starting point and step size in parameter space.
5632 DO 430 irpt=1,2
5633 DO 420 ivar=1,4
5634 IF(npts(ivar).EQ.1) GOTO 420
5635 IF(ivar.EQ.1) vvar=vtau
5636 IF(ivar.EQ.2) vvar=vtaup
5637 IF(ivar.EQ.3) vvar=vyst
5638 IF(ivar.EQ.4) vvar=vcth
5639 IF(ivar.EQ.1) mvar=mtau
5640 IF(ivar.EQ.2) mvar=mtaup
5641 IF(ivar.EQ.3) mvar=myst
5642 IF(ivar.EQ.4) mvar=mcth
5643 IF(irpt.EQ.1) vdel=0.1d0
5644 IF(irpt.EQ.2) vdel=max(0.01d0,min(0.05d0,vvar-0.02d0,
5645 & 0.98d0-vvar))
5646 IF(irpt.EQ.1) vmar=0.02d0
5647 IF(irpt.EQ.2) vmar=0.002d0
5648 imov0=1
5649 IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0
5650 DO 410 imov=imov0,8
5651
5652C...Define new point in parameter space.
5653 IF(imov.EQ.0) THEN
5654 inew=2
5655 vnew=vvar
5656 ELSEIF(imov.EQ.1) THEN
5657 inew=3
5658 vnew=vvar+vdel
5659 ELSEIF(imov.EQ.2) THEN
5660 inew=1
5661 vnew=vvar-vdel
5662 ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.
5663 & vvar+2d0*vdel.LT.1d0-vmar) THEN
5664 vvar=vvar+vdel
5665 sigssm(1)=sigssm(2)
5666 sigssm(2)=sigssm(3)
5667 inew=3
5668 vnew=vvar+vdel
5669 ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.
5670 & vvar-2d0*vdel.GT.vmar) THEN
5671 vvar=vvar-vdel
5672 sigssm(3)=sigssm(2)
5673 sigssm(2)=sigssm(1)
5674 inew=1
5675 vnew=vvar-vdel
5676 ELSEIF(sigssm(3).GE.sigssm(1)) THEN
5677 vdel=0.5d0*vdel
5678 vvar=vvar+vdel
5679 sigssm(1)=sigssm(2)
5680 inew=2
5681 vnew=vvar
5682 ELSE
5683 vdel=0.5d0*vdel
5684 vvar=vvar-vdel
5685 sigssm(3)=sigssm(2)
5686 inew=2
5687 vnew=vvar
5688 ENDIF
5689
5690C...Convert to relevant variables and find derived new limits.
5691 ilerr=0
5692 IF(ivar.EQ.1) THEN
5693 vtau=vnew
5694 CALL pykmap(1,mtau,vtau)
5695 IF(istsb.GE.3.AND.istsb.LE.5) THEN
5696 CALL pyklim(4)
5697 IF(mint(51).EQ.1) ilerr=1
5698 ENDIF
5699 ENDIF
5700 IF(ivar.LE.2.AND.istsb.GE.3.AND.istsb.LE.5.AND.
5701 & ilerr.EQ.0) THEN
5702 IF(ivar.EQ.2) vtaup=vnew
5703 CALL pykmap(4,mtaup,vtaup)
5704 ENDIF
5705 IF(ivar.LE.2.AND.ilerr.EQ.0) THEN
5706 CALL pyklim(2)
5707 IF(mint(51).EQ.1) ilerr=1
5708 ENDIF
5709 IF(ivar.LE.3.AND.ilerr.EQ.0) THEN
5710 IF(ivar.EQ.3) vyst=vnew
5711 CALL pykmap(2,myst,vyst)
5712 CALL pyklim(3)
5713 IF(mint(51).EQ.1) ilerr=1
5714 ENDIF
5715 IF((istsb.EQ.2.OR.istsb.EQ.4.OR.istsb.EQ.6).AND.
5716 & ilerr.EQ.0) THEN
5717 IF(ivar.EQ.4) vcth=vnew
5718 CALL pykmap(3,mcth,vcth)
5719 ENDIF
5720 IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2)
5721
5722C...Evaluate cross-section. Save new maximum. Final maximum.
5723 IF(ilerr.NE.0) THEN
5724 sigs=0.
5725 ELSEIF(istsb.NE.5) THEN
5726 CALL pysigh(nchn,sigs)
5727 IF(mwtxs.EQ.1) THEN
5728 CALL pyevwt(wtxs)
5729 sigs=wtxs*sigs
5730 ENDIF
5731 ELSE
5732 sigs=0d0
5733 DO 400 ikin3=1,mstp(129)
5734 CALL pykmap(5,0,0d0)
5735 IF(mint(51).EQ.1) GOTO 400
5736 CALL pysigh(nchn,sigtmp)
5737 IF(mwtxs.EQ.1) THEN
5738 CALL pyevwt(wtxs)
5739 sigtmp=wtxs*sigtmp
5740 ENDIF
5741 IF(sigtmp.GT.sigs) sigs=sigtmp
5742 400 CONTINUE
5743 ENDIF
5744 sigssm(inew)=sigs
5745 IF(sigs.GT.sigsam) sigsam=sigs
5746 IF(mstp(122).GE.2) WRITE(mstu(11),5800) imax,ivar,mvar,
5747 & imov,vnew,vint(21),vint(22),vint(23),vint(26),sigs
5748 410 CONTINUE
5749 420 CONTINUE
5750 430 CONTINUE
5751 440 CONTINUE
5752 IF(mstp(121).EQ.1) sigsam=parp(121)*sigsam
5753 xsec(isub,1)=1.05d0*sigsam
5754 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
5755 & wtgaga*xsec(isub,1)
5756 450 CONTINUE
5757 IF(mstp(173).EQ.1.AND.isub.NE.96) xsec(isub,1)=
5758 & parp(174)*xsec(isub,1)
5759 IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)
5760 460 CONTINUE
5761 mint(51)=0
5762
5763C...Print summary table.
5764 IF(mint(121).EQ.1.AND.nposi.EQ.0) THEN
5765 WRITE(mstu(11),5900)
5766 stop
5767 ENDIF
5768 IF(mstp(122).GE.1) THEN
5769 WRITE(mstu(11),6000)
5770 WRITE(mstu(11),6100)
5771 DO 470 isub=1,500
5772 IF(msub(isub).NE.1.AND.isub.NE.96) GOTO 470
5773 IF(isub.EQ.96.AND.mint(50).EQ.0) GOTO 470
5774 IF(isub.EQ.96.AND.msub(95).NE.1.AND.mstp(81).LE.0) GOTO 470
5775 IF(isub.EQ.96.AND.mint(49).EQ.0.AND.mstp(131).EQ.0) GOTO 470
5776 IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13
5777 & .OR.isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) GOTO 470
5778 WRITE(mstu(11),6200) isub,proc(isub),xsec(isub,1)
5779 470 CONTINUE
5780 WRITE(mstu(11),6300)
5781 ENDIF
5782
5783C...Format statements for maximization results.
5784 5000 FORMAT(/1x,'Coefficient optimization and maximum search for ',
5785 &'subprocess no',i4/1x,'Coefficient modes tau',10x,'y*',9x,
5786 &'cth',9x,'tau''',7x,'sigma')
5787 5100 FORMAT(1x,'Warning: requested subprocess ',i3,' has no allowed ',
5788 &'phase space.'/1x,'Process switched off!')
5789 5200 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,d12.4)
5790 5300 FORMAT(1x,'Warning: requested subprocess ',i3,' has vanishing ',
5791 &'cross-section.'/1x,'Process switched off!')
5792 5400 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)
5793 5500 FORMAT(1x,1p,8d11.3)
5794 5600 FORMAT(1x,'Result for ',a4,':',7f9.4)
5795 5700 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',
5796 &'MOD MOV VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')
5797 5800 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,d12.4)
5798 5900 FORMAT(1x,'Error: no requested process has non-vanishing ',
5799 &'cross-section.'/1x,'Execution stopped!')
5800 6000 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',
5801 &'cross-section maximum search',1x,8('*'))
5802 6100 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I ISUB ',
5803 &'Subprocess name',15x,'I Maximum value I'/11x,'I',38x,'I',
5804 &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')
5805 6200 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,d12.4,3x,'I')
5806 6300 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))
5807
5808 RETURN
5809 END
5810
5811C*********************************************************************
5812
5813C...PYPILE
5814C...Initializes multiplicity distribution and selects mutliplicity
5815C...of pileup events, i.e. several events occuring at the same
5816C...beam crossing.
5817
5818 SUBROUTINE pypile(MPILE)
5819
5820C...Double precision and integer declarations.
5821 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5822 IMPLICIT INTEGER(I-N)
5823 INTEGER PYK,PYCHGE,PYCOMP
5824C...Commonblocks.
5825 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5826 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5827 common/pyint1/mint(400),vint(400)
5828 common/pyint7/sigt(0:6,0:6,0:5)
5829 SAVE /pydat1/,/pypars/,/pyint1/,/pyint7/
5830C...Local arrays and saved variables.
5831 dimension wti(0:200)
5832 SAVE imin,imax,wti,wts
5833
5834C...Sum of allowed cross-sections for pileup events.
5835 IF(mpile.EQ.1) THEN
5836 vint(131)=sigt(0,0,5)
5837 IF(mstp(132).GE.2) vint(131)=vint(131)+sigt(0,0,4)
5838 IF(mstp(132).GE.3) vint(131)=vint(131)+sigt(0,0,2)+sigt(0,0,3)
5839 IF(mstp(132).GE.4) vint(131)=vint(131)+sigt(0,0,1)
5840 IF(mstp(133).LE.0) RETURN
5841
5842C...Initialize multiplicity distribution at maximum.
5843 xnave=vint(131)*parp(131)
5844 IF(xnave.GT.120d0) WRITE(mstu(11),5000) xnave
5845 inave=max(1,min(200,nint(xnave)))
5846 wti(inave)=1d0
5847 wts=wti(inave)
5848 wtn=wti(inave)*inave
5849
5850C...Find shape of multiplicity distribution below maximum.
5851 imin=inave
5852 DO 100 i=inave-1,1,-1
5853 IF(mstp(133).EQ.1) wti(i)=wti(i+1)*(i+1)/xnave
5854 IF(mstp(133).GE.2) wti(i)=wti(i+1)*i/xnave
5855 IF(wti(i).LT.1d-6) GOTO 110
5856 wts=wts+wti(i)
5857 wtn=wtn+wti(i)*i
5858 imin=i
5859 100 CONTINUE
5860
5861C...Find shape of multiplicity distribution above maximum.
5862 110 imax=inave
5863 DO 120 i=inave+1,200
5864 IF(mstp(133).EQ.1) wti(i)=wti(i-1)*xnave/i
5865 IF(mstp(133).GE.2) wti(i)=wti(i-1)*xnave/(i-1)
5866 IF(wti(i).LT.1d-6) GOTO 130
5867 wts=wts+wti(i)
5868 wtn=wtn+wti(i)*i
5869 imax=i
5870 120 CONTINUE
5871 130 vint(132)=xnave
5872 vint(133)=wtn/wts
5873 IF(mstp(133).EQ.1.AND.imin.EQ.1) vint(134)=
5874 & wts/(wts+wti(1)/xnave)
5875 IF(mstp(133).EQ.1.AND.imin.GT.1) vint(134)=1d0
5876 IF(mstp(133).GE.2) vint(134)=xnave
5877
5878C...Pick multiplicity of pileup events.
5879 ELSE
5880 IF(mstp(133).LE.0) THEN
5881 mint(81)=max(1,mstp(134))
5882 ELSE
5883 wtr=wts*pyr(0)
5884 DO 140 i=imin,imax
5885 mint(81)=i
5886 wtr=wtr-wti(i)
5887 IF(wtr.LE.0d0) GOTO 150
5888 140 CONTINUE
5889 150 CONTINUE
5890 ENDIF
5891 ENDIF
5892
5893C...Format statement for error message.
5894 5000 FORMAT(1x,'Warning: requested average number of events per bunch',
5895 &'crossing too large, ',1p,d12.4)
5896
5897 RETURN
5898 END
5899
5900C*********************************************************************
5901
5902C...PYSAVE
5903C...Saves and restores parameter and cross section values for the
5904C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alnternatives.
5905C...Also makes random choice between alternatives.
5906
5907 SUBROUTINE pysave(ISAVE,IGA)
5908
5909C...Double precision and integer declarations.
5910 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5911 IMPLICIT INTEGER(I-N)
5912 INTEGER PYK,PYCHGE,PYCOMP
5913C...Commonblocks.
5914 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5915 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5916 common/pyint1/mint(400),vint(400)
5917 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5918 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
5919 common/pyint7/sigt(0:6,0:6,0:5)
5920 SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint5/,/pyint7/
5921C...Local arrays and saved variables.
5922 dimension ncp(15),nsubcp(15,20),msubcp(15,20),coefcp(15,20,20),
5923 &ngencp(15,0:20,3),xseccp(15,0:20,3),sigtcp(15,0:6,0:6,0:5),
5924 &intcp(15,20),recp(15,20)
5925 SAVE ncp,nsubcp,msubcp,coefcp,ngencp,xseccp,sigtcp,intcp,recp
5926
5927C...Save list of subprocesses and cross-section information.
5928 IF(isave.EQ.1) THEN
5929 icp=0
5930 DO 120 i=1,500
5931 IF(msub(i).EQ.0.AND.i.NE.96.AND.i.NE.97) GOTO 120
5932 icp=icp+1
5933 nsubcp(iga,icp)=i
5934 msubcp(iga,icp)=msub(i)
5935 DO 100 j=1,20
5936 coefcp(iga,icp,j)=coef(i,j)
5937 100 CONTINUE
5938 DO 110 j=1,3
5939 ngencp(iga,icp,j)=ngen(i,j)
5940 xseccp(iga,icp,j)=xsec(i,j)
5941 110 CONTINUE
5942 120 CONTINUE
5943 ncp(iga)=icp
5944 DO 130 j=1,3
5945 ngencp(iga,0,j)=ngen(0,j)
5946 xseccp(iga,0,j)=xsec(0,j)
5947 130 CONTINUE
5948 DO 136 i1=0,6
5949 DO 134 i2=0,6
5950 DO 132 j=0,5
5951 sigtcp(iga,i1,i2,j)=sigt(i1,i2,j)
5952 132 CONTINUE
5953 134 CONTINUE
5954 136 CONTINUE
5955
5956C...Save various common process variables.
5957 DO 140 j=1,10
5958 intcp(iga,j)=mint(40+j)
5959 140 CONTINUE
5960 intcp(iga,11)=mint(101)
5961 intcp(iga,12)=mint(102)
5962 intcp(iga,13)=mint(107)
5963 intcp(iga,14)=mint(108)
5964 intcp(iga,15)=mint(123)
5965 recp(iga,1)=ckin(3)
5966 recp(iga,2)=vint(318)
5967
5968C...Save cross-section information only.
5969 ELSEIF(isave.EQ.2) THEN
5970 DO 160 icp=1,ncp(iga)
5971 i=nsubcp(iga,icp)
5972 DO 150 j=1,3
5973 ngencp(iga,icp,j)=ngen(i,j)
5974 xseccp(iga,icp,j)=xsec(i,j)
5975 150 CONTINUE
5976 160 CONTINUE
5977 DO 170 j=1,3
5978 ngencp(iga,0,j)=ngen(0,j)
5979 xseccp(iga,0,j)=xsec(0,j)
5980 170 CONTINUE
5981
5982C...Choose between allowed alternatives.
5983 ELSEIF(isave.EQ.3.OR.isave.EQ.4) THEN
5984 IF(isave.EQ.4) THEN
5985 xsumcp=0d0
5986 DO 180 ig=1,mint(121)
5987 xsumcp=xsumcp+xseccp(ig,0,1)
5988 180 CONTINUE
5989 xsumcp=xsumcp*pyr(0)
5990 DO 190 ig=1,mint(121)
5991 iga=ig
5992 xsumcp=xsumcp-xseccp(ig,0,1)
5993 IF(xsumcp.LE.0d0) GOTO 200
5994 190 CONTINUE
5995 200 CONTINUE
5996 ENDIF
5997
5998C...Restore cross-section information.
5999 DO 210 i=1,500
6000 msub(i)=0
6001 210 CONTINUE
6002 DO 240 icp=1,ncp(iga)
6003 i=nsubcp(iga,icp)
6004 msub(i)=msubcp(iga,icp)
6005 DO 220 j=1,20
6006 coef(i,j)=coefcp(iga,icp,j)
6007 220 CONTINUE
6008 DO 230 j=1,3
6009 ngen(i,j)=ngencp(iga,icp,j)
6010 xsec(i,j)=xseccp(iga,icp,j)
6011 230 CONTINUE
6012 240 CONTINUE
6013 DO 250 j=1,3
6014 ngen(0,j)=ngencp(iga,0,j)
6015 xsec(0,j)=xseccp(iga,0,j)
6016 250 CONTINUE
6017 DO 256 i1=0,6
6018 DO 254 i2=0,6
6019 DO 252 j=0,5
6020 sigt(i1,i2,j)=sigtcp(iga,i1,i2,j)
6021 252 CONTINUE
6022 254 CONTINUE
6023 256 CONTINUE
6024
6025C...Restore various common process variables.
6026 DO 260 j=1,10
6027 mint(40+j)=intcp(iga,j)
6028 260 CONTINUE
6029 mint(101)=intcp(iga,11)
6030 mint(102)=intcp(iga,12)
6031 mint(107)=intcp(iga,13)
6032 mint(108)=intcp(iga,14)
6033 mint(123)=intcp(iga,15)
6034 ckin(3)=recp(iga,1)
6035 ckin(1)=2d0*ckin(3)
6036 vint(318)=recp(iga,2)
6037
6038C...Sum up cross-section info (for PYSTAT).
6039 ELSEIF(isave.EQ.5) THEN
6040 DO 270 i=1,500
6041 msub(i)=0
6042 ngen(i,1)=0
6043 ngen(i,3)=0
6044 xsec(i,3)=0d0
6045 270 CONTINUE
6046 ngen(0,1)=0
6047 ngen(0,2)=0
6048 ngen(0,3)=0
6049 xsec(0,3)=0
6050 DO 290 ig=1,mint(121)
6051 DO 280 icp=1,ncp(ig)
6052 i=nsubcp(ig,icp)
6053 IF(msubcp(ig,icp).EQ.1) msub(i)=1
6054 ngen(i,1)=ngen(i,1)+ngencp(ig,icp,1)
6055 ngen(i,3)=ngen(i,3)+ngencp(ig,icp,3)
6056 xsec(i,3)=xsec(i,3)+xseccp(ig,icp,3)
6057 280 CONTINUE
6058 ngen(0,1)=ngen(0,1)+ngencp(ig,0,1)
6059 ngen(0,2)=ngen(0,2)+ngencp(ig,0,2)
6060 ngen(0,3)=ngen(0,3)+ngencp(ig,0,3)
6061 xsec(0,3)=xsec(0,3)+xseccp(ig,0,3)
6062 290 CONTINUE
6063 ENDIF
6064
6065 RETURN
6066 END
6067
6068C*********************************************************************
6069
6070C...PYGAGA
6071C...For lepton beams it gives photon-hadron or photon-photon systems
6072C...to be treated with the ordinary machinery and combines this with a
6073C...description of the lepton -> lepton + photon branching.
6074
6075 SUBROUTINE pygaga(IGAGA,WTGAGA)
6076
6077C...Double precision and integer declarations.
6078 IMPLICIT DOUBLE PRECISION(a-h, o-z)
6079 IMPLICIT INTEGER(I-N)
6080 INTEGER PYK,PYCHGE,PYCOMP
6081C...Commonblocks.
6082 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
6083 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6084 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6085 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
6086 common/pypars/mstp(200),parp(200),msti(200),pari(200)
6087 common/pyint1/mint(400),vint(400)
6088 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
6089 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
6090 &/pyint5/
6091C...Local variables and data statement.
6092 dimension pms(2),xmin(2),xmax(2),q2min(2),q2max(2),pmc(3),
6093 &x(2),q2(2),y(2),theta(2),phi(2),pt(2),beta(3)
6094 SAVE pms,xmin,xmax,q2min,q2max,pmc,x,q2,theta,phi,pt,w2min
6095 DATA eps/1d-4/
6096
6097C...Initialize generation of photons inside leptons.
6098 IF(igaga.EQ.1) THEN
6099
6100C...Save quantities on incoming lepton system.
6101 vint(301)=vint(1)
6102 vint(302)=vint(2)
6103 pms(1)=vint(303)**2
6104 IF(mint(141).EQ.0) pms(1)=sign(vint(3)**2,vint(3))
6105 pms(2)=vint(304)**2
6106 IF(mint(142).EQ.0) pms(2)=sign(vint(4)**2,vint(4))
6107 pmc(3)=vint(302)-pms(1)-pms(2)
6108 w2min=max(ckin(77),2d0*ckin(3),2d0*ckin(5))**2
6109
6110C...Calculate range of x and Q2 values allowed in generation.
6111 DO 100 i=1,2
6112 pmc(i)=vint(302)+pms(i)-pms(3-i)
6113 IF(mint(140+i).NE.0) THEN
6114 xmin(i)=max(ckin(59+2*i),eps)
6115 xmax(i)=min(ckin(60+2*i),1d0-2d0*vint(301)*sqrt(pms(i))/
6116 & pmc(i),1d0-eps)
6117 ymin=max(ckin(71+2*i),eps)
6118 ymax=min(ckin(72+2*i),1d0-eps)
6119 IF(ckin(64+2*i).GT.0d0) xmin(i)=max(xmin(i),
6120 & (ymin*pmc(3)-ckin(64+2*i))/pmc(i))
6121 xmax(i)=min(xmax(i),(ymax*pmc(3)-ckin(63+2*i))/pmc(i))
6122 themin=max(ckin(67+2*i),0d0)
6123 themax=min(ckin(68+2*i),paru(1))
6124 IF(ckin(68+2*i).LT.0d0) themax=paru(1)
6125 q2min(i)=max(ckin(63+2*i),xmin(i)**2*pms(i)/(1d0-xmin(i))+
6126 & ((1d0-xmax(i))*(vint(302)-2d0*pms(3-i))-
6127 & 2d0*pms(i)/(1d0-xmax(i)))*sin(themin/2d0)**2,0d0)
6128 q2max(i)=xmax(i)**2*pms(i)/(1d0-xmax(i))+
6129 & ((1d0-xmin(i))*(vint(302)-2d0*pms(3-i))-
6130 & 2d0*pms(i)/(1d0-xmin(i)))*sin(themax/2d0)**2
6131 IF(ckin(64+2*i).GT.0d0) q2max(i)=min(ckin(64+2*i),q2max(i))
6132C...W limits when lepton on one side only.
6133 IF(mint(143-i).EQ.0) THEN
6134 xmin(i)=max(xmin(i),(w2min-pms(3-i))/pmc(i))
6135 IF(ckin(78).GT.0d0) xmax(i)=min(xmax(i),
6136 & (ckin(78)**2-pms(3-i))/pmc(i))
6137 ENDIF
6138 ENDIF
6139 100 CONTINUE
6140
6141C...W limits when lepton on both sides.
6142 IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
6143 IF(ckin(78).GT.0d0) xmax(1)=min(xmax(1),
6144 & (ckin(78)**2+pmc(3)-pmc(2)*xmin(2))/pmc(1))
6145 IF(ckin(78).GT.0d0) xmax(2)=min(xmax(2),
6146 & (ckin(78)**2+pmc(3)-pmc(1)*xmin(1))/pmc(2))
6147 IF(iabs(mint(141)).NE.iabs(mint(142))) THEN
6148 xmin(1)=max(xmin(1),(pms(1)-pms(2)+vint(302)*(w2min-
6149 & pms(1)-pms(2))/(pmc(2)*xmax(2)+pms(1)-pms(2)))/pmc(1))
6150 xmin(2)=max(xmin(2),(pms(2)-pms(1)+vint(302)*(w2min-
6151 & pms(1)-pms(2))/(pmc(1)*xmax(1)+pms(2)-pms(1)))/pmc(2))
6152 ELSE
6153 xmin(1)=max(xmin(1),w2min/(vint(302)*xmax(2)))
6154 xmin(2)=max(xmin(2),w2min/(vint(302)*xmax(1)))
6155 ENDIF
6156 ENDIF
6157
6158C...Q2 and W values and photon flux weight factors for initialization.
6159 ELSEIF(igaga.EQ.2) THEN
6160 isub=mint(1)
6161 mint(15)=0
6162 mint(16)=0
6163
6164C...W value for photon on one or both sides, and for processes
6165C...with gamma-gamma cross section peaked at small shat.
6166 IF(mint(141).NE.0.AND.mint(142).EQ.0) THEN
6167 vint(2)=vint(302)+pms(1)-pmc(1)*(1d0-xmax(1))
6168 ELSEIF(mint(141).EQ.0.AND.mint(142).NE.0) THEN
6169 vint(2)=vint(302)+pms(2)-pmc(2)*(1d0-xmax(2))
6170 ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
6171 vint(2)=max(ckin(77)**2,12d0*max(ckin(3),ckin(5))**2)
6172 IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
6173 ELSE
6174 vint(2)=xmax(1)*xmax(2)*vint(302)
6175 IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
6176 ENDIF
6177 vint(1)=sqrt(max(0d0,vint(2)))
6178
6179C...Upper estimate of photon flux weight factor.
6180C...Initialization Q2 scale. Flag incoming unresolved photon.
6181 wtgaga=1d0
6182 DO 110 i=1,2
6183 IF(mint(140+i).NE.0) THEN
6184 wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
6185 & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
6186 IF(isub.EQ.99.AND.mint(106+i).EQ.4.AND.mint(109-i).EQ.3)
6187 & THEN
6188 q2init=5d0+q2min(3-i)
6189 ELSEIF(isub.EQ.99.AND.mint(106+i).EQ.4) THEN
6190 q2init=pmas(pycomp(113),1)**2+q2min(3-i)
6191 ELSEIF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
6192 q2init=max(ckin(1),2d0*ckin(3),2d0*ckin(5))**2/3d0
6193 ELSEIF((isub.EQ.138.AND.i.EQ.2).OR.
6194 & (isub.EQ.139.AND.i.EQ.1)) THEN
6195 q2init=vint(2)/3d0
6196 ELSEIF(isub.EQ.140) THEN
6197 q2init=vint(2)/2d0
6198 ELSE
6199 q2init=q2min(i)
6200 ENDIF
6201 vint(2+i)=-sqrt(max(q2min(i),min(q2max(i),q2init)))
6202 IF(mstp(14).EQ.0.OR.(isub.GE.131.AND.isub.LE.140))
6203 & mint(14+i)=22
6204 vint(306+i)=vint(2+i)**2
6205 ENDIF
6206 110 CONTINUE
6207 vint(320)=wtgaga
6208
6209C...Update pTmin and cross section information.
6210 IF(mstp(82).LE.1) THEN
6211 ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
6212 ELSE
6213 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
6214 ENDIF
6215 vint(149)=4d0*ptmn**2/vint(2)
6216 vint(154)=ptmn
6217 CALL pyxtot
6218 vint(318)=vint(317)
6219
6220C...Generate photons inside leptons and
6221C...calculate photon flux weight factors.
6222 ELSEIF(igaga.EQ.3) THEN
6223 isub=mint(1)
6224 mint(15)=0
6225 mint(16)=0
6226
6227C...Generate phase space point and check against cuts.
6228 loop=0
6229 120 loop=loop+1
6230 DO 130 i=1,2
6231 IF(mint(140+i).NE.0) THEN
6232C...Pick x and Q2
6233 x(i)=xmin(i)*(xmax(i)/xmin(i))**pyr(0)
6234 q2(i)=q2min(i)*(q2max(i)/q2min(i))**pyr(0)
6235C...Cuts on internal consistency in x and Q2.
6236 IF(q2(i).LT.x(i)**2*pms(i)/(1d0-x(i))) GOTO 120
6237 IF(q2(i).GT.(1d0-x(i))*(vint(302)-2d0*pms(3-i))-
6238 & (2d0-x(i)**2)*pms(i)/(1d0-x(i))) GOTO 120
6239C...Cuts on y and theta.
6240 y(i)=(pmc(i)*x(i)+q2(i))/pmc(3)
6241 IF(y(i).LT.ckin(71+2*i).OR.y(i).GT.ckin(72+2*i)) GOTO 120
6242 rat=((1d0-x(i))*q2(i)-x(i)**2*pms(i))/
6243 & ((1d0-x(i))**2*(vint(302)-2d0*pms(3-i)-2d0*pms(i)))
6244 theta(i)=2d0*asin(sqrt(max(0d0,min(1d0,rat))))
6245 IF(theta(i).LT.ckin(67+2*i)) GOTO 120
6246 IF(ckin(68+2*i).GT.0d0.AND.theta(i).GT.ckin(68+2*i))
6247 & GOTO 120
6248
6249C...Phi angle isotropic. Reconstruct pT.
6250 phi(i)=paru(2)*pyr(0)
6251 pt(i)=sqrt(((1d0-x(i))*pmc(i))**2/(4d0*vint(302))-
6252 & pms(i))*sin(theta(i))
6253
6254C...Store info on variables selected, for documentation purposes.
6255 vint(2+i)=-sqrt(q2(i))
6256 vint(304+i)=x(i)
6257 vint(306+i)=q2(i)
6258 vint(308+i)=y(i)
6259 vint(310+i)=theta(i)
6260 vint(312+i)=phi(i)
6261 ELSE
6262 vint(304+i)=1d0
6263 vint(306+i)=0d0
6264 vint(308+i)=1d0
6265 vint(310+i)=0d0
6266 vint(312+i)=0d0
6267 ENDIF
6268 130 CONTINUE
6269
6270C...Cut on W combines info from two sides.
6271 IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
6272 w2=-q2(1)-q2(2)+0.5d0*x(1)*pmc(1)*x(2)*pmc(2)/vint(302)-
6273 & 2d0*pt(1)*pt(2)*cos(phi(1)-phi(2))+2d0*
6274 & sqrt((0.5d0*x(1)*pmc(1)/vint(301))**2+q2(1)-pt(1)**2)*
6275 & sqrt((0.5d0*x(2)*pmc(2)/vint(301))**2+q2(2)-pt(2)**2)
6276 IF(w2.LT.w2min) GOTO 120
6277 IF(ckin(78).GT.0d0.AND.w2.GT.ckin(78)**2) GOTO 120
6278 pms1=-q2(1)
6279 pms2=-q2(2)
6280 ELSEIF(mint(141).NE.0) THEN
6281 w2=(vint(302)+pms(1))*x(1)+pms(2)*(1d0-x(1))
6282 pms1=-q2(1)
6283 pms2=pms(2)
6284 ELSEIF(mint(142).NE.0) THEN
6285 w2=(vint(302)+pms(2))*x(2)+pms(1)*(1d0-x(2))
6286 pms1=pms(1)
6287 pms2=-q2(2)
6288 ENDIF
6289
6290C...Store kinematics info for photon(s) in subsystem cm frame.
6291 vint(2)=w2
6292 vint(1)=sqrt(w2)
6293 vint(291)=0d0
6294 vint(292)=0d0
6295 vint(293)=0.5d0*sqrt((w2-pms1-pms2)**2-4d0*pms1*pms2)/vint(1)
6296 vint(294)=0.5d0*(w2+pms1-pms2)/vint(1)
6297 vint(295)=sign(sqrt(abs(pms1)),pms1)
6298 vint(296)=0d0
6299 vint(297)=0d0
6300 vint(298)=-vint(293)
6301 vint(299)=0.5d0*(w2+pms2-pms1)/vint(1)
6302 vint(300)=sign(sqrt(abs(pms2)),pms2)
6303
6304C...Assign weight for photon flux; different for transverse and
6305C...longitudinal photons. Flag incoming unresolved photon.
6306 wtgaga=1d0
6307 DO 140 i=1,2
6308 IF(mint(140+i).NE.0) THEN
6309 wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
6310 & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
6311 IF(mstp(16).EQ.0) THEN
6312 xy=x(i)
6313 ELSE
6314 wtgaga=wtgaga*x(i)/y(i)
6315 xy=y(i)
6316 ENDIF
6317 IF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
6318 wtgaga=wtgaga*(1d0-xy)
6319 ELSEIF(i.EQ.1.AND.(isub.EQ.139.OR.isub.EQ.140)) THEN
6320 wtgaga=wtgaga*(1d0-xy)
6321 ELSEIF(i.EQ.2.AND.(isub.EQ.138.OR.isub.EQ.140)) THEN
6322 wtgaga=wtgaga*(1d0-xy)
6323 ELSE
6324 wtgaga=wtgaga*(0.5d0*(1d0+(1d0-xy)**2)-
6325 & pms(i)*xy**2/q2(i))
6326 ENDIF
6327 IF(mint(106+i).EQ.0) mint(14+i)=22
6328 ENDIF
6329 140 CONTINUE
6330 vint(319)=wtgaga
6331 mint(143)=loop
6332
6333C...Update pTmin and cross section information.
6334 IF(mstp(82).LE.1) THEN
6335 ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
6336 ELSE
6337 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
6338 ENDIF
6339 vint(149)=4d0*ptmn**2/vint(2)
6340 vint(154)=ptmn
6341 CALL pyxtot
6342
6343C...Reconstruct kinematics of photons inside leptons.
6344 ELSEIF(igaga.EQ.4) THEN
6345
6346C...Make place for incoming particles and scattered leptons.
6347 move=3
6348 IF(mint(141).NE.0.AND.mint(142).NE.0) move=4
6349 mint(4)=mint(4)+move
6350 DO 160 i=mint(84)-move,mint(83)+1,-1
6351 IF(k(i,1).EQ.21) THEN
6352 DO 150 j=1,5
6353 k(i+move,j)=k(i,j)
6354 p(i+move,j)=p(i,j)
6355 v(i+move,j)=v(i,j)
6356 150 CONTINUE
6357 IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
6358 & k(i+move,3)=k(i,3)+move
6359 IF(k(i,4).GT.mint(83).AND.k(i,4).LE.mint(84))
6360 & k(i+move,4)=k(i,4)+move
6361 IF(k(i,5).GT.mint(83).AND.k(i,5).LE.mint(84))
6362 & k(i+move,5)=k(i,5)+move
6363 ENDIF
6364 160 CONTINUE
6365 DO 170 i=mint(84)+1,n
6366 IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
6367 & k(i,3)=k(i,3)+move
6368 170 CONTINUE
6369
6370C...Fill in incoming particles.
6371 DO 190 i=mint(83)+1,mint(83)+move
6372 DO 180 j=1,5
6373 k(i,j)=0
6374 p(i,j)=0d0
6375 v(i,j)=0d0
6376 180 CONTINUE
6377 190 CONTINUE
6378 DO 200 i=1,2
6379 k(mint(83)+i,1)=21
6380 IF(mint(140+i).NE.0) THEN
6381 k(mint(83)+i,2)=mint(140+i)
6382 p(mint(83)+i,5)=vint(302+i)
6383 ELSE
6384 k(mint(83)+i,2)=mint(10+i)
6385 p(mint(83)+i,5)=vint(2+i)
6386 ENDIF
6387 p(mint(83)+i,3)=0.5d0*sqrt((pmc(3)**2-4d0*pms(1)*pms(2))/
6388 & vint(302))*(-1d0)**(i+1)
6389 p(mint(83)+i,4)=0.5d0*pmc(i)/vint(301)
6390 200 CONTINUE
6391
6392C...New mother-daughter relations in documentation section.
6393 IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
6394 k(mint(83)+1,4)=mint(83)+3
6395 k(mint(83)+1,5)=mint(83)+5
6396 k(mint(83)+2,4)=mint(83)+4
6397 k(mint(83)+2,5)=mint(83)+6
6398 k(mint(83)+3,3)=mint(83)+1
6399 k(mint(83)+5,3)=mint(83)+1
6400 k(mint(83)+4,3)=mint(83)+2
6401 k(mint(83)+6,3)=mint(83)+2
6402 ELSEIF(mint(141).NE.0) THEN
6403 k(mint(83)+1,4)=mint(83)+3
6404 k(mint(83)+1,5)=mint(83)+4
6405 k(mint(83)+2,4)=mint(83)+5
6406 k(mint(83)+3,3)=mint(83)+1
6407 k(mint(83)+4,3)=mint(83)+1
6408 k(mint(83)+5,3)=mint(83)+2
6409 ELSEIF(mint(142).NE.0) THEN
6410 k(mint(83)+1,4)=mint(83)+4
6411 k(mint(83)+2,4)=mint(83)+3
6412 k(mint(83)+2,5)=mint(83)+5
6413 k(mint(83)+3,3)=mint(83)+2
6414 k(mint(83)+4,3)=mint(83)+1
6415 k(mint(83)+5,3)=mint(83)+2
6416 ENDIF
6417
6418C...Fill scattered lepton(s).
6419 DO 210 i=1,2
6420 IF(mint(140+i).NE.0) THEN
6421 lsc=mint(83)+min(i+2,move)
6422 k(lsc,1)=21
6423 k(lsc,2)=mint(140+i)
6424 p(lsc,1)=pt(i)*cos(phi(i))
6425 p(lsc,2)=pt(i)*sin(phi(i))
6426 p(lsc,4)=(1d0-x(i))*p(mint(83)+i,4)
6427 p(lsc,3)=sqrt(p(lsc,4)**2-pms(i))*cos(theta(i))*
6428 & (-1d0)**(i-1)
6429 p(lsc,5)=vint(302+i)
6430 ENDIF
6431 210 CONTINUE
6432
6433C...Find incoming four-vectors to subprocess.
6434 k(n+1,1)=21
6435 IF(mint(141).NE.0) THEN
6436 DO 220 j=1,4
6437 p(n+1,j)=p(mint(83)+1,j)-p(mint(83)+3,j)
6438 220 CONTINUE
6439 ELSE
6440 DO 230 j=1,4
6441 p(n+1,j)=p(mint(83)+1,j)
6442 230 CONTINUE
6443 ENDIF
6444 k(n+2,1)=21
6445 IF(mint(142).NE.0) THEN
6446 DO 240 j=1,4
6447 p(n+2,j)=p(mint(83)+2,j)-p(mint(83)+move,j)
6448 240 CONTINUE
6449 ELSE
6450 DO 250 j=1,4
6451 p(n+2,j)=p(mint(83)+2,j)
6452 250 CONTINUE
6453 ENDIF
6454
6455C...Define boost and rotation between hadronic subsystem and
6456C...collision rest frame; boost hadronic subsystem to this frame.
6457 DO 260 j=1,3
6458 beta(j)=(p(n+1,j)+p(n+2,j))/(p(n+1,4)+p(n+2,4))
6459 260 CONTINUE
6460 CALL pyrobo(n+1,n+2,0d0,0d0,-beta(1),-beta(2),-beta(3))
6461 bphi=pyangl(p(n+1,1),p(n+1,2))
6462 CALL pyrobo(n+1,n+2,0d0,-bphi,0d0,0d0,0d0)
6463 btheta=pyangl(p(n+1,3),p(n+1,1))
6464 CALL pyrobo(mint(83)+move+1,n,btheta,bphi,beta(1),beta(2),
6465 & beta(3))
6466
6467C...Add on scattered leptons to final state.
6468 DO 280 i=1,2
6469 IF(mint(140+i).NE.0) THEN
6470 lsc=mint(83)+min(i+2,move)
6471 n=n+1
6472 DO 270 j=1,5
6473 k(n,j)=k(lsc,j)
6474 p(n,j)=p(lsc,j)
6475 v(n,j)=v(lsc,j)
6476 270 CONTINUE
6477 k(n,1)=1
6478 k(n,3)=lsc
6479 ENDIF
6480 280 CONTINUE
6481 ENDIF
6482
6483 RETURN
6484 END
6485
6486C*********************************************************************
6487
6488C...PYRAND
6489C...Generates quantities characterizing the high-pT scattering at the
6490C...parton level according to the matrix elements. Chooses incoming,
6491C...reacting partons, their momentum fractions and one of the possible
6492C...subprocesses.
6493
6494 SUBROUTINE pyrand
6495
6496C...Double precision and integer declarations.
6497 IMPLICIT DOUBLE PRECISION(a-h, o-z)
6498 IMPLICIT INTEGER(I-N)
6499 INTEGER PYK,PYCHGE,PYCOMP
6500C...Parameter statement to help give large particle numbers.
6501 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
6502C...Commonblocks.
6503 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6504 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6505 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
6506 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
6507 common/pypars/mstp(200),parp(200),msti(200),pari(200)
6508 common/pyint1/mint(400),vint(400)
6509 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
6510 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
6511 common/pyint4/mwid(500),wids(500,5)
6512 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
6513 common/pyint7/sigt(0:6,0:6,0:5)
6514 common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
6515 common/pymssm/imss(0:99),rmss(0:99)
6516 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
6517 &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,/pyuppr/,/pymssm/
6518C...Local arrays.
6519 dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)
6520
6521C...Parameters and data used in elastic/diffractive treatment.
6522 DATA eps/0.0808d0/, alp/0.25d0/, cres/2d0/, pmrc/1.062d0/,
6523 &smp/0.880d0/, bhad/2.3d0,1.4d0,1.4d0,0.23d0/
6524
6525C...Initial values, specifically for (first) semihard interaction.
6526 mint(10)=0
6527 mint(17)=0
6528 mint(18)=0
6529 vint(143)=1d0
6530 vint(144)=1d0
6531 vint(157)=0d0
6532 vint(158)=0d0
6533 mfail=0
6534 IF(mstp(171).EQ.1.AND.mstp(172).EQ.2) mfail=1
6535 isub=0
6536 loop=0
6537 100 loop=loop+1
6538 mint(51)=0
6539 mint(143)=1
6540
6541C...Start by assuming incoming photon is entering subprocess.
6542 IF(mint(11).EQ.22) THEN
6543 mint(15)=22
6544 vint(307)=vint(3)**2
6545 ENDIF
6546 IF(mint(12).EQ.22) THEN
6547 mint(16)=22
6548 vint(308)=vint(4)**2
6549 ENDIF
6550 mint(103)=mint(11)
6551 mint(104)=mint(12)
6552
6553C...Choice of process type - first event of pileup.
6554 inmult=0
6555 IF(mint(82).EQ.1.AND.(isub.LE.90.OR.isub.GT.96)) THEN
6556
6557C...For gamma-p or gamma-gamma first pick between alternatives.
6558 iga=0
6559 IF(mint(121).GT.1) CALL pysave(4,iga)
6560 mint(122)=iga
6561
6562C...For real gamma + gamma with different nature, flip at random.
6563 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
6564 & mstp(14).LE.10.AND.pyr(0).GT.0.5d0) THEN
6565 mintsv=mint(41)
6566 mint(41)=mint(42)
6567 mint(42)=mintsv
6568 mintsv=mint(45)
6569 mint(45)=mint(46)
6570 mint(46)=mintsv
6571 mintsv=mint(107)
6572 mint(107)=mint(108)
6573 mint(108)=mintsv
6574 IF(mint(47).EQ.2.OR.mint(47).EQ.3) mint(47)=5-mint(47)
6575 ENDIF
6576
6577C...Pick process type.
6578 rsub=xsec(0,1)*pyr(0)
6579 DO 110 i=1,500
6580 IF(msub(i).NE.1) GOTO 110
6581 isub=i
6582 rsub=rsub-xsec(i,1)
6583 IF(rsub.LE.0d0) GOTO 120
6584 110 CONTINUE
6585 120 IF(isub.EQ.95) isub=96
6586 IF(isub.EQ.96) inmult=1
6587
6588C...Choice of inclusive process type - pileup events.
6589 ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN
6590 rsub=vint(131)*pyr(0)
6591 isub=96
6592 IF(rsub.GT.sigt(0,0,5)) isub=94
6593 IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)) isub=93
6594 IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)) isub=92
6595 IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)+sigt(0,0,2))
6596 & isub=91
6597 IF(isub.EQ.96) inmult=1
6598 ENDIF
6599
6600C...Choice of photon energy and flux factor inside lepton.
6601 IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
6602 CALL pygaga(3,wtgaga)
6603 IF(isub.GE.131.AND.isub.LE.140) THEN
6604 ckin(3)=max(vint(285),vint(154))
6605 ckin(1)=2d0*ckin(3)
6606 ENDIF
6607C...When necessary set direct/resolved photon by hand.
6608 ELSEIF(mint(15).EQ.22.OR.mint(16).EQ.22) THEN
6609 IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
6610 IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
6611 ENDIF
6612
6613C...Restrict direct*resolved processes to pTmin >= Q,
6614C...to avoid doublecounting with DIS.
6615 IF(mstp(18).EQ.3.AND.isub.GE.131.AND.isub.LE.136) THEN
6616 IF(mint(15).EQ.22) THEN
6617 ckin(3)=max(vint(285),vint(154),abs(vint(3)))
6618 ELSE
6619 ckin(3)=max(vint(285),vint(154),abs(vint(4)))
6620 ENDIF
6621 ckin(1)=2d0*ckin(3)
6622 ENDIF
6623
6624C...Set up for multiple interactions.
6625 IF(inmult.EQ.1) CALL pymult(2)
6626
6627C...Loopback point for minimum bias in photon physics.
6628 loop2=0
6629 125 loop2=loop2+1
6630 IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+mint(143)
6631 IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+mint(143)
6632 IF(isub.EQ.96.AND.loop2.EQ.1.AND.mint(82).EQ.1)
6633 &ngen(97,1)=ngen(97,1)+mint(143)
6634 mint(1)=isub
6635 istsb=iset(isub)
6636
6637C...Random choice of flavour for some SUSY processes.
6638 IF(isub.GE.201.AND.isub.LE.301) THEN
6639C...~e_L ~nu_e or ~mu_L ~nu_mu.
6640 IF(isub.EQ.210) THEN
6641 kfpr(isub,1)=ksusy1+11+2*int(0.5d0+pyr(0))
6642 kfpr(isub,2)=kfpr(isub,1)+1
6643C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
6644 ELSEIF(isub.EQ.213) THEN
6645 kfpr(isub,1)=ksusy1+12+2*int(0.5d0+pyr(0))
6646 kfpr(isub,2)=kfpr(isub,1)
6647C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
6648 ELSEIF(isub.GE.246.AND.isub.LE.259) THEN
6649 IF(isub.GE.258) THEN
6650 rkf=4d0
6651 ELSE
6652 rkf=5d0
6653 ENDIF
6654 IF(mod(isub,2).EQ.0) THEN
6655 kfpr(isub,1)=ksusy1+1+int(rkf*pyr(0))
6656 ELSE
6657 kfpr(isub,1)=ksusy2+1+int(rkf*pyr(0))
6658 ENDIF
6659C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
6660 ELSEIF(isub.GE.271.AND.isub.LE.276) THEN
6661 IF(isub.EQ.271.OR.isub.EQ.274) THEN
6662 ksu1=ksusy1
6663 ksu2=ksusy1
6664 ELSEIF(isub.EQ.272.OR.isub.EQ.275) THEN
6665 ksu1=ksusy2
6666 ksu2=ksusy2
6667 ELSEIF(pyr(0).LT.0.5d0) THEN
6668 ksu1=ksusy1
6669 ksu2=ksusy2
6670 ELSE
6671 ksu1=ksusy2
6672 ksu2=ksusy1
6673 ENDIF
6674 kfpr(isub,1)=ksu1+1+int(4d0*pyr(0))
6675 kfpr(isub,2)=ksu2+1+int(4d0*pyr(0))
6676C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
6677 ELSEIF(isub.EQ.277.OR.isub.EQ.279) THEN
6678 kfpr(isub,1)=ksusy1+1+int(4d0*pyr(0))
6679 kfpr(isub,2)=kfpr(isub,1)
6680 ELSEIF(isub.EQ.278.OR.isub.EQ.280) THEN
6681 kfpr(isub,1)=ksusy2+1+int(4d0*pyr(0))
6682 kfpr(isub,2)=kfpr(isub,1)
6683C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
6684 ELSEIF(isub.GE.281.AND.isub.LE.286) THEN
6685 IF(isub.EQ.281.OR.isub.EQ.284) THEN
6686 ksu1=ksusy1
6687 ksu2=ksusy1
6688 ELSEIF(isub.EQ.282.OR.isub.EQ.285) THEN
6689 ksu1=ksusy2
6690 ksu2=ksusy2
6691 ELSEIF(pyr(0).LT.0.5d0) THEN
6692 ksu1=ksusy1
6693 ksu2=ksusy2
6694 ELSE
6695 ksu1=ksusy2
6696 ksu2=ksusy1
6697 ENDIF
6698 IF(isub.EQ.281.OR.isub.LE.283) THEN
6699 rkf=5d0
6700 ELSE
6701 rkf=4d0
6702 ENDIF
6703 kfpr(isub,2)=ksu2+1+int(rkf*pyr(0))
6704 ENDIF
6705 ENDIF
6706
6707C...Find resonances (explicit or implicit in cross-section).
6708 mint(72)=0
6709 kfr1=0
6710 IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
6711 kfr1=kfpr(isub,1)
6712 ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165.OR.
6713 & isub.EQ.171.OR.isub.EQ.176) THEN
6714 kfr1=23
6715 ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172.OR.
6716 & isub.EQ.177) THEN
6717 kfr1=24
6718 ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
6719 kfr1=25
6720 IF(mstp(46).EQ.5) THEN
6721 kfr1=30
6722 pmas(30,1)=parp(45)
6723 pmas(30,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
6724 ENDIF
6725 ELSEIF(isub.EQ.194) THEN
6726 kfr1=54
6727 ELSEIF(isub.EQ.195) THEN
6728 kfr1=55
6729 ELSEIF(isub.GE.361.AND.isub.LE.368) THEN
6730 kfr1=54
6731 ELSEIF(isub.GE.370.AND.isub.LE.377) THEN
6732 kfr1=55
6733 ENDIF
6734 ckmx=ckin(2)
6735 IF(ckmx.LE.0d0) ckmx=vint(1)
6736 kcr1=pycomp(kfr1)
6737 IF(kfr1.NE.0) THEN
6738 IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
6739 & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
6740 ENDIF
6741 IF(kfr1.NE.0) THEN
6742 taur1=pmas(kcr1,1)**2/vint(2)
6743 IF(kfr1.EQ.54) THEN
6744 CALL pytecm(s1,s2)
6745 taur1=s1/vint(2)
6746 ENDIF
6747 gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
6748 mint(72)=1
6749 mint(73)=kfr1
6750 vint(73)=taur1
6751 vint(74)=gamr1
6752 ENDIF
6753 IF(isub.EQ.141.OR.isub.EQ.194.OR.(isub.GE.364.AND.isub.LE.368))
6754 $THEN
6755 kfr2=23
6756 IF(isub.EQ.194) THEN
6757 kfr2=56
6758 ELSEIF(isub.GE.364.AND.isub.LE.368) THEN
6759 kfr2=56
6760 ENDIF
6761 kcr2=pycomp(kfr2)
6762 taur2=pmas(kcr2,1)**2/vint(2)
6763 IF(kfr2.EQ.56) THEN
6764 CALL pytecm(s1,s2)
6765 taur2=s2/vint(2)
6766 ENDIF
6767 gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
6768 IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
6769 & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) kfr2=0
6770 IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
6771 mint(72)=2
6772 mint(74)=kfr2
6773 vint(75)=taur2
6774 vint(76)=gamr2
6775 ELSEIF(kfr2.NE.0) THEN
6776 kfr1=kfr2
6777 taur1=taur2
6778 gamr1=gamr2
6779 mint(72)=1
6780 mint(73)=kfr1
6781 vint(73)=taur1
6782 vint(74)=gamr1
6783 ENDIF
6784 ENDIF
6785
6786C...Find product masses and minimum pT of process,
6787C...optionally with broadening according to a truncated Breit-Wigner.
6788 vint(63)=0d0
6789 vint(64)=0d0
6790 mint(71)=0
6791 vint(71)=ckin(3)
6792 IF(mint(82).GE.2) vint(71)=0d0
6793 vint(80)=1d0
6794 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
6795 nbw=0
6796 DO 140 i=1,2
6797 pmmn(i)=0d0
6798 IF(kfpr(isub,i).EQ.0) THEN
6799 ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
6800 & parp(41)) THEN
6801 vint(62+i)=pmas(pycomp(kfpr(isub,i)),1)**2
6802 ELSE
6803 nbw=nbw+1
6804C...This prevents SUSY/t particles from becoming too light.
6805 kflw=kfpr(isub,i)
6806 IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
6807 kcw=pycomp(kflw)
6808 pmmn(i)=pmas(kcw,1)
6809 DO 130 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
6810 IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
6811 pmsum=pmas(pycomp(kfdp(idc,1)),1)+
6812 & pmas(pycomp(kfdp(idc,2)),1)
6813 IF(kfdp(idc,3).NE.0) pmsum=pmsum+
6814 & pmas(pycomp(kfdp(idc,3)),1)
6815 pmmn(i)=min(pmmn(i),pmsum)
6816 ENDIF
6817 130 CONTINUE
6818 ELSEIF(kflw.EQ.6) THEN
6819 pmmn(i)=pmas(24,1)+pmas(5,1)
6820 ENDIF
6821 ENDIF
6822 140 CONTINUE
6823 IF(nbw.GE.1) THEN
6824 ckin41=ckin(41)
6825 ckin43=ckin(43)
6826 ckin(41)=max(pmmn(1),ckin(41))
6827 ckin(43)=max(pmmn(2),ckin(43))
6828 CALL pyofsh(4,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
6829 ckin(41)=ckin41
6830 ckin(43)=ckin43
6831 IF(mint(51).EQ.1) THEN
6832 IF(mint(121).GT.1) CALL pysave(2,iga)
6833 IF(mfail.EQ.1) THEN
6834 msti(61)=1
6835 RETURN
6836 ENDIF
6837 GOTO 100
6838 ENDIF
6839 vint(63)=pqm3**2
6840 vint(64)=pqm4**2
6841 ENDIF
6842 IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1
6843 IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
6844 ENDIF
6845
6846C...Prepare for additional variable choices in 2 -> 3.
6847 IF(istsb.EQ.5) THEN
6848 vint(201)=0d0
6849 IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
6850 vint(206)=vint(201)
6851 vint(204)=pmas(23,1)
6852 IF(isub.EQ.124.OR.isub.EQ.351) vint(204)=pmas(24,1)
6853 IF(isub.EQ.352) vint(204)=pmas(63,1)
6854 IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
6855 & isub.EQ.186.OR.isub.EQ.187) vint(204)=vint(201)
6856 vint(209)=vint(204)
6857 ENDIF
6858
6859C...Select incoming VDM particle (rho/omega/phi/J/psi).
6860 IF(istsb.NE.0.AND.(mint(101).GE.2.OR.mint(102).GE.2).AND.
6861 &(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7)) THEN
6862 vrn=pyr(0)*sigt(0,0,5)
6863 IF(mint(101).LE.1) THEN
6864 i1mn=0
6865 i1mx=0
6866 ELSE
6867 i1mn=1
6868 i1mx=mint(101)
6869 ENDIF
6870 IF(mint(102).LE.1) THEN
6871 i2mn=0
6872 i2mx=0
6873 ELSE
6874 i2mn=1
6875 i2mx=mint(102)
6876 ENDIF
6877 DO 160 i1=i1mn,i1mx
6878 kfv1=110*i1+3
6879 DO 150 i2=i2mn,i2mx
6880 kfv2=110*i2+3
6881 vrn=vrn-sigt(i1,i2,5)
6882 IF(vrn.LE.0d0) GOTO 170
6883 150 CONTINUE
6884 160 CONTINUE
6885 170 IF(mint(101).GE.2) mint(103)=kfv1
6886 IF(mint(102).GE.2) mint(104)=kfv2
6887 ENDIF
6888
6889 IF(istsb.EQ.0) THEN
6890C...Elastic scattering or single or double diffractive scattering.
6891
6892C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
6893 mint(103)=mint(11)
6894 mint(104)=mint(12)
6895 pmm(1)=vint(3)
6896 pmm(2)=vint(4)
6897 IF(mint(101).GE.2.OR.mint(102).GE.2) THEN
6898 jj=isub-90
6899 vrn=pyr(0)*sigt(0,0,jj)
6900 IF(mint(101).LE.1) THEN
6901 i1mn=0
6902 i1mx=0
6903 ELSE
6904 i1mn=1
6905 i1mx=mint(101)
6906 ENDIF
6907 IF(mint(102).LE.1) THEN
6908 i2mn=0
6909 i2mx=0
6910 ELSE
6911 i2mn=1
6912 i2mx=mint(102)
6913 ENDIF
6914 DO 190 i1=i1mn,i1mx
6915 kfv1=110*i1+3
6916 DO 180 i2=i2mn,i2mx
6917 kfv2=110*i2+3
6918 vrn=vrn-sigt(i1,i2,jj)
6919 IF(vrn.LE.0d0) GOTO 200
6920 180 CONTINUE
6921 190 CONTINUE
6922 200 IF(mint(101).GE.2) THEN
6923 mint(103)=kfv1
6924 pmm(1)=pymass(kfv1)
6925 ENDIF
6926 IF(mint(102).GE.2) THEN
6927 mint(104)=kfv2
6928 pmm(2)=pymass(kfv2)
6929 ENDIF
6930 ENDIF
6931 vint(67)=pmm(1)
6932 vint(68)=pmm(2)
6933
6934C...Select mass for GVMD states (rejecting previous assignment).
6935 q0s=4d0*parp(15)**2
6936 q1s=4d0*vint(154)**2
6937 loop3=0
6938 202 loop3=loop3+1
6939 DO 208 jt=1,2
6940 IF(mint(106+jt).EQ.3) THEN
6941 ps=vint(2+jt)**2
6942 pmm(jt)=(q0s+ps)*(q1s+ps)/
6943 & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
6944 IF(mint(102+jt).GE.333) pmm(jt)=pmm(jt)-
6945 & pmas(pycomp(113),1)+pmas(pycomp(mint(102+jt)),1)
6946 ENDIF
6947 208 CONTINUE
6948 IF(pmm(1)+pmm(2)+parp(104).GE.vint(1)) THEN
6949 IF(loop3.LT.100.AND.(mint(107).EQ.3.OR.mint(108).EQ.3))
6950 & GOTO 202
6951 GOTO 100
6952 ENDIF
6953
6954C...Side/sides of diffractive system.
6955 mint(17)=0
6956 mint(18)=0
6957 IF(isub.EQ.92.OR.isub.EQ.94) mint(17)=1
6958 IF(isub.EQ.93.OR.isub.EQ.94) mint(18)=1
6959
6960C...Find masses of particles and minimal masses of diffractive states.
6961 DO 210 jt=1,2
6962 pdif(jt)=pmm(jt)
6963 vint(68+jt)=pdif(jt)
6964 IF(mint(16+jt).EQ.1) pdif(jt)=pdif(jt)+parp(102)
6965 210 CONTINUE
6966 sh=vint(2)
6967 sqm1=pmm(1)**2
6968 sqm2=pmm(2)**2
6969 sqm3=pdif(1)**2
6970 sqm4=pdif(2)**2
6971 smres1=(pmm(1)+pmrc)**2
6972 smres2=(pmm(2)+pmrc)**2
6973
6974C...Find elastic slope and lower limit diffractive slope.
6975 iha=max(2,iabs(mint(103))/110)
6976 IF(iha.GE.5) iha=1
6977 ihb=max(2,iabs(mint(104))/110)
6978 IF(ihb.GE.5) ihb=1
6979 IF(isub.EQ.91) THEN
6980 bmn=2d0*bhad(iha)+2d0*bhad(ihb)+4d0*sh**eps-4.2d0
6981 ELSEIF(isub.EQ.92) THEN
6982 bmn=max(2d0,2d0*bhad(ihb))
6983 ELSEIF(isub.EQ.93) THEN
6984 bmn=max(2d0,2d0*bhad(iha))
6985 ELSEIF(isub.EQ.94) THEN
6986 bmn=2d0*alp*4d0
6987 ENDIF
6988
6989C...Determine maximum possible t range and coefficient of generation.
6990 sqla12=(sh-sqm1-sqm2)**2-4d0*sqm1*sqm2
6991 sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
6992 tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
6993 thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
6994 thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
6995 & (sqm1*sqm4-sqm2*sqm3)/sh
6996 thl=-0.5d0*(tha+thb)
6997 thu=thc/thl
6998 thrnd=exp(max(-50d0,bmn*(thl-thu)))-1d0
6999
7000C...Select diffractive mass/masses according to dm^2/m^2.
7001 loop3=0
7002 220 loop3=loop3+1
7003 DO 230 jt=1,2
7004 IF(mint(16+jt).EQ.0) THEN
7005 pdif(2+jt)=pdif(jt)
7006 ELSE
7007 pmmin=pdif(jt)
7008 pmmax=max(vint(2+jt),vint(1)-pdif(3-jt))
7009 pdif(2+jt)=pmmin*(pmmax/pmmin)**pyr(0)
7010 ENDIF
7011 230 CONTINUE
7012 sqm3=pdif(3)**2
7013 sqm4=pdif(4)**2
7014
7015C..Additional mass factors, including resonance enhancement.
7016 IF(pdif(3)+pdif(4).GE.vint(1)) THEN
7017 IF(loop3.LT.100) GOTO 220
7018 GOTO 100
7019 ENDIF
7020 IF(isub.EQ.92) THEN
7021 fsd=(1d0-sqm3/sh)*(1d0+cres*smres1/(smres1+sqm3))
7022 IF(fsd.LT.pyr(0)*(1d0+cres)) GOTO 220
7023 ELSEIF(isub.EQ.93) THEN
7024 fsd=(1d0-sqm4/sh)*(1d0+cres*smres2/(smres2+sqm4))
7025 IF(fsd.LT.pyr(0)*(1d0+cres)) GOTO 220
7026 ELSEIF(isub.EQ.94) THEN
7027 fdd=(1d0-(pdif(3)+pdif(4))**2/sh)*(sh*smp/
7028 & (sh*smp+sqm3*sqm4))*(1d0+cres*smres1/(smres1+sqm3))*
7029 & (1d0+cres*smres2/(smres2+sqm4))
7030 IF(fdd.LT.pyr(0)*(1d0+cres)**2) GOTO 220
7031 ENDIF
7032
7033C...Select t according to exp(Bmn*t) and correct to right slope.
7034 th=thu+log(1d0+thrnd*pyr(0))/bmn
7035 IF(isub.GE.92) THEN
7036 IF(isub.EQ.92) THEN
7037 badd=2d0*alp*log(sh/sqm3)
7038 IF(bhad(ihb).LT.1d0) badd=max(0d0,badd+2d0*bhad(ihb)-2d0)
7039 ELSEIF(isub.EQ.93) THEN
7040 badd=2d0*alp*log(sh/sqm4)
7041 IF(bhad(iha).LT.1d0) badd=max(0d0,badd+2d0*bhad(iha)-2d0)
7042 ELSEIF(isub.EQ.94) THEN
7043 badd=2d0*alp*(log(exp(4d0)+sh/(alp*sqm3*sqm4))-4d0)
7044 ENDIF
7045 IF(exp(max(-50d0,badd*(th-thu))).LT.pyr(0)) GOTO 220
7046 ENDIF
7047
7048C...Check whether m^2 and t choices are consistent.
7049 sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
7050 tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
7051 thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
7052 IF(thb.LE.1d-8) GOTO 220
7053 thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
7054 & (sqm1*sqm4-sqm2*sqm3)/sh
7055 thlm=-0.5d0*(tha+thb)
7056 thum=thc/thlm
7057 IF(th.LT.thlm.OR.th.GT.thum) GOTO 220
7058
7059C...Information to output.
7060 vint(21)=1d0
7061 vint(22)=0d0
7062 vint(23)=min(1d0,max(-1d0,(tha+2d0*th)/thb))
7063 vint(45)=th
7064 vint(59)=2d0*sqrt(max(0d0,-(thc+tha*th+th**2)))/thb
7065 vint(63)=pdif(3)**2
7066 vint(64)=pdif(4)**2
7067 vint(283)=pmm(1)**2/4d0
7068 vint(284)=pmm(2)**2/4d0
7069
7070C...Note: in the following, by In is meant the integral over the
7071C...quantity multiplying coefficient cn.
7072C...Choose tau according to h1(tau)/tau, where
7073C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7074C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7075C...I1/I5*c5*1/(tau+tau_R') +
7076C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7077C...I1/I7*c7*tau/(1.-tau), and
7078C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
7079 ELSEIF(istsb.GE.1.AND.istsb.LE.5) THEN
7080 CALL pyklim(1)
7081 IF(mint(51).NE.0) THEN
7082 IF(mint(121).GT.1) CALL pysave(2,iga)
7083 IF(mfail.EQ.1) THEN
7084 msti(61)=1
7085 RETURN
7086 ENDIF
7087 GOTO 100
7088 ENDIF
7089 rtau=pyr(0)
7090 mtau=1
7091 IF(rtau.GT.coef(isub,1)) mtau=2
7092 IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3
7093 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4
7094 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))
7095 & mtau=5
7096 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
7097 & coef(isub,5)) mtau=6
7098 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
7099 & coef(isub,5)+coef(isub,6)) mtau=7
7100 CALL pykmap(1,mtau,pyr(0))
7101
7102C...2 -> 3, 4 processes:
7103C...Choose tau' according to h4(tau,tau')/tau', where
7104C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7105C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
7106 IF(istsb.GE.3.AND.istsb.LE.5) THEN
7107 CALL pyklim(4)
7108 IF(mint(51).NE.0) THEN
7109 IF(mint(121).GT.1) CALL pysave(2,iga)
7110 IF(mfail.EQ.1) THEN
7111 msti(61)=1
7112 RETURN
7113 ENDIF
7114 GOTO 100
7115 ENDIF
7116 rtaup=pyr(0)
7117 mtaup=1
7118 IF(rtaup.GT.coef(isub,18)) mtaup=2
7119 IF(rtaup.GT.coef(isub,18)+coef(isub,19)) mtaup=3
7120 CALL pykmap(4,mtaup,pyr(0))
7121 ENDIF
7122
7123C...Choose y* according to h2(y*), where
7124C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7125C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7126C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7127C...and c1 + c2 + c3 + c4 + c5 = 1.
7128 CALL pyklim(2)
7129 IF(mint(51).NE.0) THEN
7130 IF(mint(121).GT.1) CALL pysave(2,iga)
7131 IF(mfail.EQ.1) THEN
7132 msti(61)=1
7133 RETURN
7134 ENDIF
7135 GOTO 100
7136 ENDIF
7137 ryst=pyr(0)
7138 myst=1
7139 IF(ryst.GT.coef(isub,8)) myst=2
7140 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
7141 IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)) myst=4
7142 IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)+
7143 & coef(isub,11)) myst=5
7144 CALL pykmap(2,myst,pyr(0))
7145
7146C...2 -> 2 processes:
7147C...Choose cos(theta-hat) (cth) according to h3(cth), where
7148C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7149C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7150C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7151C...and c0 + c1 + c2 + c3 + c4 = 1.
7152 CALL pyklim(3)
7153 IF(mint(51).NE.0) THEN
7154 IF(mint(121).GT.1) CALL pysave(2,iga)
7155 IF(mfail.EQ.1) THEN
7156 msti(61)=1
7157 RETURN
7158 ENDIF
7159 GOTO 100
7160 ENDIF
7161 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7162 rcth=pyr(0)
7163 mcth=1
7164 IF(rcth.GT.coef(isub,13)) mcth=2
7165 IF(rcth.GT.coef(isub,13)+coef(isub,14)) mcth=3
7166 IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)) mcth=4
7167 IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)+
7168 & coef(isub,16)) mcth=5
7169 CALL pykmap(3,mcth,pyr(0))
7170 ENDIF
7171
7172C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
7173 IF(istsb.EQ.5) THEN
7174 CALL pykmap(5,0,0d0)
7175 IF(mint(51).NE.0) THEN
7176 IF(mint(121).GT.1) CALL pysave(2,iga)
7177 IF(mfail.EQ.1) THEN
7178 msti(61)=1
7179 RETURN
7180 ENDIF
7181 GOTO 100
7182 ENDIF
7183 ENDIF
7184
7185C...DIS as f + gamma* -> f process: set dummy values.
7186 ELSEIF(istsb.EQ.8) THEN
7187 vint(21)=0.9d0
7188 vint(22)=0d0
7189 vint(23)=0d0
7190 vint(47)=0d0
7191 vint(48)=0d0
7192
7193C...Low-pT or multiple interactions (first semihard interaction).
7194 ELSEIF(istsb.EQ.9) THEN
7195 CALL pymult(3)
7196 isub=mint(1)
7197
7198C...Generate user-defined process: kinematics plus weight.
7199 ELSEIF(istsb.EQ.11) THEN
7200 msti(51)=0
7201 CALL pyupev(isub,sigs)
7202 IF(nup.LE.0) THEN
7203 mint(51)=2
7204 msti(51)=1
7205 IF(mint(82).EQ.1) THEN
7206 ngen(0,1)=ngen(0,1)-1
7207 ngen(0,2)=ngen(0,2)-1
7208 ngen(isub,1)=ngen(isub,1)-1
7209 ENDIF
7210 IF(mint(121).GT.1) CALL pysave(2,iga)
7211 RETURN
7212 ENDIF
7213
7214C...Construct 'trivial' kinematical variables needed.
7215 kfl1=kup(1,2)
7216 kfl2=kup(2,2)
7217 vint(41)=2d0*pup(1,4)/vint(1)
7218 vint(42)=2d0*pup(2,4)/vint(1)
7219 vint(21)=vint(41)*vint(42)
7220 vint(22)=0.5d0*log(vint(41)/vint(42))
7221 vint(44)=vint(21)*vint(2)
7222 vint(43)=sqrt(max(0d0,vint(44)))
7223 vint(56)=q2up(0)
7224 vint(55)=sqrt(max(0d0,vint(56)))
7225
7226C...Construct other kinematical variables needed (approximately).
7227 vint(23)=0d0
7228 vint(26)=vint(21)
7229 vint(45)=-0.5d0*vint(44)
7230 vint(46)=-0.5d0*vint(44)
7231 vint(49)=vint(43)
7232 vint(50)=vint(44)
7233 vint(51)=vint(55)
7234 vint(52)=vint(56)
7235 vint(53)=vint(55)
7236 vint(54)=vint(56)
7237 vint(25)=0d0
7238 vint(48)=0d0
7239 DO 240 iup=3,nup
7240 IF(kup(iup,1).EQ.1) vint(25)=vint(25)+2d0*(pup(iup,5)**2+
7241 & pup(iup,1)**2+pup(iup,2)**2)/vint(2)
7242 IF(kup(iup,1).EQ.1) vint(48)=vint(48)+0.5d0*(pup(iup,1)**2+
7243 & pup(iup,2)**2)
7244 240 CONTINUE
7245 vint(47)=sqrt(vint(48))
7246
7247C...Calculate parton distribution weights.
7248 IF(mint(47).GE.2) THEN
7249 DO 260 i=3-min(2,mint(45)),min(2,mint(46))
7250 mint(105)=mint(102+i)
7251 mint(109)=mint(106+i)
7252 vint(120)=vint(2+i)
7253 IF(mstp(57).LE.1) THEN
7254 CALL pypdfu(mint(10+i),vint(40+i),q2up(0),xpq)
7255 ELSE
7256 CALL pypdfl(mint(10+i),vint(40+i),q2up(0),xpq)
7257 ENDIF
7258 DO 250 kfl=-25,25
7259 xsfx(i,kfl)=xpq(kfl)
7260 250 CONTINUE
7261 260 CONTINUE
7262 ENDIF
7263 ENDIF
7264
7265C...Choose azimuthal angle.
7266 vint(24)=paru(2)*pyr(0)
7267
7268C...Check against user cuts on kinematics at parton level.
7269 mint(51)=0
7270 IF((isub.LE.90.OR.isub.GT.100).AND.istsb.LE.10) CALL pyklim(0)
7271 IF(mint(51).NE.0) THEN
7272 IF(mint(121).GT.1) CALL pysave(2,iga)
7273 IF(mfail.EQ.1) THEN
7274 msti(61)=1
7275 RETURN
7276 ENDIF
7277 GOTO 100
7278 ENDIF
7279 IF(mint(82).EQ.1.AND.mstp(141).GE.1.AND.istsb.LE.10) THEN
7280 mcut=0
7281 IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)
7282 & CALL pykcut(mcut)
7283 IF(mcut.NE.0) THEN
7284 IF(mint(121).GT.1) CALL pysave(2,iga)
7285 IF(mfail.EQ.1) THEN
7286 msti(61)=1
7287 RETURN
7288 ENDIF
7289 GOTO 100
7290 ENDIF
7291 ENDIF
7292
7293C...Calculate differential cross-section for different subprocesses.
7294 IF(istsb.LE.10) CALL pysigh(nchn,sigs)
7295 sigsor=sigs
7296 siglpt=sigt(0,0,5)*vint(315)*vint(316)
7297
7298C...Multiply cross section by lepton -> photon flux factor.
7299 IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
7300 sigs=wtgaga*sigs
7301 DO 270 ichn=1,nchn
7302 sigh(ichn)=wtgaga*sigh(ichn)
7303 270 CONTINUE
7304 siglpt=wtgaga*siglpt
7305 ENDIF
7306
7307C...Multiply cross-section by user-defined weights.
7308 IF(mstp(173).EQ.1) THEN
7309 sigs=parp(173)*sigs
7310 DO 280 ichn=1,nchn
7311 sigh(ichn)=parp(173)*sigh(ichn)
7312 280 CONTINUE
7313 siglpt=parp(173)*siglpt
7314 ENDIF
7315 wtxs=1d0
7316 sigswt=sigs
7317 vint(99)=1d0
7318 vint(100)=1d0
7319 IF(mint(82).EQ.1.AND.mstp(142).GE.1) THEN
7320 IF(isub.NE.96.AND.msub(91)+msub(92)+msub(93)+msub(94)+
7321 & msub(95).EQ.0) CALL pyevwt(wtxs)
7322 sigswt=wtxs*sigs
7323 vint(99)=wtxs
7324 IF(mstp(142).EQ.1) vint(100)=1d0/wtxs
7325 ENDIF
7326
7327C...Calculations for Monte Carlo estimate of all cross-sections.
7328 IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN
7329 IF(mstp(142).LE.1) THEN
7330 xsec(isub,2)=xsec(isub,2)+sigs
7331 ELSE
7332 xsec(isub,2)=xsec(isub,2)+sigswt
7333 ENDIF
7334 ELSEIF(mint(82).EQ.1) THEN
7335 xsec(isub,2)=xsec(isub,2)+sigs
7336 ENDIF
7337 IF((isub.EQ.95.OR.isub.EQ.96).AND.loop2.EQ.1.AND.
7338 &mint(82).EQ.1) xsec(97,2)=xsec(97,2)+siglpt
7339
7340C...Multiple interactions: store results of cross-section calculation.
7341 IF(mint(50).EQ.1.AND.mstp(82).GE.3) THEN
7342 vint(153)=sigsor
7343 CALL pymult(4)
7344 ENDIF
7345
7346C...Check that weight not negative.
7347 viol=sigswt/xsec(isub,1)
7348 IF(isub.EQ.96.AND.mstp(173).EQ.1) viol=viol/parp(174)
7349 IF(mstp(123).LE.0) THEN
7350 IF(viol.LT.-1d-3) THEN
7351 WRITE(mstu(11),5000) viol,ngen(0,3)+1
7352 IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
7353 & vint(22),vint(23),vint(26)
7354 stop
7355 ENDIF
7356 ELSE
7357 IF(viol.LT.min(-1d-3,vint(109))) THEN
7358 vint(109)=viol
7359 WRITE(mstu(11),5200) viol,ngen(0,3)+1
7360 IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
7361 & vint(22),vint(23),vint(26)
7362 ENDIF
7363 ENDIF
7364
7365C...Weighting using estimate of maximum of differential cross-section.
7366 IF(mfail.EQ.0.AND.isub.NE.95.AND.isub.NE.96) THEN
7367 IF(viol.LT.pyr(0)) THEN
7368 IF(mint(121).GT.1) CALL pysave(2,iga)
7369 IF(isub.GE.91.AND.isub.LE.94) isub=0
7370 GOTO 100
7371 ENDIF
7372 ELSEIF(mfail.EQ.0) THEN
7373 ratnd=siglpt/xsec(95,1)
7374 IF(loop2.EQ.1.AND.ratnd.LT.pyr(0)) THEN
7375 IF(mint(121).GT.1) CALL pysave(2,iga)
7376 isub=0
7377 GOTO 100
7378 ENDIF
7379 viol=viol/ratnd
7380 IF(viol.LT.pyr(0)) THEN
7381 GOTO 125
7382 ENDIF
7383 ELSEIF(isub.NE.95.AND.isub.NE.96) THEN
7384 IF(viol.LT.pyr(0)) THEN
7385 msti(61)=1
7386 IF(mint(121).GT.1) CALL pysave(2,iga)
7387 RETURN
7388 ENDIF
7389 ELSE
7390 ratnd=siglpt/xsec(95,1)
7391 IF(loop.EQ.1.AND.ratnd.LT.pyr(0)) THEN
7392 msti(61)=1
7393 IF(mint(121).GT.1) CALL pysave(2,iga)
7394 RETURN
7395 ENDIF
7396 viol=viol/ratnd
7397 IF(viol.LT.pyr(0)) THEN
7398 IF(mint(121).GT.1) CALL pysave(2,iga)
7399 GOTO 100
7400 ENDIF
7401 ENDIF
7402
7403C...Check for possible violation of estimated maximum of differential
7404C...cross-section used in weighting.
7405 IF(mstp(123).LE.0) THEN
7406 IF(viol.GT.1d0) THEN
7407 WRITE(mstu(11),5300) viol,ngen(0,3)+1
7408 IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
7409 & vint(22),vint(23),vint(26)
7410 stop
7411 ENDIF
7412 ELSEIF(mstp(123).EQ.1) THEN
7413 IF(viol.GT.vint(108)) THEN
7414 vint(108)=viol
7415 IF(viol.GT.1d0) THEN
7416 mint(10)=1
7417 WRITE(mstu(11),5400) viol,ngen(0,3)+1
7418 IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
7419 & vint(22),vint(23),vint(26)
7420 ENDIF
7421 ENDIF
7422 ELSEIF(viol.GT.vint(108)) THEN
7423 vint(108)=viol
7424 IF(viol.GT.1d0) THEN
7425 mint(10)=1
7426 xdif=xsec(isub,1)*(viol-1d0)
7427 xsec(isub,1)=xsec(isub,1)+xdif
7428 IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))
7429 & xsec(0,1)=xsec(0,1)+xdif
7430 WRITE(mstu(11),5400) viol,ngen(0,3)+1
7431 IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
7432 & vint(22),vint(23),vint(26)
7433 IF(isub.LE.9) THEN
7434 WRITE(mstu(11),5500) isub,xsec(isub,1)
7435 ELSEIF(isub.LE.99) THEN
7436 WRITE(mstu(11),5600) isub,xsec(isub,1)
7437 ELSE
7438 WRITE(mstu(11),5700) isub,xsec(isub,1)
7439 ENDIF
7440 vint(108)=1d0
7441 ENDIF
7442 ENDIF
7443
7444C...Multiple interactions: choose impact parameter.
7445 vint(148)=1d0
7446 IF(mint(50).EQ.1.AND.(isub.LE.90.OR.isub.GE.96).AND.
7447 &mstp(82).GE.3) THEN
7448 CALL pymult(5)
7449 IF(vint(150).LT.pyr(0)) THEN
7450 IF(mint(121).GT.1) CALL pysave(2,iga)
7451 IF(mfail.EQ.1) THEN
7452 msti(61)=1
7453 RETURN
7454 ENDIF
7455 GOTO 100
7456 ENDIF
7457 ENDIF
7458 IF(mint(82).EQ.1) ngen(0,2)=ngen(0,2)+1
7459 IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN
7460 IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+mint(143)
7461 IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1
7462 ENDIF
7463 IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1
7464
7465C...Choose flavour of reacting partons (and subprocess).
7466 IF(istsb.GE.11) GOTO 300
7467 rsigs=sigs*pyr(0)
7468 qt2=vint(48)
7469 rqqbar=parp(87)*(1d0-(qt2/(qt2+(parp(88)*parp(82)*
7470 &(vint(1)/parp(89))**parp(90))**2))**2)
7471 IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.
7472 &pyr(0).GT.rqqbar)) THEN
7473 DO 290 ichn=1,nchn
7474 kfl1=isig(ichn,1)
7475 kfl2=isig(ichn,2)
7476 mint(2)=isig(ichn,3)
7477 rsigs=rsigs-sigh(ichn)
7478 IF(rsigs.LE.0d0) GOTO 300
7479 290 CONTINUE
7480
7481C...Multiple interactions: choose qqbar preferentially at small pT.
7482 ELSEIF(isub.EQ.96) THEN
7483 mint(105)=mint(103)
7484 mint(109)=mint(107)
7485 CALL pyspli(mint(11),21,kfl1,kfldum)
7486 mint(105)=mint(104)
7487 mint(109)=mint(108)
7488 CALL pyspli(mint(12),21,kfl2,kfldum)
7489 mint(1)=11
7490 mint(2)=1
7491 IF(kfl1.EQ.kfl2.AND.pyr(0).LT.0.5d0) mint(2)=2
7492
7493C...Low-pT: choose string drawing configuration.
7494 ELSE
7495 kfl1=21
7496 kfl2=21
7497 rsigs=6d0*pyr(0)
7498 mint(2)=1
7499 IF(rsigs.GT.1d0) mint(2)=2
7500 IF(rsigs.GT.2d0) mint(2)=3
7501 ENDIF
7502
7503C...Reassign QCD process. Partons before initial state radiation.
7504 300 IF(mint(2).GT.10) THEN
7505 mint(1)=mint(2)/10
7506 mint(2)=mod(mint(2),10)
7507 ENDIF
7508 IF(mint(82).EQ.1.AND.mstp(111).GE.0) ngen(mint(1),2)=
7509 &ngen(mint(1),2)+1
7510 mint(15)=kfl1
7511 mint(16)=kfl2
7512 mint(13)=mint(15)
7513 mint(14)=mint(16)
7514 vint(141)=vint(41)
7515 vint(142)=vint(42)
7516 vint(151)=0d0
7517 vint(152)=0d0
7518
7519C...Calculate x value of photon for parton inside photon inside e.
7520 DO 330 jt=1,2
7521 mint(18+jt)=0
7522 vint(154+jt)=0d0
7523 mspli=0
7524 IF(jt.EQ.1.AND.mint(43).LE.2) mspli=1
7525 IF(jt.EQ.2.AND.mod(mint(43),2).EQ.1) mspli=1
7526 IF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) mspli=mspli+1
7527 IF(mspli.EQ.2) THEN
7528 kflh=mint(14+jt)
7529 xhrd=vint(140+jt)
7530 q2hrd=vint(54)
7531 mint(105)=mint(102+jt)
7532 mint(109)=mint(106+jt)
7533 vint(120)=vint(2+jt)
7534 IF(mstp(57).LE.1) THEN
7535 CALL pypdfu(22,xhrd,q2hrd,xpq)
7536 ELSE
7537 CALL pypdfl(22,xhrd,q2hrd,xpq)
7538 ENDIF
7539 wtmx=4d0*xpq(kflh)
7540 IF(mstp(13).EQ.2) THEN
7541 q2pms=q2hrd/pmas(11,1)**2
7542 wtmx=wtmx*log(max(2d0,q2pms*(1d0-xhrd)/xhrd**2))
7543 ENDIF
7544 310 xe=xhrd**pyr(0)
7545 xg=min(1d0-1d-10,xhrd/xe)
7546 IF(mstp(57).LE.1) THEN
7547 CALL pypdfu(22,xg,q2hrd,xpq)
7548 ELSE
7549 CALL pypdfl(22,xg,q2hrd,xpq)
7550 ENDIF
7551 wt=(1d0+(1d0-xe)**2)*xpq(kflh)
7552 IF(mstp(13).EQ.2) wt=wt*log(max(2d0,q2pms*(1d0-xe)/xe**2))
7553 IF(wt.LT.pyr(0)*wtmx) GOTO 310
7554 mint(18+jt)=1
7555 vint(154+jt)=xe
7556 DO 320 kfls=-25,25
7557 xsfx(jt,kfls)=xpq(kfls)
7558 320 CONTINUE
7559 ENDIF
7560 330 CONTINUE
7561
7562C...Pick scale where photon is resolved.
7563 q0s=parp(15)**2
7564 q1s=vint(154)**2
7565 vint(283)=0d0
7566 IF(mint(107).EQ.3) THEN
7567 IF(mstp(66).EQ.1) THEN
7568 vint(283)=q0s*(vint(54)/q0s)**pyr(0)
7569 ELSEIF(mstp(66).EQ.2) THEN
7570 ps=vint(3)**2
7571 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
7572 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
7573 q2int=sqrt(q0s*q2eff)
7574 vint(283)=q2int*(vint(54)/q2int)**pyr(0)
7575 ELSEIF(mstp(66).EQ.3) THEN
7576 vint(283)=q0s*(q1s/q0s)**pyr(0)
7577 ELSEIF(mstp(66).GE.4) THEN
7578 ps=0.25d0*vint(3)**2
7579 vint(283)=(q0s+ps)*(q1s+ps)/
7580 & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
7581 ENDIF
7582 ENDIF
7583 vint(284)=0d0
7584 IF(mint(108).EQ.3) THEN
7585 IF(mstp(66).EQ.1) THEN
7586 vint(284)=q0s*(vint(54)/q0s)**pyr(0)
7587 ELSEIF(mstp(66).EQ.2) THEN
7588 ps=vint(4)**2
7589 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
7590 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
7591 q2int=sqrt(q0s*q2eff)
7592 vint(284)=q2int*(vint(54)/q2int)**pyr(0)
7593 ELSEIF(mstp(66).EQ.3) THEN
7594 vint(284)=q0s*(q1s/q0s)**pyr(0)
7595 ELSEIF(mstp(66).GE.4) THEN
7596 ps=0.25d0*vint(4)**2
7597 vint(284)=(q0s+ps)*(q1s+ps)/
7598 & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
7599 ENDIF
7600 ENDIF
7601 IF(mint(121).GT.1) CALL pysave(2,iga)
7602
7603C...Format statements for differential cross-section maximum violations.
7604 5000 FORMAT(/1x,'Error: negative cross-section fraction',1p,d11.3,1x,
7605 &'in event',1x,i7,'D0'/1x,'Execution stopped!')
7606 5100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,
7607 &d11.3,', y* =',d11.3,', cthe = ',0p,f11.7,', tau'' =',1p,d11.3)
7608 5200 FORMAT(/1x,'Warning: negative cross-section fraction',1p,d11.3,1x,
7609 &'in event',1x,i7)
7610 5300 FORMAT(/1x,'Error: maximum violated by',1p,d11.3,1x,
7611 &'in event',1x,i7,'D0'/1x,'Execution stopped!')
7612 5400 FORMAT(/1x,'Advisory warning: maximum violated by',1p,d11.3,1x,
7613 &'in event',1x,i7)
7614 5500 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,d11.3)
7615 5600 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,d11.3)
7616 5700 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,d11.3)
7617
7618 RETURN
7619 END
7620
7621C*********************************************************************
7622
7623C...PYSCAT
7624C...Finds outgoing flavours and event type; sets up the kinematics
7625C...and colour flow of the hard scattering
7626
7627 SUBROUTINE pyscat
7628
7629C...Double precision and integer declarations
7630 IMPLICIT DOUBLE PRECISION(a-h, o-z)
7631 IMPLICIT INTEGER(I-N)
7632 INTEGER PYK,PYCHGE,PYCOMP
7633C...Parameter statement to help give large particle numbers.
7634 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
7635C...Commonblocks
7636 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
7637 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
7638 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
7639 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
7640 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
7641 common/pypars/mstp(200),parp(200),msti(200),pari(200)
7642 common/pyint1/mint(400),vint(400)
7643 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
7644 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
7645 common/pyint4/mwid(500),wids(500,5)
7646 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
7647 common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
7648 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
7649 &sfmix(16,4)
7650 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
7651 &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyuppr/,/pyssmt/
7652C...Local arrays and saved variables
7653 dimension wdtp(0:200),wdte(0:200,0:5),pmq(2),z(2),cthe(2),
7654 &phi(2),kuppo(20),vintsv(41:66)
7655 SAVE vintsv
7656
7657C...Read out process
7658 isub=mint(1)
7659 isubsv=isub
7660
7661C...Restore information for low-pT processes
7662 IF(isub.EQ.95.AND.mint(57).GE.1) THEN
7663 DO 100 j=41,66
7664 100 vint(j)=vintsv(j)
7665 ENDIF
7666
7667C...Convert H' or A process into equivalent H one
7668 ihigg=1
7669 kfhigg=25
7670 IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
7671 &isub.LE.190)) THEN
7672 ihigg=2
7673 IF(mod(isub-1,10).GE.5) ihigg=3
7674 kfhigg=33+ihigg
7675 IF(isub.EQ.151.OR.isub.EQ.156) isub=3
7676 IF(isub.EQ.152.OR.isub.EQ.157) isub=102
7677 IF(isub.EQ.153.OR.isub.EQ.158) isub=103
7678 IF(isub.EQ.171.OR.isub.EQ.176) isub=24
7679 IF(isub.EQ.172.OR.isub.EQ.177) isub=26
7680 IF(isub.EQ.173.OR.isub.EQ.178) isub=123
7681 IF(isub.EQ.174.OR.isub.EQ.179) isub=124
7682 IF(isub.EQ.181.OR.isub.EQ.186) isub=121
7683 IF(isub.EQ.182.OR.isub.EQ.187) isub=122
7684 ENDIF
7685
7686C...Choice of subprocess, number of documentation lines
7687 idoc=6+iset(isub)
7688 IF(isub.EQ.95) idoc=8
7689 IF(iset(isub).EQ.5) idoc=9
7690 IF(iset(isub).EQ.11) idoc=4+nup
7691 mint(3)=idoc-6
7692 IF(idoc.GE.9.AND.iset(isub).LE.4) idoc=idoc+2
7693 mint(4)=idoc
7694 ipu1=mint(84)+1
7695 ipu2=mint(84)+2
7696 ipu3=mint(84)+3
7697 ipu4=mint(84)+4
7698 ipu5=mint(84)+5
7699 ipu6=mint(84)+6
7700
7701C...Reset K, P and V vectors. Store incoming particles
7702 DO 120 jt=1,mstp(126)+20
7703 i=mint(83)+jt
7704 DO 110 j=1,5
7705 k(i,j)=0
7706 p(i,j)=0d0
7707 v(i,j)=0d0
7708 110 CONTINUE
7709 120 CONTINUE
7710 DO 140 jt=1,2
7711 i=mint(83)+jt
7712 k(i,1)=21
7713 k(i,2)=mint(10+jt)
7714 DO 130 j=1,5
7715 p(i,j)=vint(285+5*jt+j)
7716 130 CONTINUE
7717 140 CONTINUE
7718 mint(6)=2
7719 kfres=0
7720
7721C...Store incoming partons in their CM-frame
7722 sh=vint(44)
7723 shr=sqrt(sh)
7724 shp=vint(26)*vint(2)
7725 shpr=sqrt(shp)
7726 shuser=shr
7727 IF(iset(isub).GE.3.AND.iset(isub).LE.5) shuser=shpr
7728 DO 150 jt=1,2
7729 i=mint(84)+jt
7730 k(i,1)=14
7731 k(i,2)=mint(14+jt)
7732 k(i,3)=mint(83)+2+jt
7733 p(i,3)=0.5d0*shuser*(-1d0)**(jt-1)
7734 p(i,4)=0.5d0*shuser
7735 150 CONTINUE
7736
7737C...Copy incoming partons to documentation lines
7738 DO 170 jt=1,2
7739 i1=mint(83)+4+jt
7740 i2=mint(84)+jt
7741 k(i1,1)=21
7742 k(i1,2)=k(i2,2)
7743 k(i1,3)=i1-2
7744 DO 160 j=1,5
7745 p(i1,j)=p(i2,j)
7746 160 CONTINUE
7747 170 CONTINUE
7748
7749C...Choose new quark/lepton flavour for relevant annihilation graphs
7750 IF(isub.EQ.12.OR.isub.EQ.53.OR.isub.EQ.54.OR.isub.EQ.58.OR.
7751 &(isub.GE.135.AND.isub.LE.140)) THEN
7752 iglga=21
7753 IF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) iglga=22
7754 CALL pywidt(iglga,sh,wdtp,wdte)
7755 180 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
7756 DO 190 i=1,mdcy(iglga,3)
7757 kflf=kfdp(i+mdcy(iglga,2)-1,1)
7758 rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
7759 IF(rkfl.LE.0d0) GOTO 200
7760 190 CONTINUE
7761 200 CONTINUE
7762 IF(isub.EQ.12.AND.mstp(5).EQ.1.AND.iabs(mint(15)).LE.2.AND.
7763 & iabs(kflf).GE.3) THEN
7764 facqqb=vint(58)**2*4d0/9d0*(vint(45)**2+vint(46)**2)/
7765 & vint(44)**2
7766 faccib=vint(46)**2/paru(155)**4
7767 IF(facqqb/(facqqb+faccib).LT.pyr(0)) GOTO 180
7768 ELSEIF(isub.EQ.54.OR.isub.EQ.135.OR.isub.EQ.136) THEN
7769 IF((kchg(pycomp(kflf),1)/2d0)**2.LT.pyr(0)) GOTO 180
7770 ELSEIF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) THEN
7771 IF((kchg(pycomp(kflf),1)/3d0)**2.LT.pyr(0)) GOTO 180
7772 ENDIF
7773 ENDIF
7774
7775C...Final state flavours and colour flow: default values
7776 js=1
7777 mint(21)=mint(15)
7778 mint(22)=mint(16)
7779 mint(23)=0
7780 mint(24)=0
7781 kcc=20
7782 kcs=isign(1,mint(15))
7783
7784 IF(iset(isub).EQ.11) THEN
7785C...User-defined processes: find products
7786 irup=0
7787 DO 210 iup=3,nup
7788 IF(kup(iup,1).NE.1) THEN
7789 ELSEIF(irup.LE.5) THEN
7790 irup=irup+1
7791 mint(20+irup)=kup(iup,2)
7792 ENDIF
7793 210 CONTINUE
7794
7795 ELSEIF(isub.LE.10) THEN
7796 IF(isub.EQ.1) THEN
7797C...f + fbar -> gamma*/Z0
7798 kfres=23
7799
7800 ELSEIF(isub.EQ.2) THEN
7801C...f + fbar' -> W+/-
7802 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7803 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7804 kfres=isign(24,kch1+kch2)
7805
7806 ELSEIF(isub.EQ.3) THEN
7807C...f + fbar -> h0 (or H0, or A0)
7808 kfres=kfhigg
7809
7810 ELSEIF(isub.EQ.4) THEN
7811C...gamma + W+/- -> W+/-
7812
7813 ELSEIF(isub.EQ.5) THEN
7814C...Z0 + Z0 -> h0
7815 xh=sh/shp
7816 mint(21)=mint(15)
7817 mint(22)=mint(16)
7818 pmq(1)=pymass(mint(21))
7819 pmq(2)=pymass(mint(22))
7820 220 jt=int(1.5d0+pyr(0))
7821 zmin=2d0*pmq(jt)/shpr
7822 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
7823 & (shpr*(shpr-pmq(3-jt)))
7824 zmax=min(1d0-xh,zmax)
7825 z(jt)=zmin+(zmax-zmin)*pyr(0)
7826 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
7827 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 220
7828 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
7829 IF(sqc1.LT.1d-8) GOTO 220
7830 c1=sqrt(sqc1)
7831 c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
7832 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7833 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
7834 z(3-jt)=1d0-xh/(1d0-z(jt))
7835 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
7836 IF(sqc1.LT.1d-8) GOTO 220
7837 c1=sqrt(sqc1)
7838 c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
7839 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7840 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
7841 phir=paru(2)*pyr(0)
7842 cphi=cos(phir)
7843 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
7844 & sqrt(1d0-cthe(2)**2)*cphi
7845 z1=2d0-z(jt)
7846 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
7847 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
7848 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
7849 & pmq(3-jt)**2/shp))
7850 zmin=2d0*pmq(3-jt)/shpr
7851 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
7852 zmax=min(1d0-xh,zmax)
7853 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 220
7854 kcc=22
7855 kfres=25
7856
7857 ELSEIF(isub.EQ.6) THEN
7858C...Z0 + W+/- -> W+/-
7859
7860 ELSEIF(isub.EQ.7) THEN
7861C...W+ + W- -> Z0
7862
7863 ELSEIF(isub.EQ.8) THEN
7864C...W+ + W- -> h0
7865 xh=sh/shp
7866 230 DO 260 jt=1,2
7867 i=mint(14+jt)
7868 ia=iabs(i)
7869 IF(ia.LE.10) THEN
7870 rvckm=vint(180+i)*pyr(0)
7871 DO 240 j=1,mstp(1)
7872 ib=2*j-1+mod(ia,2)
7873 ipm=(5-isign(1,i))/2
7874 idc=j+mdcy(ia,2)+2
7875 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 240
7876 mint(20+jt)=isign(ib,i)
7877 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
7878 IF(rvckm.LE.0d0) GOTO 250
7879 240 CONTINUE
7880 ELSE
7881 ib=2*((ia+1)/2)-1+mod(ia,2)
7882 mint(20+jt)=isign(ib,i)
7883 ENDIF
7884 250 pmq(jt)=pymass(mint(20+jt))
7885 260 CONTINUE
7886 jt=int(1.5d0+pyr(0))
7887 zmin=2d0*pmq(jt)/shpr
7888 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
7889 & (shpr*(shpr-pmq(3-jt)))
7890 zmax=min(1d0-xh,zmax)
7891 IF(zmin.GE.zmax) GOTO 230
7892 z(jt)=zmin+(zmax-zmin)*pyr(0)
7893 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
7894 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 230
7895 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
7896 IF(sqc1.LT.1d-8) GOTO 230
7897 c1=sqrt(sqc1)
7898 c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
7899 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7900 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
7901 z(3-jt)=1d0-xh/(1d0-z(jt))
7902 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
7903 IF(sqc1.LT.1d-8) GOTO 230
7904 c1=sqrt(sqc1)
7905 c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
7906 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7907 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
7908 phir=paru(2)*pyr(0)
7909 cphi=cos(phir)
7910 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
7911 & sqrt(1d0-cthe(2)**2)*cphi
7912 z1=2d0-z(jt)
7913 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
7914 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
7915 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
7916 & pmq(3-jt)**2/shp))
7917 zmin=2d0*pmq(3-jt)/shpr
7918 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
7919 zmax=min(1d0-xh,zmax)
7920 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 230
7921 kcc=22
7922 kfres=25
7923
7924 ELSEIF(isub.EQ.10) THEN
7925C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
7926 IF(mint(2).EQ.1) THEN
7927 kcc=22
7928 ELSE
7929C...W exchange: need to mix flavours according to CKM matrix
7930 DO 280 jt=1,2
7931 i=mint(14+jt)
7932 ia=iabs(i)
7933 IF(ia.LE.10) THEN
7934 rvckm=vint(180+i)*pyr(0)
7935 DO 270 j=1,mstp(1)
7936 ib=2*j-1+mod(ia,2)
7937 ipm=(5-isign(1,i))/2
7938 idc=j+mdcy(ia,2)+2
7939 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 270
7940 mint(20+jt)=isign(ib,i)
7941 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
7942 IF(rvckm.LE.0d0) GOTO 280
7943 270 CONTINUE
7944 ELSE
7945 ib=2*((ia+1)/2)-1+mod(ia,2)
7946 mint(20+jt)=isign(ib,i)
7947 ENDIF
7948 280 CONTINUE
7949 kcc=22
7950 ENDIF
7951 ENDIF
7952
7953 ELSEIF(isub.LE.20) THEN
7954 IF(isub.EQ.11) THEN
7955C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
7956 kcc=mint(2)
7957 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
7958
7959 ELSEIF(isub.EQ.12) THEN
7960C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
7961 mint(21)=isign(kflf,mint(15))
7962 mint(22)=-mint(21)
7963 kcc=4
7964
7965 ELSEIF(isub.EQ.13) THEN
7966C...f + fbar -> g + g; th arbitrary
7967 mint(21)=21
7968 mint(22)=21
7969 kcc=mint(2)+4
7970
7971 ELSEIF(isub.EQ.14) THEN
7972C...f + fbar -> g + gamma; th arbitrary
7973 IF(pyr(0).GT.0.5d0) js=2
7974 mint(20+js)=21
7975 mint(23-js)=22
7976 kcc=17+js
7977
7978 ELSEIF(isub.EQ.15) THEN
7979C...f + fbar -> g + Z0; th arbitrary
7980 IF(pyr(0).GT.0.5d0) js=2
7981 mint(20+js)=21
7982 mint(23-js)=23
7983 kcc=17+js
7984
7985 ELSEIF(isub.EQ.16) THEN
7986C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
7987 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7988 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7989 IF(mint(15)*(kch1+kch2).LT.0) js=2
7990 mint(20+js)=21
7991 mint(23-js)=isign(24,kch1+kch2)
7992 kcc=17+js
7993
7994 ELSEIF(isub.EQ.17) THEN
7995C...f + fbar -> g + h0; th arbitrary
7996 IF(pyr(0).GT.0.5d0) js=2
7997 mint(20+js)=21
7998 mint(23-js)=25
7999 kcc=17+js
8000
8001 ELSEIF(isub.EQ.18) THEN
8002C...f + fbar -> gamma + gamma; th arbitrary
8003 mint(21)=22
8004 mint(22)=22
8005
8006 ELSEIF(isub.EQ.19) THEN
8007C...f + fbar -> gamma + Z0; th arbitrary
8008 IF(pyr(0).GT.0.5d0) js=2
8009 mint(20+js)=22
8010 mint(23-js)=23
8011
8012 ELSEIF(isub.EQ.20) THEN
8013C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8014C...(p(fbar')-p(W+))**2
8015 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8016 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8017 IF(mint(15)*(kch1+kch2).LT.0) js=2
8018 mint(20+js)=22
8019 mint(23-js)=isign(24,kch1+kch2)
8020 ENDIF
8021
8022 ELSEIF(isub.LE.30) THEN
8023 IF(isub.EQ.21) THEN
8024C...f + fbar -> gamma + h0; th arbitrary
8025 IF(pyr(0).GT.0.5d0) js=2
8026 mint(20+js)=22
8027 mint(23-js)=25
8028
8029 ELSEIF(isub.EQ.22) THEN
8030C...f + fbar -> Z0 + Z0; th arbitrary
8031 mint(21)=23
8032 mint(22)=23
8033
8034 ELSEIF(isub.EQ.23) THEN
8035C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8036 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8037 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8038 IF(mint(15)*(kch1+kch2).LT.0) js=2
8039 mint(20+js)=23
8040 mint(23-js)=isign(24,kch1+kch2)
8041
8042 ELSEIF(isub.EQ.24) THEN
8043C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
8044 IF(pyr(0).GT.0.5d0) js=2
8045 mint(20+js)=23
8046 mint(23-js)=kfhigg
8047
8048 ELSEIF(isub.EQ.25) THEN
8049C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
8050 mint(21)=-isign(24,mint(15))
8051 mint(22)=-mint(21)
8052
8053 ELSEIF(isub.EQ.26) THEN
8054C...f + fbar' -> W+/- + h0 (or H0, or A0);
8055C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8056 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8057 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8058 IF(mint(15)*(kch1+kch2).GT.0) js=2
8059 mint(20+js)=isign(24,kch1+kch2)
8060 mint(23-js)=kfhigg
8061
8062 ELSEIF(isub.EQ.27) THEN
8063C...f + fbar -> h0 + h0
8064
8065 ELSEIF(isub.EQ.28) THEN
8066C...f + g -> f + g; th = (p(f)-p(f))**2
8067 kcc=mint(2)+6
8068 IF(mint(15).EQ.21) kcc=kcc+2
8069 IF(mint(15).NE.21) kcs=isign(1,mint(15))
8070 IF(mint(16).NE.21) kcs=isign(1,mint(16))
8071
8072 ELSEIF(isub.EQ.29) THEN
8073C...f + g -> f + gamma; th = (p(f)-p(f))**2
8074 IF(mint(15).EQ.21) js=2
8075 mint(23-js)=22
8076 kcc=15+js
8077 kcs=isign(1,mint(14+js))
8078
8079 ELSEIF(isub.EQ.30) THEN
8080C...f + g -> f + Z0; th = (p(f)-p(f))**2
8081 IF(mint(15).EQ.21) js=2
8082 mint(23-js)=23
8083 kcc=15+js
8084 kcs=isign(1,mint(14+js))
8085 ENDIF
8086
8087 ELSEIF(isub.LE.40) THEN
8088 IF(isub.EQ.31) THEN
8089C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
8090 IF(mint(15).EQ.21) js=2
8091 i=mint(14+js)
8092 ia=iabs(i)
8093 mint(23-js)=isign(24,kchg(ia,1)*i)
8094 rvckm=vint(180+i)*pyr(0)
8095 DO 290 j=1,mstp(1)
8096 ib=2*j-1+mod(ia,2)
8097 ipm=(5-isign(1,i))/2
8098 idc=j+mdcy(ia,2)+2
8099 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 290
8100 mint(20+js)=isign(ib,i)
8101 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
8102 IF(rvckm.LE.0d0) GOTO 300
8103 290 CONTINUE
8104 300 kcc=15+js
8105 kcs=isign(1,mint(14+js))
8106
8107 ELSEIF(isub.EQ.32) THEN
8108C...f + g -> f + h0; th = (p(f)-p(f))**2
8109 IF(mint(15).EQ.21) js=2
8110 mint(23-js)=25
8111 kcc=15+js
8112 kcs=isign(1,mint(14+js))
8113
8114 ELSEIF(isub.EQ.33) THEN
8115C...f + gamma -> f + g; th=(p(f)-p(f))**2
8116 IF(mint(15).EQ.22) js=2
8117 mint(23-js)=21
8118 kcc=24+js
8119 kcs=isign(1,mint(14+js))
8120
8121 ELSEIF(isub.EQ.34) THEN
8122C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
8123 IF(mint(15).EQ.22) js=2
8124 kcc=22
8125 kcs=isign(1,mint(14+js))
8126
8127 ELSEIF(isub.EQ.35) THEN
8128C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
8129 IF(mint(15).EQ.22) js=2
8130 mint(23-js)=23
8131 kcc=22
8132
8133 ELSEIF(isub.EQ.36) THEN
8134C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
8135 IF(mint(15).EQ.22) js=2
8136 i=mint(14+js)
8137 ia=iabs(i)
8138 mint(23-js)=isign(24,kchg(ia,1)*i)
8139 IF(ia.LE.10) THEN
8140 rvckm=vint(180+i)*pyr(0)
8141 DO 310 j=1,mstp(1)
8142 ib=2*j-1+mod(ia,2)
8143 ipm=(5-isign(1,i))/2
8144 idc=j+mdcy(ia,2)+2
8145 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 310
8146 mint(20+js)=isign(ib,i)
8147 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
8148 IF(rvckm.LE.0d0) GOTO 320
8149 310 CONTINUE
8150 ELSE
8151 ib=2*((ia+1)/2)-1+mod(ia,2)
8152 mint(20+js)=isign(ib,i)
8153 ENDIF
8154 320 kcc=22
8155
8156 ELSEIF(isub.EQ.37) THEN
8157C...f + gamma -> f + h0
8158
8159 ELSEIF(isub.EQ.38) THEN
8160C...f + Z0 -> f + g
8161
8162 ELSEIF(isub.EQ.39) THEN
8163C...f + Z0 -> f + gamma
8164
8165 ELSEIF(isub.EQ.40) THEN
8166C...f + Z0 -> f + Z0
8167 ENDIF
8168
8169 ELSEIF(isub.LE.50) THEN
8170 IF(isub.EQ.41) THEN
8171C...f + Z0 -> f' + W+/-
8172
8173 ELSEIF(isub.EQ.42) THEN
8174C...f + Z0 -> f + h0
8175
8176 ELSEIF(isub.EQ.43) THEN
8177C...f + W+/- -> f' + g
8178
8179 ELSEIF(isub.EQ.44) THEN
8180C...f + W+/- -> f' + gamma
8181
8182 ELSEIF(isub.EQ.45) THEN
8183C...f + W+/- -> f' + Z0
8184
8185 ELSEIF(isub.EQ.46) THEN
8186C...f + W+/- -> f' + W+/-
8187
8188 ELSEIF(isub.EQ.47) THEN
8189C...f + W+/- -> f' + h0
8190
8191 ELSEIF(isub.EQ.48) THEN
8192C...f + h0 -> f + g
8193
8194 ELSEIF(isub.EQ.49) THEN
8195C...f + h0 -> f + gamma
8196
8197 ELSEIF(isub.EQ.50) THEN
8198C...f + h0 -> f + Z0
8199 ENDIF
8200
8201 ELSEIF(isub.LE.60) THEN
8202 IF(isub.EQ.51) THEN
8203C...f + h0 -> f' + W+/-
8204
8205 ELSEIF(isub.EQ.52) THEN
8206C...f + h0 -> f + h0
8207
8208 ELSEIF(isub.EQ.53) THEN
8209C...g + g -> f + fbar; th arbitrary
8210 kcs=(-1)**int(1.5d0+pyr(0))
8211 mint(21)=isign(kflf,kcs)
8212 mint(22)=-mint(21)
8213 kcc=mint(2)+10
8214
8215 ELSEIF(isub.EQ.54) THEN
8216C...g + gamma -> f + fbar; th arbitrary
8217 kcs=(-1)**int(1.5d0+pyr(0))
8218 mint(21)=isign(kflf,kcs)
8219 mint(22)=-mint(21)
8220 kcc=27
8221 IF(mint(16).EQ.21) kcc=28
8222
8223 ELSEIF(isub.EQ.55) THEN
8224C...g + Z0 -> f + fbar
8225
8226 ELSEIF(isub.EQ.56) THEN
8227C...g + W+/- -> f + fbar'
8228
8229 ELSEIF(isub.EQ.57) THEN
8230C...g + h0 -> f + fbar
8231
8232 ELSEIF(isub.EQ.58) THEN
8233C...gamma + gamma -> f + fbar; th arbitrary
8234 kcs=(-1)**int(1.5d0+pyr(0))
8235 mint(21)=isign(kflf,kcs)
8236 mint(22)=-mint(21)
8237 kcc=21
8238
8239 ELSEIF(isub.EQ.59) THEN
8240C...gamma + Z0 -> f + fbar
8241
8242 ELSEIF(isub.EQ.60) THEN
8243C...gamma + W+/- -> f + fbar'
8244 ENDIF
8245
8246 ELSEIF(isub.LE.70) THEN
8247 IF(isub.EQ.61) THEN
8248C...gamma + h0 -> f + fbar
8249
8250 ELSEIF(isub.EQ.62) THEN
8251C...Z0 + Z0 -> f + fbar
8252
8253 ELSEIF(isub.EQ.63) THEN
8254C...Z0 + W+/- -> f + fbar'
8255
8256 ELSEIF(isub.EQ.64) THEN
8257C...Z0 + h0 -> f + fbar
8258
8259 ELSEIF(isub.EQ.65) THEN
8260C...W+ + W- -> f + fbar
8261
8262 ELSEIF(isub.EQ.66) THEN
8263C...W+/- + h0 -> f + fbar'
8264
8265 ELSEIF(isub.EQ.67) THEN
8266C...h0 + h0 -> f + fbar
8267
8268 ELSEIF(isub.EQ.68) THEN
8269C...g + g -> g + g; th arbitrary
8270 kcc=mint(2)+12
8271 kcs=(-1)**int(1.5d0+pyr(0))
8272
8273 ELSEIF(isub.EQ.69) THEN
8274C...gamma + gamma -> W+ + W-; th arbitrary
8275 mint(21)=24
8276 mint(22)=-24
8277 kcc=21
8278
8279 ELSEIF(isub.EQ.70) THEN
8280C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
8281 IF(mint(15).EQ.22) mint(21)=23
8282 IF(mint(16).EQ.22) mint(22)=23
8283 kcc=21
8284 ENDIF
8285
8286 ELSEIF(isub.LE.80) THEN
8287 IF(isub.EQ.71.OR.isub.EQ.72) THEN
8288C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
8289 xh=sh/shp
8290 mint(21)=mint(15)
8291 mint(22)=mint(16)
8292 pmq(1)=pymass(mint(21))
8293 pmq(2)=pymass(mint(22))
8294 330 jt=int(1.5d0+pyr(0))
8295 zmin=2d0*pmq(jt)/shpr
8296 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
8297 & (shpr*(shpr-pmq(3-jt)))
8298 zmax=min(1d0-xh,zmax)
8299 z(jt)=zmin+(zmax-zmin)*pyr(0)
8300 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
8301 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 330
8302 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
8303 IF(sqc1.LT.1d-8) GOTO 330
8304 c1=sqrt(sqc1)
8305 c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
8306 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
8307 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
8308 z(3-jt)=1d0-xh/(1d0-z(jt))
8309 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
8310 IF(sqc1.LT.1d-8) GOTO 330
8311 c1=sqrt(sqc1)
8312 c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
8313 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
8314 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
8315 phir=paru(2)*pyr(0)
8316 cphi=cos(phir)
8317 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
8318 & sqrt(1d0-cthe(2)**2)*cphi
8319 z1=2d0-z(jt)
8320 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
8321 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
8322 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
8323 & pmq(3-jt)**2/shp))
8324 zmin=2d0*pmq(3-jt)/shpr
8325 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
8326 zmax=min(1d0-xh,zmax)
8327 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 330
8328 kcc=22
8329
8330 ELSEIF(isub.EQ.73) THEN
8331C...Z0 + W+/- -> Z0 + W+/-
8332 js=mint(2)
8333 xh=sh/shp
8334 340 jt=3-mint(2)
8335 i=mint(14+jt)
8336 ia=iabs(i)
8337 IF(ia.LE.10) THEN
8338 rvckm=vint(180+i)*pyr(0)
8339 DO 350 j=1,mstp(1)
8340 ib=2*j-1+mod(ia,2)
8341 ipm=(5-isign(1,i))/2
8342 idc=j+mdcy(ia,2)+2
8343 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 350
8344 mint(20+jt)=isign(ib,i)
8345 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
8346 IF(rvckm.LE.0d0) GOTO 360
8347 350 CONTINUE
8348 ELSE
8349 ib=2*((ia+1)/2)-1+mod(ia,2)
8350 mint(20+jt)=isign(ib,i)
8351 ENDIF
8352 360 pmq(jt)=pymass(mint(20+jt))
8353 mint(23-jt)=mint(17-jt)
8354 pmq(3-jt)=pymass(mint(23-jt))
8355 jt=int(1.5d0+pyr(0))
8356 zmin=2d0*pmq(jt)/shpr
8357 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
8358 & (shpr*(shpr-pmq(3-jt)))
8359 zmax=min(1d0-xh,zmax)
8360 IF(zmin.GE.zmax) GOTO 340
8361 z(jt)=zmin+(zmax-zmin)*pyr(0)
8362 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
8363 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 340
8364 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
8365 IF(sqc1.LT.1d-8) GOTO 340
8366 c1=sqrt(sqc1)
8367 c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
8368 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
8369 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
8370 z(3-jt)=1d0-xh/(1d0-z(jt))
8371 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
8372 IF(sqc1.LT.1d-8) GOTO 340
8373 c1=sqrt(sqc1)
8374 c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
8375 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
8376 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
8377 phir=paru(2)*pyr(0)
8378 cphi=cos(phir)
8379 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
8380 & sqrt(1d0-cthe(2)**2)*cphi
8381 z1=2d0-z(jt)
8382 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
8383 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
8384 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
8385 & pmq(3-jt)**2/shp))
8386 zmin=2d0*pmq(3-jt)/shpr
8387 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
8388 zmax=min(1d0-xh,zmax)
8389 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 340
8390 kcc=22
8391
8392 ELSEIF(isub.EQ.74) THEN
8393C...Z0 + h0 -> Z0 + h0
8394
8395 ELSEIF(isub.EQ.75) THEN
8396C...W+ + W- -> gamma + gamma
8397
8398 ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
8399C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
8400 xh=sh/shp
8401 370 DO 400 jt=1,2
8402 i=mint(14+jt)
8403 ia=iabs(i)
8404 IF(ia.LE.10) THEN
8405 rvckm=vint(180+i)*pyr(0)
8406 DO 380 j=1,mstp(1)
8407 ib=2*j-1+mod(ia,2)
8408 ipm=(5-isign(1,i))/2
8409 idc=j+mdcy(ia,2)+2
8410 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 380
8411 mint(20+jt)=isign(ib,i)
8412 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
8413 IF(rvckm.LE.0d0) GOTO 390
8414 380 CONTINUE
8415 ELSE
8416 ib=2*((ia+1)/2)-1+mod(ia,2)
8417 mint(20+jt)=isign(ib,i)
8418 ENDIF
8419 390 pmq(jt)=pymass(mint(20+jt))
8420 400 CONTINUE
8421 jt=int(1.5d0+pyr(0))
8422 zmin=2d0*pmq(jt)/shpr
8423 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
8424 & (shpr*(shpr-pmq(3-jt)))
8425 zmax=min(1d0-xh,zmax)
8426 IF(zmin.GE.zmax) GOTO 370
8427 z(jt)=zmin+(zmax-zmin)*pyr(0)
8428 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
8429 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 370
8430 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
8431 IF(sqc1.LT.1d-8) GOTO 370
8432 c1=sqrt(sqc1)
8433 c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
8434 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
8435 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
8436 z(3-jt)=1d0-xh/(1d0-z(jt))
8437 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
8438 IF(sqc1.LT.1d-8) GOTO 370
8439 c1=sqrt(sqc1)
8440 c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
8441 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
8442 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
8443 phir=paru(2)*pyr(0)
8444 cphi=cos(phir)
8445 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
8446 & sqrt(1d0-cthe(2)**2)*cphi
8447 z1=2d0-z(jt)
8448 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
8449 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
8450 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
8451 & pmq(3-jt)**2/shp))
8452 zmin=2d0*pmq(3-jt)/shpr
8453 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
8454 zmax=min(1d0-xh,zmax)
8455 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 370
8456 kcc=22
8457
8458 ELSEIF(isub.EQ.78) THEN
8459C...W+/- + h0 -> W+/- + h0
8460
8461 ELSEIF(isub.EQ.79) THEN
8462C...h0 + h0 -> h0 + h0
8463
8464 ELSEIF(isub.EQ.80) THEN
8465C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
8466 IF(mint(15).EQ.22) js=2
8467 i=mint(14+js)
8468 ia=iabs(i)
8469 mint(23-js)=isign(211,kchg(ia,1)*i)
8470 ib=3-ia
8471 mint(20+js)=isign(ib,i)
8472 kcc=22
8473 ENDIF
8474
8475 ELSEIF(isub.LE.90) THEN
8476 IF(isub.EQ.81) THEN
8477C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
8478 mint(21)=isign(mint(55),mint(15))
8479 mint(22)=-mint(21)
8480 kcc=4
8481
8482 ELSEIF(isub.EQ.82) THEN
8483C...g + g -> Q + Qbar; th arbitrary
8484 kcs=(-1)**int(1.5d0+pyr(0))
8485 mint(21)=isign(mint(55),kcs)
8486 mint(22)=-mint(21)
8487 kcc=mint(2)+10
8488
8489 ELSEIF(isub.EQ.83) THEN
8490C...f + q -> f' + Q; th = (p(f) - p(f'))**2
8491 kfold=mint(16)
8492 IF(mint(2).EQ.2) kfold=mint(15)
8493 kfaold=iabs(kfold)
8494 IF(kfaold.GT.10) THEN
8495 kfanew=kfaold+2*mod(kfaold,2)-1
8496 ELSE
8497 rckm=vint(180+kfold)*pyr(0)
8498 ipm=(5-isign(1,kfold))/2
8499 kfanew=-mod(kfaold+1,2)
8500 410 kfanew=kfanew+2
8501 idc=mdcy(kfaold,2)+(kfanew+1)/2+2
8502 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) THEN
8503 IF(mod(kfaold,2).EQ.0) rckm=rckm-
8504 & vckm(kfaold/2,(kfanew+1)/2)
8505 IF(mod(kfaold,2).EQ.1) rckm=rckm-
8506 & vckm(kfanew/2,(kfaold+1)/2)
8507 ENDIF
8508 IF(kfanew.LE.6.AND.rckm.GT.0d0) GOTO 410
8509 ENDIF
8510 IF(mint(2).EQ.1) THEN
8511 mint(21)=isign(mint(55),mint(15))
8512 mint(22)=isign(kfanew,mint(16))
8513 ELSE
8514 mint(21)=isign(kfanew,mint(15))
8515 mint(22)=isign(mint(55),mint(16))
8516 js=2
8517 ENDIF
8518 kcc=22
8519
8520 ELSEIF(isub.EQ.84) THEN
8521C...g + gamma -> Q + Qbar; th arbitary
8522 kcs=(-1)**int(1.5d0+pyr(0))
8523 mint(21)=isign(mint(55),kcs)
8524 mint(22)=-mint(21)
8525 kcc=27
8526 IF(mint(16).EQ.21) kcc=28
8527
8528 ELSEIF(isub.EQ.85) THEN
8529C...gamma + gamma -> F + Fbar; th arbitary
8530 kcs=(-1)**int(1.5d0+pyr(0))
8531 mint(21)=isign(mint(56),kcs)
8532 mint(22)=-mint(21)
8533 kcc=21
8534
8535 ELSEIF(isub.GE.86.AND.isub.LE.89) THEN
8536C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
8537 mint(21)=kfpr(isub,1)
8538 mint(22)=kfpr(isub,2)
8539 kcc=24
8540 kcs=(-1)**int(1.5d0+pyr(0))
8541 ENDIF
8542
8543 ELSEIF(isub.LE.100) THEN
8544 IF(isub.EQ.95) THEN
8545C...Low-pT ( = energyless g + g -> g + g)
8546 kcc=mint(2)+12
8547 kcs=(-1)**int(1.5d0+pyr(0))
8548
8549 ELSEIF(isub.EQ.96) THEN
8550C...Multiple interactions (should be reassigned to QCD process)
8551 ENDIF
8552
8553 ELSEIF(isub.LE.110) THEN
8554 IF(isub.EQ.101) THEN
8555C...g + g -> gamma*/Z0
8556 kcc=21
8557 kfres=22
8558
8559 ELSEIF(isub.EQ.102) THEN
8560C...g + g -> h0 (or H0, or A0)
8561 kcc=21
8562 kfres=kfhigg
8563
8564 ELSEIF(isub.EQ.103) THEN
8565C...gamma + gamma -> h0 (or H0, or A0)
8566 kcc=21
8567 kfres=kfhigg
8568
8569 ELSEIF(isub.EQ.104.OR.isub.EQ.105) THEN
8570C...g + g -> chi_0c or chi_2c.
8571 kcc=21
8572 kfres=kfpr(isub,1)
8573
8574 ELSEIF(isub.EQ.106) THEN
8575C...g + g -> J/Psi + gamma
8576 mint(21)=kfpr(isub,1)
8577 mint(22)=kfpr(isub,2)
8578 kcc=21
8579
8580 ELSEIF(isub.EQ.107) THEN
8581C...g + gamma -> J/Psi + g
8582 mint(21)=kfpr(isub,1)
8583 mint(22)=kfpr(isub,2)
8584 kcc=22
8585 IF(mint(16).EQ.22) kcc=33
8586
8587 ELSEIF(isub.EQ.108) THEN
8588C...gamma + gamma -> J/Psi + gamma
8589 mint(21)=kfpr(isub,1)
8590 mint(22)=kfpr(isub,2)
8591
8592 ELSEIF(isub.EQ.110) THEN
8593C...f + fbar -> gamma + h0; th arbitrary
8594 IF(pyr(0).GT.0.5d0) js=2
8595 mint(20+js)=22
8596 mint(23-js)=kfhigg
8597 ENDIF
8598
8599 ELSEIF(isub.LE.120) THEN
8600 IF(isub.EQ.111) THEN
8601C...f + fbar -> g + h0; th arbitrary
8602 IF(pyr(0).GT.0.5d0) js=2
8603 mint(20+js)=21
8604 mint(23-js)=25
8605 kcc=17+js
8606
8607 ELSEIF(isub.EQ.112) THEN
8608C...f + g -> f + h0; th = (p(f) - p(f))**2
8609 IF(mint(15).EQ.21) js=2
8610 mint(23-js)=25
8611 kcc=15+js
8612 kcs=isign(1,mint(14+js))
8613
8614 ELSEIF(isub.EQ.113) THEN
8615C...g + g -> g + h0; th arbitrary
8616 IF(pyr(0).GT.0.5d0) js=2
8617 mint(23-js)=25
8618 kcc=22+js
8619 kcs=(-1)**int(1.5d0+pyr(0))
8620
8621 ELSEIF(isub.EQ.114) THEN
8622C...g + g -> gamma + gamma; th arbitrary
8623 IF(pyr(0).GT.0.5d0) js=2
8624 mint(21)=22
8625 mint(22)=22
8626 kcc=21
8627
8628 ELSEIF(isub.EQ.115) THEN
8629C...g + g -> g + gamma; th arbitrary
8630 IF(pyr(0).GT.0.5d0) js=2
8631 mint(23-js)=22
8632 kcc=22+js
8633 kcs=(-1)**int(1.5d0+pyr(0))
8634
8635 ELSEIF(isub.EQ.116) THEN
8636C...g + g -> gamma + Z0
8637
8638 ELSEIF(isub.EQ.117) THEN
8639C...g + g -> Z0 + Z0
8640
8641 ELSEIF(isub.EQ.118) THEN
8642C...g + g -> W+ + W-
8643 ENDIF
8644
8645 ELSEIF(isub.LE.140) THEN
8646 IF(isub.EQ.121) THEN
8647C...g + g -> Q + Qbar + h0
8648 kcs=(-1)**int(1.5d0+pyr(0))
8649 mint(21)=isign(kfpr(isubsv,2),kcs)
8650 mint(22)=-mint(21)
8651 kcc=11+int(0.5d0+pyr(0))
8652 kfres=kfhigg
8653
8654 ELSEIF(isub.EQ.122) THEN
8655C...q + qbar -> Q + Qbar + h0
8656 mint(21)=isign(kfpr(isubsv,2),mint(15))
8657 mint(22)=-mint(21)
8658 kcc=4
8659 kfres=kfhigg
8660
8661 ELSEIF(isub.EQ.123) THEN
8662C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
8663C...inner process)
8664 kcc=22
8665 kfres=kfhigg
8666
8667 ELSEIF(isub.EQ.124) THEN
8668C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
8669C...inner process)
8670 DO 430 jt=1,2
8671 i=mint(14+jt)
8672 ia=iabs(i)
8673 IF(ia.LE.10) THEN
8674 rvckm=vint(180+i)*pyr(0)
8675 DO 420 j=1,mstp(1)
8676 ib=2*j-1+mod(ia,2)
8677 ipm=(5-isign(1,i))/2
8678 idc=j+mdcy(ia,2)+2
8679 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 420
8680 mint(20+jt)=isign(ib,i)
8681 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
8682 IF(rvckm.LE.0d0) GOTO 430
8683 420 CONTINUE
8684 ELSE
8685 ib=2*((ia+1)/2)-1+mod(ia,2)
8686 mint(20+jt)=isign(ib,i)
8687 ENDIF
8688 430 CONTINUE
8689 kcc=22
8690 kfres=kfhigg
8691
8692 ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
8693C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
8694 IF(mint(15).EQ.22) js=2
8695 mint(23-js)=21
8696 kcc=24+js
8697 kcs=isign(1,mint(14+js))
8698
8699 ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
8700C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
8701 IF(mint(15).EQ.22) js=2
8702 kcc=22
8703 kcs=isign(1,mint(14+js))
8704
8705 ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
8706C...g + gamma*_(T,L) -> f + fbar; th arbitrary
8707 kcs=(-1)**int(1.5d0+pyr(0))
8708 mint(21)=isign(kflf,kcs)
8709 mint(22)=-mint(21)
8710 kcc=27
8711 IF(mint(16).EQ.21) kcc=28
8712
8713 ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
8714C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
8715 kcs=(-1)**int(1.5d0+pyr(0))
8716 mint(21)=isign(kflf,kcs)
8717 mint(22)=-mint(21)
8718 kcc=21
8719
8720 ENDIF
8721
8722 ELSEIF(isub.LE.160) THEN
8723 IF(isub.EQ.141) THEN
8724C...f + fbar -> gamma*/Z0/Z'0
8725 kfres=32
8726
8727 ELSEIF(isub.EQ.142) THEN
8728C...f + fbar' -> W'+/-
8729 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8730 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8731 kfres=isign(34,kch1+kch2)
8732
8733 ELSEIF(isub.EQ.143) THEN
8734C...f + fbar' -> H+/-
8735 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8736 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8737 kfres=isign(37,kch1+kch2)
8738
8739 ELSEIF(isub.EQ.144) THEN
8740C...f + fbar' -> R
8741 kfres=isign(40,mint(15)+mint(16))
8742
8743 ELSEIF(isub.EQ.145) THEN
8744C...q + l -> LQ (leptoquark)
8745 IF(iabs(mint(16)).LE.8) js=2
8746 kfres=isign(39,mint(14+js))
8747 kcc=28+js
8748 kcs=isign(1,mint(14+js))
8749
8750 ELSEIF(isub.EQ.146) THEN
8751C...e + gamma -> e* (excited lepton)
8752 IF(mint(15).EQ.22) js=2
8753 kfres=isign(kfpr(isub,1),mint(14+js))
8754 kcc=22
8755
8756 ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
8757C...q + g -> q* (excited quark)
8758 IF(mint(15).EQ.21) js=2
8759 kfres=isign(kfpr(isub,1),mint(14+js))
8760 kcc=30+js
8761 kcs=isign(1,mint(14+js))
8762
8763 ELSEIF(isub.EQ.149) THEN
8764C...g + g -> eta_techni
8765 kfres=38
8766 kcc=23
8767 kcs=(-1)**int(1.5d0+pyr(0))
8768 ENDIF
8769
8770 ELSEIF(isub.LE.200) THEN
8771 IF(isub.EQ.161) THEN
8772C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
8773 IF(mint(15).EQ.21) js=2
8774 i=mint(14+js)
8775 ia=iabs(i)
8776 mint(23-js)=isign(37,kchg(ia,1)*i)
8777 ib=ia+mod(ia,2)-mod(ia+1,2)
8778 mint(20+js)=isign(ib,i)
8779 kcc=15+js
8780 kcs=isign(1,mint(14+js))
8781
8782 ELSEIF(isub.EQ.162) THEN
8783C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
8784 IF(mint(15).EQ.21) js=2
8785 mint(20+js)=isign(39,mint(14+js))
8786 kflql=kfdp(mdcy(39,2),2)
8787 mint(23-js)=-isign(kflql,mint(14+js))
8788 kcc=15+js
8789 kcs=isign(1,mint(14+js))
8790
8791 ELSEIF(isub.EQ.163) THEN
8792C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
8793 kcs=(-1)**int(1.5d0+pyr(0))
8794 mint(21)=isign(39,kcs)
8795 mint(22)=-mint(21)
8796 kcc=mint(2)+10
8797
8798 ELSEIF(isub.EQ.164) THEN
8799C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
8800 mint(21)=isign(39,mint(15))
8801 mint(22)=-mint(21)
8802 kcc=4
8803
8804 ELSEIF(isub.EQ.165) THEN
8805C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
8806 mint(21)=isign(kfpr(isub,1),mint(15))
8807 mint(22)=-mint(21)
8808
8809 ELSEIF(isub.EQ.166) THEN
8810C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
8811 IF(mod(mint(15),2).EQ.0) THEN
8812 mint(21)=isign(kfpr(isub,1)+1,mint(15))
8813 mint(22)=isign(kfpr(isub,1),mint(16))
8814 ELSE
8815 mint(21)=isign(kfpr(isub,1),mint(15))
8816 mint(22)=isign(kfpr(isub,1)+1,mint(16))
8817 ENDIF
8818
8819 ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
8820C...q + q' -> q" + q* (excited quark)
8821 kfqstr=kfpr(isub,2)
8822 kfqexc=mod(kfqstr,kexcit)
8823 js=mint(2)
8824 mint(20+js)=isign(kfqstr,mint(14+js))
8825 IF(iabs(mint(15)).NE.kfqexc.AND.iabs(mint(16)).NE.kfqexc)
8826 & mint(23-js)=isign(kfqexc,mint(17-js))
8827 kcc=22
8828
8829 ELSEIF(isub.EQ.169) THEN
8830C...q + qbar -> e + e* (excited lepton)
8831 kfqstr=kfpr(isub,2)
8832 kfqexc=mod(kfqstr,kexcit)
8833 js=mint(2)
8834 mint(20+js)=isign(kfqstr,mint(14+js))
8835 mint(23-js)=isign(kfqexc,mint(17-js))
8836
8837 ELSEIF(isub.EQ.191) THEN
8838C...f + fbar -> rho_tech0.
8839 kfres=54
8840
8841 ELSEIF(isub.EQ.192) THEN
8842C...f + fbar' -> rho_tech+/-
8843 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8844 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8845 kfres=isign(55,kch1+kch2)
8846
8847 ELSEIF(isub.EQ.193) THEN
8848C...f + fbar -> omega_tech0.
8849 kfres=56
8850
8851 ELSEIF(isub.EQ.194) THEN
8852C...f + fbar -> f' + fbar' via mixture of s-channel
8853C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
8854 mint(21)=isign(kfpr(isub,1),mint(15))
8855 mint(22)=-mint(21)
8856
8857 ELSEIF(isub.EQ.195) THEN
8858C...f + fbar' -> f'' + fbar''' via s-channel
8859C...rho_tech+ th=(p(f)-p(f'))**2
8860C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
8861 IF(mod(mint(15),2).EQ.0) THEN
8862 mint(21)=isign(kfpr(isub,1)+1,mint(15))
8863 mint(22)=isign(kfpr(isub,1),mint(16))
8864 ELSE
8865 mint(21)=isign(kfpr(isub,1),mint(15))
8866 mint(22)=isign(kfpr(isub,1)+1,mint(16))
8867 ENDIF
8868 ENDIF
8869
8870CMRENNA++
8871 ELSEIF(isub.LE.215) THEN
8872 IF(isub.EQ.201) THEN
8873C...f + fbar -> ~e_L + ~e_Lbar
8874 mint(21)=isign(ksusy1+11,kcs)
8875 mint(22)=-mint(21)
8876
8877 ELSEIF(isub.EQ.202) THEN
8878C...f + fbar -> ~e_R + ~e_Rbar
8879 mint(21)=isign(ksusy2+11,kcs)
8880 mint(22)=-mint(21)
8881
8882 ELSEIF(isub.EQ.203) THEN
8883C...f + fbar -> ~e_R + ~e_Lbar
8884 kcsg=1
8885 IF(mint(2).EQ.2) kcsg=-1
8886 mint(21)=isign(ksusy1+11,kcsg)
8887 mint(22)=-isign(ksusy2+11,kcsg)
8888
8889 ELSEIF(isub.EQ.204) THEN
8890C...f + fbar -> ~mu_L + ~mu_Lbar
8891 mint(21)=isign(ksusy1+13,kcs)
8892 mint(22)=-mint(21)
8893
8894 ELSEIF(isub.EQ.205) THEN
8895C...f + fbar -> ~mu_R + ~mu_Rbar
8896 mint(21)=isign(ksusy2+13,kcs)
8897 mint(22)=-mint(21)
8898
8899 ELSEIF(isub.EQ.206) THEN
8900C...f + fbar -> ~mu_L + ~mu_Rbar
8901 kcsg=1
8902 IF(mint(2).EQ.2) kcsg=-1
8903 mint(21)=isign(ksusy1+13,kcsg)
8904 mint(22)=-isign(ksusy2+13,kcsg)
8905
8906 ELSEIF(isub.EQ.207) THEN
8907C...f + fbar -> ~tau_1 + ~tau_1bar
8908 mint(21)=isign(ksusy1+15,kcs)
8909 mint(22)=-mint(21)
8910
8911 ELSEIF(isub.EQ.208) THEN
8912C...f + fbar -> ~tau_2 + ~tau_2bar
8913 mint(21)=isign(ksusy2+15,kcs)
8914 mint(22)=-mint(21)
8915
8916 ELSEIF(isub.EQ.209) THEN
8917C...f + fbar -> ~tau_1 + ~tau_2bar
8918 kcsg=1
8919 IF(mint(2).EQ.2) kcsg=-1
8920 mint(21)=isign(ksusy1+15,kcsg)
8921 mint(22)=-isign(ksusy2+15,kcsg)
8922
8923 ELSEIF(isub.EQ.210) THEN
8924C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
8925 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8926 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8927 mint(21)=-isign(kfpr(isub,1),kch1+kch2)
8928 mint(22)=isign(kfpr(isub,2),kch1+kch2)
8929
8930 ELSEIF(isub.EQ.211) THEN
8931C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
8932 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8933 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8934 mint(21)=-isign(ksusy1+15,kch1+kch2)
8935 mint(22)=isign(ksusy1+16,kch1+kch2)
8936
8937 ELSEIF(isub.EQ.212) THEN
8938C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
8939 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
8940 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
8941 mint(21)=-isign(ksusy2+15,kch1+kch2)
8942 mint(22)=isign(ksusy1+16,kch1+kch2)
8943
8944 ELSEIF(isub.EQ.213) THEN
8945C...f + fbar -> ~nul + ~nulbar
8946 mint(21)=isign(kfpr(isub,1),kcs)
8947 mint(22)=-mint(21)
8948
8949 ELSEIF(isub.EQ.214) THEN
8950C...f + fbar -> ~nutau + ~nutaubar
8951 mint(21)=isign(ksusy1+16,kcs)
8952 mint(22)=-mint(21)
8953 ENDIF
8954
8955 ELSEIF(isub.LE.225) THEN
8956 IF(isub.EQ.216) THEN
8957C...f + fbar -> ~chi01 + ~chi01
8958 mint(21)=ksusy1+22
8959 mint(22)=ksusy1+22
8960
8961 ELSEIF(isub.EQ.217) THEN
8962C...f + fbar -> ~chi02 + ~chi02
8963 mint(21)=ksusy1+23
8964 mint(22)=ksusy1+23
8965
8966 ELSEIF(isub.EQ.218 ) THEN
8967C...f + fbar -> ~chi03 + ~chi03
8968 mint(21)=ksusy1+25
8969 mint(22)=ksusy1+25
8970
8971 ELSEIF(isub.EQ.219 ) THEN
8972C...f + fbar -> ~chi04 + ~chi04
8973 mint(21)=ksusy1+35
8974 mint(22)=ksusy1+35
8975
8976 ELSEIF(isub.EQ.220 ) THEN
8977C...f + fbar -> ~chi01 + ~chi02
8978 IF(pyr(0).GT.0.5d0) js=2
8979 mint(20+js)=ksusy1+22
8980 mint(23-js)=ksusy1+23
8981
8982 ELSEIF(isub.EQ.221 ) THEN
8983C...f + fbar -> ~chi01 + ~chi03
8984 IF(pyr(0).GT.0.5d0) js=2
8985 mint(20+js)=ksusy1+22
8986 mint(23-js)=ksusy1+25
8987
8988 ELSEIF(isub.EQ.222) THEN
8989C...f + fbar -> ~chi01 + ~chi04
8990 IF(pyr(0).GT.0.5d0) js=2
8991 mint(20+js)=ksusy1+22
8992 mint(23-js)=ksusy1+35
8993
8994 ELSEIF(isub.EQ.223) THEN
8995C...f + fbar -> ~chi02 + ~chi03
8996 IF(pyr(0).GT.0.5d0) js=2
8997 mint(20+js)=ksusy1+23
8998 mint(23-js)=ksusy1+25
8999
9000 ELSEIF(isub.EQ.224) THEN
9001C...f + fbar -> ~chi02 + ~chi04
9002 IF(pyr(0).GT.0.5d0) js=2
9003 mint(20+js)=ksusy1+23
9004 mint(23-js)=ksusy1+35
9005
9006 ELSEIF(isub.EQ.225) THEN
9007C...f + fbar -> ~chi03 + ~chi04
9008 IF(pyr(0).GT.0.5d0) js=2
9009 mint(20+js)=ksusy1+25
9010 mint(23-js)=ksusy1+35
9011 ENDIF
9012
9013 ELSEIF(isub.LE.236) THEN
9014 IF(isub.EQ.226) THEN
9015C...f + fbar -> ~chi+-1 + ~chi-+1
9016C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
9017 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9018 mint(21)=isign(ksusy1+24,kch1)
9019 mint(22)=-mint(21)
9020
9021 ELSEIF(isub.EQ.227) THEN
9022C...f + fbar -> ~chi+-2 + ~chi-+2
9023 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9024 mint(21)=isign(ksusy1+37,kch1)
9025 mint(22)=-mint(21)
9026
9027 ELSEIF(isub.EQ.228) THEN
9028C...f + fbar -> ~chi+-1 + ~chi-+2
9029C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9030C...js=1 if pyr<.5, js=2 if pyr>.5
9031C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9032C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9033C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9034C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
9035 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9036C KCH1=ISIGN(1,MINT(15))
9037 kch2=int(1-kch1)/2
9038 IF(mint(2).EQ.1) THEN
9039 mint(22-kch2)= -(ksusy1+24)
9040 mint(21+kch2)= ksusy1+37
9041 IF(kch2.EQ.0) js=2
9042 ELSE
9043 mint(21+kch2)= ksusy1+24
9044 mint(22-kch2)= -(ksusy1+37)
9045 IF(kch2.EQ.1) js=2
9046 ENDIF
9047
9048 ELSEIF(isub.EQ.229) THEN
9049C...q + qbar' -> ~chi01 + ~chi+-1
9050C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
9051 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9052 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9053C...CHECK THIS
9054 IF(mod(mint(15),2).NE.0) js=2
9055 mint(20+js)=ksusy1+22
9056 mint(23-js)=isign(ksusy1+24,kch1+kch2)
9057
9058 ELSEIF(isub.EQ.230) THEN
9059C...q + qbar' -> ~chi02 + ~chi+-1
9060 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9061 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9062 IF(mod(mint(15),2).NE.0) js=2
9063 mint(20+js)=ksusy1+23
9064 mint(23-js)=isign(ksusy1+24,kch1+kch2)
9065
9066 ELSEIF(isub.EQ.231) THEN
9067C...q + qbar' -> ~chi03 + ~chi+-1
9068 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9069 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9070 IF(mod(mint(15),2).NE.0) js=2
9071 mint(20+js)=ksusy1+25
9072 mint(23-js)=isign(ksusy1+24,kch1+kch2)
9073
9074 ELSEIF(isub.EQ.232) THEN
9075C...q + qbar' -> ~chi04 + ~chi+-1
9076 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9077 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9078 IF(mod(mint(15),2).NE.0) js=2
9079 mint(20+js)=ksusy1+35
9080 mint(23-js)=isign(ksusy1+24,kch1+kch2)
9081
9082 ELSEIF(isub.EQ.233) THEN
9083C...q + qbar' -> ~chi01 + ~chi+-2
9084 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9085 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9086 IF(mod(mint(15),2).NE.0) js=2
9087 mint(20+js)=ksusy1+22
9088 mint(23-js)=isign(ksusy1+37,kch1+kch2)
9089
9090 ELSEIF(isub.EQ.234) THEN
9091C...q + qbar' -> ~chi02 + ~chi+-2
9092 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9093 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9094 IF(mod(mint(15),2).NE.0) js=2
9095 mint(20+js)=ksusy1+23
9096 mint(23-js)=isign(ksusy1+37,kch1+kch2)
9097
9098 ELSEIF(isub.EQ.235) THEN
9099C...q + qbar' -> ~chi03 + ~chi+-2
9100 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9101 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9102 IF(mod(mint(15),2).NE.0) js=2
9103 mint(20+js)=ksusy1+25
9104 mint(23-js)=isign(ksusy1+37,kch1+kch2)
9105
9106 ELSEIF(isub.EQ.236) THEN
9107C...q + qbar' -> ~chi04 + ~chi+-2
9108 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9109 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9110 IF(mod(mint(15),2).NE.0) js=2
9111 mint(20+js)=ksusy1+35
9112 mint(23-js)=isign(ksusy1+37,kch1+kch2)
9113 ENDIF
9114
9115 ELSEIF(isub.LE.245) THEN
9116 IF(isub.EQ.237) THEN
9117C...q + qbar -> ~chi01 + ~g
9118C...th arbitrary
9119 IF(pyr(0).GT.0.5d0) js=2
9120 mint(20+js)=ksusy1+21
9121 mint(23-js)=ksusy1+22
9122 kcc=17+js
9123
9124 ELSEIF(isub.EQ.238) THEN
9125C...q + qbar -> ~chi02 + ~g
9126C...th arbitrary
9127 IF(pyr(0).GT.0.5d0) js=2
9128 mint(20+js)=ksusy1+21
9129 mint(23-js)=ksusy1+23
9130 kcc=17+js
9131
9132 ELSEIF(isub.EQ.239) THEN
9133C...q + qbar -> ~chi03 + ~g
9134C...th arbitrary
9135 IF(pyr(0).GT.0.5d0) js=2
9136 mint(20+js)=ksusy1+21
9137 mint(23-js)=ksusy1+25
9138 kcc=17+js
9139
9140 ELSEIF(isub.EQ.240) THEN
9141C...q + qbar -> ~chi04 + ~g
9142C...th arbitrary
9143 IF(pyr(0).GT.0.5d0) js=2
9144 mint(20+js)=ksusy1+21
9145 mint(23-js)=ksusy1+35
9146 kcc=17+js
9147
9148 ELSEIF(isub.EQ.241) THEN
9149C...q + qbar' -> ~chi+-1 + ~g
9150C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9151C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9152C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9153C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9154C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
9155 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9156 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9157 js=1
9158 IF(mint(15)*(kch1+kch2).GT.0) js=2
9159 mint(20+js)=ksusy1+21
9160 mint(23-js)=isign(ksusy1+24,kch1+kch2)
9161 kcc=17+js
9162
9163 ELSEIF(isub.EQ.242) THEN
9164C...q + qbar' -> ~chi+-2 + ~g
9165C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9166C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9167C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9168C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9169C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
9170 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9171 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9172 js=1
9173 IF(mint(15)*(kch1+kch2).GT.0) js=2
9174 mint(20+js)=ksusy1+21
9175 mint(23-js)=isign(ksusy1+37,kch1+kch2)
9176 kcc=17+js
9177
9178 ELSEIF(isub.EQ.243) THEN
9179C...q + qbar -> ~g + ~g ; th arbitrary
9180 mint(21)=ksusy1+21
9181 mint(22)=ksusy1+21
9182 kcc=mint(2)+4
9183
9184 ELSEIF(isub.EQ.244) THEN
9185C...g + g -> ~g + ~g ; th arbitrary
9186 kcc=mint(2)+12
9187 kcs=(-1)**int(1.5d0+pyr(0))
9188 mint(21)=ksusy1+21
9189 mint(22)=ksusy1+21
9190 ENDIF
9191
9192 ELSEIF(isub.LE.260) THEN
9193 IF(isub.EQ.246) THEN
9194C...qj + g -> ~qj_L + ~chi01
9195 IF(mint(15).EQ.21) js=2
9196 i=mint(14+js)
9197 ia=iabs(i)
9198 mint(20+js)=isign(ksusy1+ia,i)
9199 mint(23-js)=ksusy1+22
9200 kcc=15+js
9201 kcs=isign(1,mint(14+js))
9202
9203 ELSEIF(isub.EQ.247) THEN
9204C...qj + g -> ~qj_R + ~chi01
9205 IF(mint(15).EQ.21) js=2
9206 i=mint(14+js)
9207 ia=iabs(i)
9208 mint(20+js)=isign(ksusy2+ia,i)
9209 mint(23-js)=ksusy1+22
9210 kcc=15+js
9211 kcs=isign(1,mint(14+js))
9212
9213 ELSEIF(isub.EQ.248) THEN
9214C...qj + g -> ~qj_L + ~chi02
9215 IF(mint(15).EQ.21) js=2
9216 i=mint(14+js)
9217 ia=iabs(i)
9218 mint(20+js)=isign(ksusy1+ia,i)
9219 mint(23-js)=ksusy1+23
9220 kcc=15+js
9221 kcs=isign(1,mint(14+js))
9222
9223 ELSEIF(isub.EQ.249) THEN
9224C...qj + g -> ~qj_R + ~chi02
9225 IF(mint(15).EQ.21) js=2
9226 i=mint(14+js)
9227 ia=iabs(i)
9228 mint(20+js)=isign(ksusy2+ia,i)
9229 mint(23-js)=ksusy1+23
9230 kcc=15+js
9231 kcs=isign(1,mint(14+js))
9232
9233 ELSEIF(isub.EQ.250) THEN
9234C...qj + g -> ~qj_L + ~chi03
9235 IF(mint(15).EQ.21) js=2
9236 i=mint(14+js)
9237 ia=iabs(i)
9238 mint(20+js)=isign(ksusy1+ia,i)
9239 mint(23-js)=ksusy1+25
9240 kcc=15+js
9241 kcs=isign(1,mint(14+js))
9242
9243 ELSEIF(isub.EQ.251) THEN
9244C...qj + g -> ~qj_R + ~chi03
9245 IF(mint(15).EQ.21) js=2
9246 i=mint(14+js)
9247 ia=iabs(i)
9248 mint(20+js)=isign(ksusy2+ia,i)
9249 mint(23-js)=ksusy1+25
9250 kcc=15+js
9251 kcs=isign(1,mint(14+js))
9252
9253 ELSEIF(isub.EQ.252) THEN
9254C...qj + g -> ~qj_L + ~chi04
9255 IF(mint(15).EQ.21) js=2
9256 i=mint(14+js)
9257 ia=iabs(i)
9258 mint(20+js)=isign(ksusy1+ia,i)
9259 mint(23-js)=ksusy1+35
9260 kcc=15+js
9261 kcs=isign(1,mint(14+js))
9262
9263 ELSEIF(isub.EQ.253) THEN
9264C...qj + g -> ~qj_R + ~chi04
9265 IF(mint(15).EQ.21) js=2
9266 i=mint(14+js)
9267 ia=iabs(i)
9268 mint(20+js)=isign(ksusy2+ia,i)
9269 mint(23-js)=ksusy1+35
9270 kcc=15+js
9271 kcs=isign(1,mint(14+js))
9272
9273 ELSEIF(isub.EQ.254) THEN
9274C...qj + g -> ~qk_L + ~chi+-1
9275 IF(mint(15).EQ.21) js=2
9276 i=mint(14+js)
9277 ia=iabs(i)
9278 mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
9279 ib=-ia+int((ia+1)/2)*4-1
9280 mint(20+js)=isign(ksusy1+ib,i)
9281 kcc=15+js
9282 kcs=isign(1,mint(14+js))
9283
9284 ELSEIF(isub.EQ.255) THEN
9285C...qj + g -> ~qk_L + ~chi+-1
9286 IF(mint(15).EQ.21) js=2
9287 i=mint(14+js)
9288 ia=iabs(i)
9289 mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
9290 ib=-ia+int((ia+1)/2)*4-1
9291 mint(20+js)=isign(ksusy2+ib,i)
9292 kcc=15+js
9293 kcs=isign(1,mint(14+js))
9294
9295 ELSEIF(isub.EQ.256) THEN
9296C...qj + g -> ~qk_L + ~chi+-2
9297 IF(mint(15).EQ.21) js=2
9298 i=mint(14+js)
9299 ia=iabs(i)
9300 ib=-ia+int((ia+1)/2)*4-1
9301 mint(20+js)=isign(ksusy1+ib,i)
9302 mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
9303 kcc=15+js
9304 kcs=isign(1,mint(14+js))
9305
9306 ELSEIF(isub.EQ.257) THEN
9307C...qj + g -> ~qk_R + ~chi+-2
9308 IF(mint(15).EQ.21) js=2
9309 i=mint(14+js)
9310 ia=iabs(i)
9311 ib=-ia+int((ia+1)/2)*4-1
9312 mint(20+js)=isign(ksusy2+ib,i)
9313 mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
9314 kcc=15+js
9315 kcs=isign(1,mint(14+js))
9316
9317 ELSEIF(isub.EQ.258) THEN
9318C...qj + g -> ~qj_L + ~g
9319 IF(mint(15).EQ.21) js=2
9320 i=mint(14+js)
9321 ia=iabs(i)
9322 mint(20+js)=isign(ksusy1+ia,i)
9323 mint(23-js)=ksusy1+21
9324 kcc=mint(2)+6
9325 IF(js.EQ.2) kcc=kcc+2
9326 kcs=isign(1,i)
9327
9328 ELSEIF(isub.EQ.259) THEN
9329C...qj + g -> ~qj_R + ~g
9330 IF(mint(15).EQ.21) js=2
9331 i=mint(14+js)
9332 ia=iabs(i)
9333 mint(20+js)=isign(ksusy2+ia,i)
9334 mint(23-js)=ksusy1+21
9335 kcc=mint(2)+6
9336 IF(js.EQ.2) kcc=kcc+2
9337 kcs=isign(1,i)
9338 ENDIF
9339
9340 ELSEIF(isub.LE.270) THEN
9341 IF(isub.EQ.261) THEN
9342C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
9343 isgn=1
9344 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
9345 mint(21)=isgn*isign(kfpr(isub,1),kcs)
9346 mint(22)=-mint(21)
9347C...Correct color combination
9348 IF(mint(43).EQ.4) kcc=4
9349
9350 ELSEIF(isub.EQ.262) THEN
9351C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
9352 isgn=1
9353 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
9354 mint(21)=isgn*isign(kfpr(isub,1),kcs)
9355 mint(22)=-mint(21)
9356C...Correct color combination
9357 IF(mint(43).EQ.4) kcc=4
9358
9359 ELSEIF(isub.EQ.263) THEN
9360C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
9361 IF((kcs.GT.0.AND.mint(2).EQ.1).OR.
9362 & (kcs.LT.0.AND.mint(2).EQ.2)) THEN
9363 mint(21)=isign(kfpr(isub,1),kcs)
9364 mint(22)=-isign(kfpr(isub,2),kcs)
9365 ELSE
9366 js=2
9367 mint(21)=isign(kfpr(isub,2),kcs)
9368 mint(22)=-isign(kfpr(isub,1),kcs)
9369 ENDIF
9370C...Correct color combination
9371 IF(mint(43).EQ.4) kcc=4
9372
9373 ELSEIF(isub.EQ.264) THEN
9374C...g + g -> ~t_1 + ~t_1bar; th arbitrary
9375 kcs=(-1)**int(1.5d0+pyr(0))
9376 mint(21)=isign(kfpr(isub,1),kcs)
9377 mint(22)=-mint(21)
9378 kcc=mint(2)+10
9379
9380 ELSEIF(isub.EQ.265) THEN
9381C...g + g -> ~t_2 + ~t_2bar; th arbitrary
9382 kcs=(-1)**int(1.5d0+pyr(0))
9383 mint(21)=isign(kfpr(isub,1),kcs)
9384 mint(22)=-mint(21)
9385 kcc=mint(2)+10
9386 ENDIF
9387
9388 ELSEIF(isub.LE.296) THEN
9389 IF(isub.EQ.271.OR.isub.EQ.281.OR.isub.EQ.291) THEN
9390C...qi + qj -> ~qi_L + ~qj_L
9391 kcc=mint(2)
9392 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
9393 mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
9394 mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
9395
9396 ELSEIF(isub.EQ.272.OR.isub.EQ.282.OR.isub.EQ.292) THEN
9397C...qi + qj -> ~qi_R + ~qj_R
9398 kcc=mint(2)
9399 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
9400 mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
9401 mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
9402
9403 ELSEIF(isub.EQ.273.OR.isub.EQ.283.OR.isub.EQ.293) THEN
9404C...qi + qj -> ~qi_L + ~qj_R
9405 mint(21)=isign(kfpr(isub,1),mint(15))
9406 mint(22)=isign(kfpr(isub,2),mint(16))
9407 kcc=mint(2)
9408 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
9409
9410 ELSEIF(isub.EQ.274.OR.isub.EQ.284) THEN
9411C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
9412 mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
9413 mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
9414 kcc=mint(2)
9415 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
9416
9417 ELSEIF(isub.EQ.275.OR.isub.EQ.285) THEN
9418C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
9419 mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
9420 mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
9421 kcc=mint(2)
9422 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
9423
9424 ELSEIF(isub.EQ.276.OR.isub.EQ.286.OR.isub.EQ.296) THEN
9425C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
9426 mint(21)=isign(kfpr(isub,1),mint(15))
9427 mint(22)=isign(kfpr(isub,2),mint(16))
9428 kcc=mint(2)
9429 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
9430
9431 ELSEIF(isub.EQ.277.OR.isub.EQ.287) THEN
9432C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
9433 isgn=1
9434 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
9435 mint(21)=isgn*isign(kfpr(isub,1),kcs)
9436 mint(22)=-mint(21)
9437 IF(mint(43).EQ.4) kcc=4
9438
9439 ELSEIF(isub.EQ.278.OR.isub.EQ.288) THEN
9440C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
9441 isgn=1
9442 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
9443 mint(21)=isgn*isign(kfpr(isub,1),kcs)
9444 mint(22)=-mint(21)
9445 IF(mint(43).EQ.4) kcc=4
9446
9447 ELSEIF(isub.EQ.279.OR.isub.EQ.289) THEN
9448C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
9449C...pure LL + RR
9450 kcs=(-1)**int(1.5d0+pyr(0))
9451 mint(21)=isign(kfpr(isub,1),kcs)
9452 mint(22)=-mint(21)
9453 kcc=mint(2)+10
9454
9455 ELSEIF(isub.EQ.280.OR.isub.EQ.290) THEN
9456C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
9457 kcs=(-1)**int(1.5d0+pyr(0))
9458 mint(21)=isign(kfpr(isub,1),kcs)
9459 mint(22)=-mint(21)
9460 kcc=mint(2)+10
9461
9462 ELSEIF(isub.EQ.294) THEN
9463C...qj + g -> ~qj_L + ~g
9464 IF(mint(15).EQ.21) js=2
9465 i=mint(14+js)
9466 ia=iabs(i)
9467 mint(20+js)=isign(ksusy1+ia,i)
9468 mint(23-js)=ksusy1+21
9469 kcc=mint(2)+6
9470 IF(js.EQ.2) kcc=kcc+2
9471 kcs=isign(1,i)
9472
9473 ELSEIF(isub.EQ.295) THEN
9474C...qj + g -> ~qj_R + ~g
9475 IF(mint(15).EQ.21) js=2
9476 i=mint(14+js)
9477 ia=iabs(i)
9478 mint(20+js)=isign(ksusy2+ia,i)
9479 mint(23-js)=ksusy1+21
9480 kcc=mint(2)+6
9481 IF(js.EQ.2) kcc=kcc+2
9482 kcs=isign(1,i)
9483 ENDIF
9484
9485 ELSEIF(isub.LE.340) THEN
9486
9487 IF(isub.EQ.297.OR.isub.EQ.298) THEN
9488C...q + qbar' -> H+ + H0
9489 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9490 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9491 IF(mint(15)*(kch1+kch2).GT.0) js=2
9492 mint(20+js)=isign(37,kch1+kch2)
9493 mint(23-js)=kfpr(isub,2)
9494 ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
9495C...f + fbar -> A0 + H0; th arbitrary
9496 IF(pyr(0).GT.0.5d0) js=2
9497 mint(20+js)=kfpr(isub,1)
9498 mint(23-js)=kfpr(isub,2)
9499 ELSEIF(isub.EQ.301) THEN
9500C...f + fbar -> H+ H-
9501 mint(21)=isign(kfpr(isub,1),kcs)
9502 mint(22)=-mint(21)
9503 ENDIF
9504CMRENNA--
9505
9506 ELSEIF(isub.LE.360) THEN
9507
9508 IF(isub.EQ.341.OR.isub.EQ.342) THEN
9509C...l + l -> H_L++/--, H_R++/--
9510 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9511 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9512 kfres=isign(kfpr(isub,1),kch1+kch2)
9513
9514 ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
9515C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
9516 IF(mint(15).EQ.22) js=2
9517 mint(20+js)=isign(kfpr(isub,1),-mint(14+js))
9518 mint(23-js)=isign(kfpr(isub,2),-mint(14+js))
9519 kcc=22
9520
9521 ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
9522C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
9523 mint(21)=-isign(kfpr(isub,1),mint(15))
9524 mint(22)=-mint(21)
9525
9526 ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
9527C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
9528C...as inner process).
9529 DO 432 jt=1,2
9530 i=mint(14+jt)
9531 ia=iabs(i)
9532 IF(ia.LE.10) THEN
9533 rvckm=vint(180+i)*pyr(0)
9534 DO 422 j=1,mstp(1)
9535 ib=2*j-1+mod(ia,2)
9536 ipm=(5-isign(1,i))/2
9537 idc=j+mdcy(ia,2)+2
9538 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 422
9539 mint(20+jt)=isign(ib,i)
9540 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
9541 IF(rvckm.LE.0d0) GOTO 432
9542 422 CONTINUE
9543 ELSE
9544 ib=2*((ia+1)/2)-1+mod(ia,2)
9545 mint(20+jt)=isign(ib,i)
9546 ENDIF
9547 432 CONTINUE
9548 kcc=22
9549 kfres=isign(kfpr(isub,1),mint(15))
9550 IF(mod(mint(15),2).EQ.1) kfres=-kfres
9551
9552 ENDIF
9553
9554 ELSEIF(isub.LE.380) THEN
9555 IF(isub.LE.363.OR.isub.EQ.368) THEN
9556C...f + fbar -> pi+ pi-
9557 ksw=(-1)**int(1.5d0+pyr(0))
9558 mint(21)=isign(kfpr(isub,1),ksw)
9559 mint(22)=-isign(kfpr(isub,2),ksw)
9560C...f + fbar -> neutral neutral
9561 ELSEIF(isub.LE.367) THEN
9562 mint(21)=kfpr(isub,1)
9563 mint(22)=kfpr(isub,2)
9564C...f + fbar' -> charged neutral
9565 ELSEIF(isub.EQ.374.OR.isub.EQ.375) THEN
9566 in=1
9567 ic=2
9568 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9569 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9570 IF(mint(15)*(kch1+kch2).LT.0) js=2
9571c MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9572c MINT(23-JS)=KFPR(ISUB,IN)
9573 mint(23-js)=isign(kfpr(isub,ic),kch1+kch2)
9574 mint(20+js)=kfpr(isub,in)
9575
9576 ELSEIF(isub.GE.370.AND.isub.LE.377) THEN
9577 in=2
9578 ic=1
9579 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
9580 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
9581 IF(mint(15)*(kch1+kch2).GT.0) js=2
9582 mint(20+js)=isign(kfpr(isub,ic),kch1+kch2)
9583 mint(23-js)=kfpr(isub,in)
9584 ENDIF
9585 ENDIF
9586
9587 IF(iset(isub).EQ.11) THEN
9588C...Store documentation for user-defined processes
9589 bezup=(pup(1,4)-pup(2,4))/(pup(1,4)+pup(2,4))
9590 kuppo(1)=mint(83)+5
9591 kuppo(2)=mint(83)+6
9592 i=mint(83)+6
9593 DO 450 iup=3,nup
9594 kuppo(iup)=0
9595 IF(mstp(128).GE.2.AND.kup(iup,3).NE.0) THEN
9596 idoc=idoc-1
9597 mint(4)=mint(4)-1
9598 GOTO 450
9599 ENDIF
9600 i=i+1
9601 kuppo(iup)=i
9602 k(i,1)=21
9603 k(i,2)=kup(iup,2)
9604 k(i,3)=0
9605 IF(kup(iup,3).NE.0) k(i,3)=kuppo(kup(iup,3))
9606 k(i,4)=0
9607 k(i,5)=0
9608 DO 440 j=1,5
9609 p(i,j)=pup(iup,j)
9610 440 CONTINUE
9611 450 CONTINUE
9612 CALL pyrobo(mint(83)+7,mint(83)+4+nup,0d0,vint(24),0d0,0d0,
9613 & -bezup)
9614
9615C...Store final state partons for user-defined processes
9616 n=ipu2
9617 DO 470 iup=3,nup
9618 n=n+1
9619 k(n,1)=1
9620 IF(kup(iup,1).NE.1) k(n,1)=11
9621 k(n,2)=kup(iup,2)
9622 IF(mstp(128).LE.0.OR.kup(iup,3).EQ.0) THEN
9623 k(n,3)=kuppo(iup)
9624 ELSE
9625 k(n,3)=mint(84)+kup(iup,3)
9626 ENDIF
9627 k(n,4)=0
9628 k(n,5)=0
9629 DO 460 j=1,5
9630 p(n,j)=pup(iup,j)
9631 460 CONTINUE
9632 470 CONTINUE
9633 CALL pyrobo(ipu3,n,0d0,vint(24),0d0,0d0,-bezup)
9634
9635C...Arrange colour flow for user-defined processes
9636 n=mint(84)
9637 DO 480 iup=1,nup
9638 n=n+1
9639 IF(kchg(pycomp(k(n,2)),2).EQ.0) GOTO 480
9640 IF(k(n,1).EQ.1) k(n,1)=3
9641 IF(k(n,1).EQ.11) k(n,1)=14
9642 IF(kup(iup,4).NE.0) k(n,4)=k(n,4)+mstu(5)*(kup(iup,4)+
9643 & mint(84))
9644 IF(kup(iup,5).NE.0) k(n,5)=k(n,5)+mstu(5)*(kup(iup,5)+
9645 & mint(84))
9646 IF(kup(iup,6).NE.0) k(n,4)=k(n,4)+kup(iup,6)+mint(84)
9647 IF(kup(iup,7).NE.0) k(n,5)=k(n,5)+kup(iup,7)+mint(84)
9648 480 CONTINUE
9649
9650 ELSEIF(idoc.EQ.7) THEN
9651C...Resonance not decaying; store kinematics
9652 i=mint(83)+7
9653 k(ipu3,1)=1
9654 k(ipu3,2)=kfres
9655 k(ipu3,3)=i
9656 p(ipu3,4)=shuser
9657 p(ipu3,5)=shuser
9658 k(i,1)=21
9659 k(i,2)=kfres
9660 p(i,4)=shuser
9661 p(i,5)=shuser
9662 n=ipu3
9663 mint(21)=kfres
9664 mint(22)=0
9665
9666C...Special cases: colour flow in coloured resonances
9667 kcres=pycomp(kfres)
9668 IF(kchg(kcres,2).NE.0) THEN
9669 k(ipu3,1)=3
9670 DO 490 j=1,2
9671 jc=j
9672 IF(kcs.EQ.-1) jc=3-j
9673 IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
9674 & mint(84)+icol(kcc,1,jc)
9675 IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
9676 & mint(84)+icol(kcc,2,jc)
9677 IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
9678 & mstu(5)*(mint(84)+icol(kcc,3,jc))
9679 490 CONTINUE
9680 ELSE
9681 k(ipu1,4)=ipu2
9682 k(ipu1,5)=ipu2
9683 k(ipu2,4)=ipu1
9684 k(ipu2,5)=ipu1
9685 ENDIF
9686
9687 ELSEIF(idoc.EQ.8) THEN
9688C...2 -> 2 processes: store outgoing partons in their CM-frame
9689 DO 500 jt=1,2
9690 i=mint(84)+2+jt
9691 kca=pycomp(mint(20+jt))
9692 k(i,1)=1
9693 IF(kchg(kca,2).NE.0) k(i,1)=3
9694 k(i,2)=mint(20+jt)
9695 k(i,3)=mint(83)+idoc+jt-2
9696 kfaa=iabs(k(i,2))
9697 IF(kfpr(isubsv,1+mod(js+jt,2)).NE.0) THEN
9698 p(i,5)=sqrt(vint(63+mod(js+jt,2)))
9699 ELSE
9700 p(i,5)=pymass(k(i,2))
9701 ENDIF
9702 IF((kfaa.EQ.6.OR.kfaa.EQ.7.OR.kfaa.EQ.8).AND.
9703 & p(i,5).LT.parp(42)) p(i,5)=pymass(k(i,2))
9704 500 CONTINUE
9705 IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN
9706 kfa1=iabs(mint(21))
9707 kfa2=iabs(mint(22))
9708 IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))
9709 & THEN
9710 mint(51)=1
9711 RETURN
9712 ENDIF
9713 p(ipu3,5)=0d0
9714 p(ipu4,5)=0d0
9715 ENDIF
9716 p(ipu3,4)=0.5d0*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)
9717 p(ipu3,3)=sqrt(max(0d0,p(ipu3,4)**2-p(ipu3,5)**2))
9718 p(ipu4,4)=shr-p(ipu3,4)
9719 p(ipu4,3)=-p(ipu3,3)
9720 n=ipu4
9721 mint(7)=mint(83)+7
9722 mint(8)=mint(83)+8
9723
9724C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
9725 CALL pyrobo(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)
9726
9727 ELSEIF(idoc.EQ.9) THEN
9728C...2 -> 3 processes: store outgoing partons in their CM frame
9729 DO 510 jt=1,2
9730 i=mint(84)+2+jt
9731 kca=pycomp(mint(20+jt))
9732 k(i,1)=1
9733 IF(kchg(kca,2).NE.0) k(i,1)=3
9734 k(i,2)=mint(20+jt)
9735 k(i,3)=mint(83)+idoc+jt-3
9736 IF(iabs(k(i,2)).LE.22) THEN
9737 p(i,5)=pymass(k(i,2))
9738 ELSE
9739 p(i,5)=sqrt(vint(63+mod(js+jt,2)))
9740 ENDIF
9741 pt=sqrt(max(0d0,vint(197+5*jt)-p(i,5)**2+vint(196+5*jt)**2))
9742 p(i,1)=pt*cos(vint(198+5*jt))
9743 p(i,2)=pt*sin(vint(198+5*jt))
9744 510 CONTINUE
9745 k(ipu5,1)=1
9746 k(ipu5,2)=kfres
9747 k(ipu5,3)=mint(83)+idoc
9748 p(ipu5,5)=shr
9749 p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
9750 p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
9751 pms1=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
9752 pms2=p(ipu4,5)**2+p(ipu4,1)**2+p(ipu4,2)**2
9753 pms3=p(ipu5,5)**2+p(ipu5,1)**2+p(ipu5,2)**2
9754 pmt3=sqrt(pms3)
9755 p(ipu5,3)=pmt3*sinh(vint(211))
9756 p(ipu5,4)=pmt3*cosh(vint(211))
9757 pms12=(shpr-p(ipu5,4))**2-p(ipu5,3)**2
9758 sql12=(pms12-pms1-pms2)**2-4d0*pms1*pms2
9759 IF(sql12.LE.0d0) THEN
9760 mint(51)=1
9761 RETURN
9762 ENDIF
9763 p(ipu3,3)=(-p(ipu5,3)*(pms12+pms1-pms2)+
9764 & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
9765 p(ipu4,3)=-p(ipu3,3)-p(ipu5,3)
9766 p(ipu3,4)=sqrt(pms1+p(ipu3,3)**2)
9767 p(ipu4,4)=sqrt(pms2+p(ipu4,3)**2)
9768 mint(23)=kfres
9769 n=ipu5
9770 mint(7)=mint(83)+7
9771 mint(8)=mint(83)+8
9772
9773 ELSEIF(idoc.EQ.11) THEN
9774C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
9775 phi(1)=paru(2)*pyr(0)
9776 phi(2)=phi(1)-phir
9777 DO 520 jt=1,2
9778 i=mint(84)+2+jt
9779 k(i,1)=1
9780 IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
9781 k(i,2)=mint(20+jt)
9782 k(i,3)=mint(83)+idoc+jt-2
9783 p(i,5)=pymass(k(i,2))
9784 IF(0.5d0*shpr*z(jt).LE.p(i,5)) THEN
9785 mint(51)=1
9786 RETURN
9787 ENDIF
9788 pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
9789 ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
9790 p(i,1)=ptabs*cos(phi(jt))
9791 p(i,2)=ptabs*sin(phi(jt))
9792 p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
9793 p(i,4)=0.5d0*shpr*z(jt)
9794 izw=mint(83)+6+jt
9795 k(izw,1)=21
9796 k(izw,2)=23
9797 IF(isub.EQ.8) k(izw,2)=isign(24,pychge(mint(14+jt)))
9798 k(izw,3)=izw-2
9799 p(izw,1)=-p(i,1)
9800 p(izw,2)=-p(i,2)
9801 p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
9802 p(izw,4)=0.5d0*shpr*(1d0-z(jt))
9803 p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
9804 520 CONTINUE
9805 i=mint(83)+9
9806 k(ipu5,1)=1
9807 k(ipu5,2)=kfres
9808 k(ipu5,3)=i
9809 p(ipu5,5)=shr
9810 p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
9811 p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
9812 p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)
9813 p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)
9814 k(i,1)=21
9815 k(i,2)=kfres
9816 DO 530 j=1,5
9817 p(i,j)=p(ipu5,j)
9818 530 CONTINUE
9819 n=ipu5
9820 mint(23)=kfres
9821
9822 ELSEIF(idoc.EQ.12) THEN
9823C...Z0 and W+/- scattering: store bosons and outgoing partons
9824 phi(1)=paru(2)*pyr(0)
9825 phi(2)=phi(1)-phir
9826 jtran=int(1.5d0+pyr(0))
9827 DO 540 jt=1,2
9828 i=mint(84)+2+jt
9829 k(i,1)=1
9830 IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
9831 k(i,2)=mint(20+jt)
9832 k(i,3)=mint(83)+idoc+jt-2
9833 p(i,5)=pymass(k(i,2))
9834 IF(0.5d0*shpr*z(jt).LE.p(i,5)) p(i,5)=0d0
9835 pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
9836 ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
9837 p(i,1)=ptabs*cos(phi(jt))
9838 p(i,2)=ptabs*sin(phi(jt))
9839 p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
9840 p(i,4)=0.5d0*shpr*z(jt)
9841 izw=mint(83)+6+jt
9842 k(izw,1)=21
9843 IF(mint(14+jt).EQ.mint(20+jt)) THEN
9844 k(izw,2)=23
9845 ELSE
9846 k(izw,2)=isign(24,pychge(mint(14+jt))-pychge(mint(20+jt)))
9847 ENDIF
9848 k(izw,3)=izw-2
9849 p(izw,1)=-p(i,1)
9850 p(izw,2)=-p(i,2)
9851 p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
9852 p(izw,4)=0.5d0*shpr*(1d0-z(jt))
9853 p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
9854 ipu=mint(84)+4+jt
9855 k(ipu,1)=3
9856 k(ipu,2)=kfpr(isub,jt)
9857 IF(isub.EQ.72.AND.jt.EQ.jtran) k(ipu,2)=-k(ipu,2)
9858 IF(isub.EQ.73.OR.isub.EQ.77) k(ipu,2)=k(izw,2)
9859 k(ipu,3)=mint(83)+8+jt
9860 IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN
9861 p(ipu,5)=pymass(k(ipu,2))
9862 ELSE
9863 p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))
9864 ENDIF
9865 mint(22+jt)=k(ipu,2)
9866 540 CONTINUE
9867C...Find rotation and boost for hard scattering subsystem
9868 i1=mint(83)+7
9869 i2=mint(83)+8
9870 bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))
9871 beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))
9872 bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))
9873 gamcm=(p(i1,4)+p(i2,4))/shr
9874 bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)
9875 px=p(i1,1)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bexcm
9876 py=p(i1,2)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*beycm
9877 pz=p(i1,3)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bezcm
9878 thecm=pyangl(pz,sqrt(px**2+py**2))
9879 phicm=pyangl(px,py)
9880C...Store hard scattering subsystem. Rotate and boost it
9881 sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4d0*p(ipu5,5)**2*
9882 & p(ipu6,5)**2
9883 pabs=sqrt(max(0d0,sqlam/(4d0*sh)))
9884 cthwz=vint(23)
9885 sthwz=sqrt(max(0d0,1d0-cthwz**2))
9886 phiwz=vint(24)-phicm
9887 p(ipu5,1)=pabs*sthwz*cos(phiwz)
9888 p(ipu5,2)=pabs*sthwz*sin(phiwz)
9889 p(ipu5,3)=pabs*cthwz
9890 p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)
9891 p(ipu6,1)=-p(ipu5,1)
9892 p(ipu6,2)=-p(ipu5,2)
9893 p(ipu6,3)=-p(ipu5,3)
9894 p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)
9895 CALL pyrobo(ipu5,ipu6,thecm,phicm,bexcm,beycm,bezcm)
9896 DO 560 jt=1,2
9897 i1=mint(83)+8+jt
9898 i2=mint(84)+4+jt
9899 k(i1,1)=21
9900 k(i1,2)=k(i2,2)
9901 DO 550 j=1,5
9902 p(i1,j)=p(i2,j)
9903 550 CONTINUE
9904 560 CONTINUE
9905 n=ipu6
9906 mint(7)=mint(83)+9
9907 mint(8)=mint(83)+10
9908 ENDIF
9909
9910 IF(iset(isub).EQ.11) THEN
9911 ELSEIF(idoc.GE.8) THEN
9912C...Store colour connection indices
9913 DO 570 j=1,2
9914 jc=j
9915 IF(kcs.EQ.-1) jc=3-j
9916 IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
9917 & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)
9918 IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
9919 & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)
9920 IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
9921 & mstu(5)*(mint(84)+icol(kcc,3,jc))
9922 IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
9923 & mstu(5)*(mint(84)+icol(kcc,4,jc))
9924 570 CONTINUE
9925
9926C...Copy outgoing partons to documentation lines
9927 imax=2
9928 IF(idoc.EQ.9) imax=3
9929 DO 590 i=1,imax
9930 i1=mint(83)+idoc-imax+i
9931 i2=mint(84)+2+i
9932 k(i1,1)=21
9933 k(i1,2)=k(i2,2)
9934 IF(idoc.LE.9) k(i1,3)=0
9935 IF(idoc.GE.11) k(i1,3)=mint(83)+2+i
9936 DO 580 j=1,5
9937 p(i1,j)=p(i2,j)
9938 580 CONTINUE
9939 590 CONTINUE
9940
9941 ELSEIF(idoc.EQ.9) THEN
9942C...Store colour connection indices
9943 DO 600 j=1,2
9944 jc=j
9945 IF(kcs.EQ.-1) jc=3-j
9946 IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
9947 & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)+
9948 & max(0,min(1,icol(kcc,1,jc)-2))
9949 IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
9950 & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)+
9951 & max(0,min(1,icol(kcc,2,jc)-2))
9952 IF(icol(kcc,3,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
9953 & mstu(5)*(mint(84)+icol(kcc,3,jc))
9954 IF(icol(kcc,4,jc).NE.0.AND.k(ipu5,1).EQ.3) k(ipu5,j+3)=
9955 & mstu(5)*(mint(84)+icol(kcc,4,jc))
9956 600 CONTINUE
9957
9958C...Copy outgoing partons to documentation lines
9959 DO 620 i=1,3
9960 i1=mint(83)+idoc-3+i
9961 i2=mint(84)+2+i
9962 k(i1,1)=21
9963 k(i1,2)=k(i2,2)
9964 k(i1,3)=0
9965 DO 610 j=1,5
9966 p(i1,j)=p(i2,j)
9967 610 CONTINUE
9968 620 CONTINUE
9969 ENDIF
9970
9971C...Low-pT events: remove gluons used for string drawing purposes
9972 IF(isub.EQ.95) THEN
9973 k(ipu3,1)=k(ipu3,1)+10
9974 k(ipu4,1)=k(ipu4,1)+10
9975 DO 630 j=41,66
9976 vintsv(j)=vint(j)
9977 vint(j)=0d0
9978 630 CONTINUE
9979 DO 650 i=mint(83)+5,mint(83)+8
9980 DO 640 j=1,5
9981 p(i,j)=0d0
9982 640 CONTINUE
9983 650 CONTINUE
9984 ENDIF
9985
9986 RETURN
9987 END
9988
9989C*********************************************************************
9990
9991C...PYSSPA
9992C...Generates spacelike parton showers.
9993
9994 SUBROUTINE pysspa(IPU1,IPU2)
9995
9996C...Double precision and integer declarations.
9997 IMPLICIT DOUBLE PRECISION(a-h, o-z)
9998 IMPLICIT INTEGER(I-N)
9999 INTEGER PYK,PYCHGE,PYCOMP
10000C...Commonblocks.
10001 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10002 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
10003 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
10004 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
10005 common/pypars/mstp(200),parp(200),msti(200),pari(200)
10006 common/pyint1/mint(400),vint(400)
10007 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
10008 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
10009 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
10010 &/pyint2/,/pyint3/
10011C...Local arrays and data.
10012 dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevcsv(2),tevesv(2),
10013 &xfs(2,-25:25),xfa(-25:25),xfb(-25:25),xfn(-25:25),wtapc(-25:25),
10014 &wtape(-25:25),wtsf(-25:25),the2(2),alam(2),dq2(3),dpc(3),dpd(4),
10015 &dpb(4),robo(5),more(2),kfbeam(2),q2mncs(2),kcfi(2),nfis(2),
10016 &thefis(2,2),isfi(2)
10017 DATA is/2*0/
10018
10019C...Read out basic information; set global Q^2 scale.
10020 ipus1=ipu1
10021 ipus2=ipu2
10022 isub=mint(1)
10023 q2mx=vint(56)
10024 IF(iset(isub).EQ.2) q2mx=min(vint(2),parp(67)*vint(56))
10025 mecor=0
10026 IF(mstp(68).EQ.1.AND.(isub.EQ.1.OR.isub.EQ.2.OR.
10027 &isub.EQ.141.OR.isub.EQ.142.OR.isub.EQ.144)) mecor=1
10028 fcq2mx=1d0
10029
10030C...Initialize QCD evolution and check phase space.
10031 q2mnc=parp(62)**2
10032 q2mncs(1)=q2mnc
10033 q2mncs(2)=q2mnc
10034 IF(mint(107).EQ.2.AND.mstp(66).EQ.2) THEN
10035 q0s=parp(15)**2
10036 ps=vint(3)**2
10037 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10038 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10039 q2int=sqrt(q0s*q2eff)
10040 q2mncs(1)=max(q2mnc,q2int)
10041 ELSEIF(mint(107).EQ.3.AND.mstp(66).GE.1) THEN
10042 q2mncs(1)=max(q2mnc,vint(283))
10043 ENDIF
10044 IF(mint(108).EQ.2.AND.mstp(66).EQ.2) THEN
10045 q0s=parp(15)**2
10046 ps=vint(4)**2
10047 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10048 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10049 q2int=sqrt(q0s*q2eff)
10050 q2mncs(2)=max(q2mnc,q2int)
10051 ELSEIF(mint(108).EQ.3.AND.mstp(66).GE.1) THEN
10052 q2mncs(2)=max(q2mnc,vint(284))
10053 ENDIF
10054 mcev=0
10055 alams=paru(112)
10056 paru(112)=parp(61)
10057 fq2c=1d0
10058 tcmx=0d0
10059 IF(mint(47).GE.2.AND.(mint(47).LT.5.OR.mstp(12).GE.1)) THEN
10060 mcev=1
10061 IF(mstp(64).EQ.1) fq2c=parp(63)
10062 IF(mstp(64).EQ.2) fq2c=parp(64)
10063 tcmx=log(fq2c*q2mx/parp(61)**2)
10064 IF(q2mx.LT.max(q2mnc,2d0*parp(61)**2).OR.tcmx.LT.0.2d0)
10065 & mcev=0
10066 ENDIF
10067
10068C...Initialize QED evolution and check phase space.
10069 meev=0
10070 xee=1d-10
10071 spme=pmas(11,1)**2
10072 IF(iabs(mint(11)).EQ.13.OR.iabs(mint(12)).EQ.13)
10073 &spme=pmas(13,1)**2
10074 IF(iabs(mint(11)).EQ.15.OR.iabs(mint(12)).EQ.15)
10075 &spme=pmas(15,1)**2
10076 q2mne=max(parp(68)**2,2d0*spme)
10077 temx=0d0
10078 fwte=10d0
10079 IF(mint(45).EQ.3.OR.mint(46).EQ.3) THEN
10080 meev=1
10081 temx=log(q2mx/spme)
10082 IF(q2mx.LE.q2mne.OR.temx.LT.0.2d0) meev=0
10083 ENDIF
10084 IF(mcev.EQ.0.AND.meev.EQ.0) RETURN
10085
10086C...Loopback point in case of failure to reconstruct kinematics.
10087 ns=n
10088 loop=0
10089 100 loop=loop+1
10090 IF(loop.GT.100) THEN
10091 mint(51)=1
10092 RETURN
10093 ENDIF
10094 n=ns
10095
10096C...Initial values: flavours, momenta, virtualities.
10097 DO 120 jt=1,2
10098 more(jt)=1
10099 kfbeam(jt)=mint(10+jt)
10100 IF(mint(18+jt).EQ.1)kfbeam(jt)=22
10101 kfls(jt)=mint(14+jt)
10102 kfls(jt+2)=kfls(jt)
10103 xs(jt)=vint(40+jt)
10104 IF(mint(18+jt).EQ.1) xs(jt)=vint(40+jt)/vint(154+jt)
10105 zs(jt)=1d0
10106 q2s(jt)=fcq2mx*q2mx
10107 tevcsv(jt)=tcmx
10108 alam(jt)=parp(61)
10109 the2(jt)=1d0
10110 tevesv(jt)=temx
10111 DO 110 kfl=-25,25
10112 xfs(jt,kfl)=xsfx(jt,kfl)
10113 110 CONTINUE
10114C...Special kinematics check for c/b quarks (that g -> c cbar or
10115C...b bbar kinematically possible).
10116 kflcb=iabs(kfls(jt))
10117 IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
10118 IF(xs(jt).GT.0.9d0*q2s(jt)/(pmas(kflcb,1)**2+q2s(jt))) THEN
10119 mint(51)=1
10120 RETURN
10121 ENDIF
10122 ENDIF
10123 120 CONTINUE
10124 dsh=vint(44)
10125 IF(iset(isub).GE.3.AND.iset(isub).LE.5) dsh=vint(26)*vint(2)
10126
10127C...Find if interference with final state partons.
10128 mfis=0
10129 IF(mstp(67).GE.1.AND.mstp(67).LE.3) mfis=mstp(67)
10130 IF(mfis.NE.0) THEN
10131 DO 140 i=1,2
10132 kcfi(i)=0
10133 kca=pycomp(iabs(kfls(i)))
10134 IF(kca.NE.0) kcfi(i)=kchg(kca,2)*isign(1,kfls(i))
10135 nfis(i)=0
10136 IF(kcfi(i).NE.0) THEN
10137 IF(i.EQ.1) ipfs=ipus1
10138 IF(i.EQ.2) ipfs=ipus2
10139 DO 130 j=1,2
10140 icsi=mod(k(ipfs,3+j),mstu(5))
10141 IF(icsi.GT.0.AND.icsi.NE.ipus1.AND.icsi.NE.ipus2.AND.
10142 & (kcfi(i).EQ.(-1)**(j+1).OR.kcfi(i).EQ.2)) THEN
10143 nfis(i)=nfis(i)+1
10144 thefis(i,nfis(i))=pyangl(p(icsi,3),sqrt(p(icsi,1)**2+
10145 & p(icsi,2)**2))
10146 IF(i.EQ.2) thefis(i,nfis(i))=paru(1)-thefis(i,nfis(i))
10147 ENDIF
10148 130 CONTINUE
10149 ENDIF
10150 140 CONTINUE
10151 IF(nfis(1)+nfis(2).EQ.0) mfis=0
10152 ENDIF
10153
10154C...Pick up leg with highest virtuality.
10155 150 n=n+1
10156 jt=1
10157 IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2
10158 IF(more(jt).EQ.0) jt=3-jt
10159 kflb=kfls(jt)
10160 xb=xs(jt)
10161 DO 160 kfl=-25,25
10162 xfb(kfl)=xfs(jt,kfl)
10163 160 CONTINUE
10164 dshr=2d0*sqrt(dsh)
10165 dshz=dsh/zs(jt)
10166
10167C...Check if allowed to branch.
10168 mcev=0
10169 IF(iabs(kflb).LE.10.OR.kflb.EQ.21) THEN
10170 mcev=1
10171 xec=max(parp(65)*dshr/vint(2),xb*(1d0/(1d0-parp(66))-1d0))
10172 IF(xb.GE.1d0-2d0*xec) mcev=0
10173 ENDIF
10174 meev=0
10175 IF(mint(44+jt).EQ.3) THEN
10176 meev=1
10177 IF(xb.GE.1d0-2d0*xee) meev=0
10178 IF((iabs(kflb).LE.10.OR.kflb.EQ.21).AND.xb.GE.1d0-2d0*xec)
10179 & meev=0
10180C***Currently kill QED shower for resolved photoproduction.
10181 IF(mint(18+jt).EQ.1) meev=0
10182C***Currently kill shower for W inside electron.
10183 IF(iabs(kflb).EQ.24) THEN
10184 mcev=0
10185 meev=0
10186 ENDIF
10187 ENDIF
10188 IF(mcev.EQ.0.AND.meev.EQ.0) THEN
10189 q2b=0d0
10190 GOTO 250
10191 ENDIF
10192
10193C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
10194 q2b=q2s(jt)
10195 tevcb=tevcsv(jt)
10196 teveb=tevesv(jt)
10197 IF(mstp(62).LE.1) THEN
10198 IF(zs(jt).GT.0.99999d0) THEN
10199 q2b=q2s(jt)
10200 ELSE
10201 q2b=0.5d0*(1d0/zs(jt)+1d0)*q2s(jt)+0.5d0*(1d0/zs(jt)-1d0)*
10202 & (q2s(3-jt)-dsh+sqrt((dsh+q2s(1)+q2s(2))**2+
10203 & 8d0*q2s(1)*q2s(2)*zs(jt)/(1d0-zs(jt))))
10204 ENDIF
10205 IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
10206 IF(meev.EQ.1) teveb=log(q2b/spme)
10207 ENDIF
10208 IF(mcev.EQ.1) THEN
10209 alsdum=pyalps(fq2c*q2b)
10210 tevcb=tevcb+2d0*log(alam(jt)/paru(117))
10211 alam(jt)=paru(117)
10212 b0=(33d0-2d0*mstu(118))/6d0
10213 ENDIF
10214 tevcbs=tevcb
10215 tevebs=teveb
10216
10217C...Select side for interference with final state partons.
10218 IF(mfis.GE.1.AND.n.LE.ns+2) THEN
10219 ifi=n-ns
10220 isfi(ifi)=0
10221 IF(iabs(kcfi(ifi)).EQ.1.AND.nfis(ifi).EQ.1) THEN
10222 isfi(ifi)=1
10223 ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.1) THEN
10224 IF(pyr(0).GT.0.5d0) isfi(ifi)=1
10225 ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.2) THEN
10226 isfi(ifi)=1
10227 IF(pyr(0).GT.0.5d0) isfi(ifi)=2
10228 ENDIF
10229 ENDIF
10230
10231C...Calculate Altarelli-Parisi weights.
10232 DO 170 kfl=-25,25
10233 wtapc(kfl)=0d0
10234 wtape(kfl)=0d0
10235 wtsf(kfl)=0d0
10236 170 CONTINUE
10237C...q -> q, g -> q.
10238 IF(iabs(kflb).LE.10) THEN
10239 wtapc(kflb)=(8d0/3d0)*log((1d0-xec-xb)*(xb+xec)/(xec*(1d0-xec)))
10240 wtapc(21)=0.5d0*(xb/(xb+xec)-xb/(1d0-xec))
10241 IF(mecor.EQ.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2))
10242 & wtapc(21)=3d0*wtapc(21)
10243C...f -> f, gamma -> f.
10244 ELSEIF(iabs(kflb).LE.20) THEN
10245 wtapf1=log((1d0-xee-xb)*(xb+xee)/(xee*(1d0-xee)))
10246 wtapf2=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))
10247 wtape(kflb)=2d0*(wtapf1+wtapf2)
10248 IF(mstp(12).GE.1) wtape(22)=xb/(xb+xee)-xb/(1d0-xee)
10249 IF(mecor.EQ.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2))
10250 & wtape(22)=3d0*wtape(22)
10251C...f -> g, g -> g.
10252 ELSEIF(kflb.EQ.21) THEN
10253 wtapq=(16d0/3d0)*(sqrt((1d0-xec)/xb)-sqrt((xb+xec)/xb))
10254 DO 180 kfl=1,mstp(58)
10255 wtapc(kfl)=wtapq
10256 wtapc(-kfl)=wtapq
10257 180 CONTINUE
10258 wtapc(21)=6d0*log((1d0-xec-xb)/xec)
10259C...f -> gamma, W+, W-.
10260 ELSEIF(kflb.EQ.22) THEN
10261 wtapf=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))/xb
10262 wtape(11)=wtapf
10263 wtape(-11)=wtapf
10264 ELSEIF(kflb.EQ.24) THEN
10265 wtape(-11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
10266 & (xee*(xb+xee)))/xb
10267 ELSEIF(kflb.EQ.-24) THEN
10268 wtape(11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
10269 & (xee*(xb+xee)))/xb
10270 ENDIF
10271
10272C...Calculate parton distribution weights and sum.
10273 ntry=0
10274 190 ntry=ntry+1
10275 IF(ntry.GT.500) THEN
10276 mint(51)=1
10277 RETURN
10278 ENDIF
10279 wtsumc=0d0
10280 wtsume=0d0
10281 xfbo=max(1d-10,xfb(kflb))
10282 DO 200 kfl=-25,25
10283 wtsf(kfl)=xfb(kfl)/xfbo
10284 wtsumc=wtsumc+wtapc(kfl)*wtsf(kfl)
10285 wtsume=wtsume+wtape(kfl)*wtsf(kfl)
10286 200 CONTINUE
10287 wtsumc=max(0.0001d0,wtsumc)
10288 wtsume=max(0.0001d0/fwte,wtsume)
10289
10290C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
10291 ntry2=0
10292 210 ntry2=ntry2+1
10293 IF(ntry2.GT.500) THEN
10294 mint(51)=1
10295 RETURN
10296 ENDIF
10297 IF(mcev.EQ.1) THEN
10298 IF(mstp(64).LE.0) THEN
10299 tevcb=tevcb+log(pyr(0))*paru(2)/(paru(111)*wtsumc)
10300 ELSEIF(mstp(64).EQ.1) THEN
10301 tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/wtsumc))
10302 ELSE
10303 tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/(5d0*wtsumc)))
10304 ENDIF
10305 ENDIF
10306 IF(meev.EQ.1) THEN
10307 teveb=teveb*exp(max(-50d0,log(pyr(0))*paru(2)/
10308 & (paru(101)*fwte*wtsume*temx)))
10309 ENDIF
10310
10311C...Translate t into Q2 scale; choose between QCD and QED evolution.
10312 220 IF(mcev.EQ.1) q2cb=alam(jt)**2*exp(max(-50d0,tevcb))/fq2c
10313 IF(meev.EQ.1) q2eb=spme*exp(max(-50d0,teveb))
10314C...Ensure that Q2 is above threshold for charm/bottom.
10315 kflcb=iabs(kflb)
10316 IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
10317 &mcev.EQ.1) THEN
10318 IF(q2cb.LT.pmas(kflcb,1)**2) THEN
10319 q2cb=1.1*pmas(kflcb,1)**2
10320 tevcb=log(fq2c*q2b/alam(jt)**2)
10321 fcq2mx=min(2d0,1.05d0*fcq2mx)
10322 ENDIF
10323 ENDIF
10324 mce=0
10325 IF(mcev.EQ.0.AND.meev.EQ.0) THEN
10326 ELSEIF(mcev.EQ.1.AND.meev.EQ.0) THEN
10327 IF(q2cb.GT.q2mncs(jt)) mce=1
10328 ELSEIF(mcev.EQ.0.AND.meev.EQ.1) THEN
10329 IF(q2eb.GT.q2mne) mce=2
10330 ELSEIF(q2mncs(jt).GT.q2mne) THEN
10331 mce=1
10332 IF(q2eb.GT.q2cb.OR.q2cb.LE.q2mncs(jt)) mce=2
10333 IF(mce.EQ.2.AND.q2eb.LE.q2mne) mce=0
10334 ELSE
10335 mce=2
10336 IF(q2cb.GT.q2eb.OR.q2eb.LE.q2mne) mce=1
10337 IF(mce.EQ.1.AND.q2cb.LE.q2mncs(jt)) mce=0
10338 ENDIF
10339
10340C...Evolution possibly ended. Update t values.
10341 IF(mce.EQ.0) THEN
10342 q2b=0d0
10343 GOTO 250
10344 ELSEIF(mce.EQ.1) THEN
10345 q2b=q2cb
10346 q2ref=fq2c*q2b
10347 IF(meev.EQ.1) teveb=log(q2b/spme)
10348 ELSE
10349 q2b=q2eb
10350 q2ref=q2b
10351 IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
10352 ENDIF
10353
10354C...Select flavour for branching parton.
10355 IF(mce.EQ.1) wtran=pyr(0)*wtsumc
10356 IF(mce.EQ.2) wtran=pyr(0)*wtsume
10357 kfla=-25
10358 230 kfla=kfla+1
10359 IF(mce.EQ.1) wtran=wtran-wtapc(kfla)*wtsf(kfla)
10360 IF(mce.EQ.2) wtran=wtran-wtape(kfla)*wtsf(kfla)
10361 IF(kfla.LE.24.AND.wtran.GT.0d0) GOTO 230
10362 IF(kfla.EQ.25) THEN
10363 q2b=0d0
10364 GOTO 250
10365 ENDIF
10366
10367C...Choose z value and corrective weight.
10368 wtz=0d0
10369C...q -> q + g.
10370 IF(iabs(kfla).LE.10.AND.iabs(kflb).LE.10) THEN
10371 z=1d0-((1d0-xb-xec)/(1d0-xec))*
10372 & (xec*(1d0-xec)/((xb+xec)*(1d0-xb-xec)))**pyr(0)
10373 wtz=0.5d0*(1d0+z**2)
10374C...q -> g + q.
10375 ELSEIF(iabs(kfla).LE.10.AND.kflb.EQ.21) THEN
10376 z=xb/(sqrt(xb+xec)+pyr(0)*(sqrt(1d0-xec)-sqrt(xb+xec)))**2
10377 wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
10378C...f -> f + gamma.
10379 ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
10380 IF(wtapf1.GT.pyr(0)*(wtapf1+wtapf2)) THEN
10381 z=1d0-((1d0-xb-xee)/(1d0-xee))*
10382 & (xee*(1d0-xee)/((xb+xee)*(1d0-xb-xee)))**pyr(0)
10383 ELSE
10384 z=xb+xb*(xee/(1d0-xee))*
10385 & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
10386 ENDIF
10387 wtz=0.5d0*(1d0+z**2)*(z-xb)/(1d0-xb)
10388C...f -> gamma + f.
10389 ELSEIF(iabs(kfla).LE.20.AND.kflb.EQ.22) THEN
10390 z=xb+xb*(xee/(1d0-xee))*
10391 & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
10392 wtz=0.5d0*(1d0+(1d0-z)**2)*xb*(z-xb)/z
10393C...f -> W+- + f'.
10394 ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).EQ.24) THEN
10395 z=xb+xb*(xee/(1d0-xee))*
10396 & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
10397 wtz=0.5d0*(1d0+(1d0-z)**2)*(xb*(z-xb)/z)*
10398 & (q2b/(q2b+pmas(24,1)**2))
10399C...g -> q + qbar.
10400 ELSEIF(kfla.EQ.21.AND.iabs(kflb).LE.10) THEN
10401 z=xb/(1d0-xec)+pyr(0)*(xb/(xb+xec)-xb/(1d0-xec))
10402 wtz=1d0-2d0*z*(1d0-z)
10403C...g -> g + g.
10404 ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
10405 z=1d0/(1d0+((1d0-xec-xb)/xb)*(xec/(1d0-xec-xb))**pyr(0))
10406 wtz=(1d0-z*(1d0-z))**2
10407C...gamma -> f + fbar.
10408 ELSEIF(kfla.EQ.22.AND.iabs(kflb).LE.20) THEN
10409 z=xb/(1d0-xee)+pyr(0)*(xb/(xb+xee)-xb/(1d0-xee))
10410 wtz=1d0-2d0*z*(1d0-z)
10411 ENDIF
10412 IF(mce.EQ.2) wtz=(wtz/fwte)*(teveb/temx)
10413
10414C...Option with resummation of soft gluon emission as effective z shift.
10415 IF(mce.EQ.1) THEN
10416 IF(mstp(65).GE.1) THEN
10417 rsoft=6d0
10418 IF(kflb.NE.21) rsoft=8d0/3d0
10419 z=z*(tevcb/tevcsv(jt))**(rsoft*xec/((xb+xec)*b0))
10420 IF(z.LE.xb) GOTO 210
10421 ENDIF
10422
10423C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
10424 IF(mstp(64).GE.2) THEN
10425 IF((1d0-z)*q2b.LT.q2mncs(jt)) GOTO 210
10426 alprat=tevcb/(tevcb+log(1d0-z))
10427 IF(alprat.LT.5d0*pyr(0)) GOTO 210
10428 IF(alprat.GT.5d0) wtz=wtz*alprat/5d0
10429 ENDIF
10430 ENDIF
10431
10432C...Remove kinematically impossible branchings.
10433 uhat=q2b-dsh*(1d0-z)/z
10434 IF(mstp(68).GE.0.AND.uhat.GT.0d0) GOTO 210
10435
10436C...Matrix-element corrections for s-channel resonance production.
10437 IF(mecor.EQ.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
10438 shat=dsh/z
10439 that=-q2b
10440 IF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
10441 rmeps=(that**2+uhat**2+2d0*dsh*shat)/(shat**2+dsh**2)
10442 wtz=wtz*rmeps
10443 ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.iabs(kflb).LE.20) THEN
10444 rmeps=(shat**2+uhat**2+2d0*dsh*that)/((shat-dsh)**2+dsh**2)
10445 wtz=wtz*rmeps/3d0
10446 ENDIF
10447 ENDIF
10448
10449C...Impose angular constraint in first branching from interference
10450C...with final state partons.
10451 IF(mce.EQ.1) THEN
10452 IF(mfis.GE.1.AND.n.LE.ns+2.AND.ntry2.LT.200) THEN
10453 the2d=(4d0*q2b)/(dsh*(1d0-z))
10454 IF(n.EQ.ns+1.AND.isfi(1).GE.1) THEN
10455 IF(the2d.GT.thefis(1,isfi(1))**2) GOTO 210
10456 ELSEIF(n.EQ.ns+2.AND.isfi(2).GE.1) THEN
10457 IF(the2d.GT.thefis(2,isfi(2))**2) GOTO 210
10458 ENDIF
10459 ENDIF
10460
10461C...Option with angular ordering requirement.
10462 IF(mstp(62).GE.3.AND.ntry2.LT.200) THEN
10463 the2t=(4d0*z**2*q2b)/(4d0*z**2*q2b+(1d0-z)*xb**2*vint(2))
10464 IF(the2t.GT.the2(jt)) GOTO 210
10465 ENDIF
10466 ENDIF
10467
10468C...Weighting with new parton distributions.
10469 mint(105)=mint(102+jt)
10470 mint(109)=mint(106+jt)
10471 vint(120)=vint(2+jt)
10472 IF(mstp(57).LE.1) THEN
10473 CALL pypdfu(kfbeam(jt),xb,q2ref,xfn)
10474 ELSE
10475 CALL pypdfl(kfbeam(jt),xb,q2ref,xfn)
10476 ENDIF
10477 xfbn=xfn(kflb)
10478 IF(xfbn.LT.1d-20) THEN
10479 IF(kfla.EQ.kflb) THEN
10480 tevcb=tevcbs
10481 teveb=tevebs
10482 wtapc(kflb)=0d0
10483 wtape(kflb)=0d0
10484 GOTO 190
10485 ELSEIF(mce.EQ.1.AND.tevcbs-tevcb.GT.0.2d0) THEN
10486 tevcb=0.5d0*(tevcbs+tevcb)
10487 GOTO 220
10488 ELSEIF(mce.EQ.2.AND.tevebs-teveb.GT.0.2d0) THEN
10489 teveb=0.5d0*(tevebs+teveb)
10490 GOTO 220
10491 ELSE
10492 xfbn=1d-10
10493 xfn(kflb)=xfbn
10494 ENDIF
10495 ENDIF
10496 DO 240 kfl=-25,25
10497 xfb(kfl)=xfn(kfl)
10498 240 CONTINUE
10499 xa=xb/z
10500 IF(mstp(57).LE.1) THEN
10501 CALL pypdfu(kfbeam(jt),xa,q2ref,xfa)
10502 ELSE
10503 CALL pypdfl(kfbeam(jt),xa,q2ref,xfa)
10504 ENDIF
10505 xfan=xfa(kfla)
10506 IF(xfan.LT.1d-20) GOTO 190
10507 wtsfa=wtsf(kfla)
10508 IF(wtz*xfan/xfbn.LT.pyr(0)*wtsfa) GOTO 190
10509
10510C...Define two hard scatterers in their CM-frame.
10511 250 IF(n.EQ.ns+2) THEN
10512 dq2(jt)=q2b
10513 dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr
10514 DO 270 jr=1,2
10515 i=ns+jr
10516 IF(jr.EQ.1) ipo=ipus1
10517 IF(jr.EQ.2) ipo=ipus2
10518 DO 260 j=1,5
10519 k(i,j)=0
10520 p(i,j)=0d0
10521 v(i,j)=0d0
10522 260 CONTINUE
10523 k(i,1)=14
10524 k(i,2)=kfls(jr+2)
10525 k(i,4)=ipo
10526 k(i,5)=ipo
10527 p(i,3)=dplcm*(-1)**(jr+1)
10528 p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
10529 p(i,5)=-sqrt(dq2(jr))
10530 k(ipo,1)=14
10531 k(ipo,3)=i
10532 k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i
10533 k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i
10534 270 CONTINUE
10535
10536C...Find maximum allowed mass of timelike parton.
10537 ELSEIF(n.GT.ns+2) THEN
10538 jr=3-jt
10539 dq2(3)=q2b
10540 dpc(1)=p(is(1),4)
10541 dpc(2)=p(is(2),4)
10542 dpc(3)=0.5d0*(abs(p(is(1),3))+abs(p(is(2),3)))
10543 dpd(1)=dsh+dq2(jr)+dq2(jt)
10544 dpd(2)=dshz+dq2(jr)+dq2(3)
10545 dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))
10546 dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))
10547 ikin=0
10548 IF(q2s(jr).GE.0.25d0*q2mnc.AND.dpd(1)-dpd(3).GE.
10549 & 1d-10*dpd(1)) ikin=1
10550 IF(ikin.EQ.0) dmsma=(dq2(jt)/zs(jt)-dq2(3))*
10551 & (dsh/(dsh+dq2(jt))-dsh/(dshz+dq2(3)))
10552 IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/
10553 & (2d0*dq2(jr))-dq2(jt)-dq2(3)
10554
10555C...Generate timelike parton shower (if required).
10556 it=n
10557 DO 280 j=1,5
10558 k(it,j)=0
10559 p(it,j)=0d0
10560 v(it,j)=0d0
10561 280 CONTINUE
10562C...f -> f + g (gamma).
10563 IF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).LE.20) THEN
10564 k(it,2)=21
10565 IF(iabs(kflb).GE.11) k(it,2)=22
10566C...f -> g (gamma, W+-) + f.
10567 ELSEIF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).GT.20) THEN
10568 k(it,2)=kflb
10569 IF(kfls(jt+2).EQ.24) THEN
10570 k(it,2)=-12
10571 ELSEIF(kfls(jt+2).EQ.-24) THEN
10572 k(it,2)=12
10573 ENDIF
10574C...g (gamma) -> f + fbar, g + g.
10575 ELSE
10576 k(it,2)=-kfls(jt+2)
10577 IF(kfls(jt+2).GT.20) k(it,2)=kfls(jt+2)
10578 ENDIF
10579 k(it,1)=3
10580 IF((iabs(k(it,2)).GE.11.AND.iabs(k(it,2)).LE.18).OR.
10581 & iabs(k(it,2)).EQ.22) k(it,1)=1
10582 p(it,5)=pymass(k(it,2))
10583 IF(dmsma.LE.p(it,5)**2) GOTO 100
10584 IF(mstp(63).GE.1.AND.mce.EQ.1) THEN
10585 mstj48=mstj(48)
10586 parj85=parj(85)
10587 p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
10588 p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)
10589 IF(mstp(63).EQ.1) THEN
10590 q2tim=dmsma
10591 ELSEIF(mstp(63).EQ.2) THEN
10592 q2tim=min(dmsma,parp(71)*q2s(jt))
10593 ELSE
10594 q2tim=dmsma
10595 mstj(48)=1
10596 IF(ikin.EQ.0) dpt2=dmsma*(dshz+dq2(3))/(dsh+dq2(jt))
10597 IF(ikin.EQ.1) dpt2=dmsma*(0.5d0*dpd(1)*dpd(2)+0.5d0*dpd(3)*
10598 & dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)))/(4d0*dsh*dpc(3)**2)
10599 parj(85)=sqrt(max(0d0,dpt2))*
10600 & (1d0/p(it,4)+1d0/p(is(jt),4))
10601 ENDIF
10602 CALL pyshow(it,0,sqrt(q2tim))
10603 mstj(48)=mstj48
10604 parj(85)=parj85
10605 IF(n.GE.it+1) p(it,5)=p(it+1,5)
10606 ENDIF
10607
10608C...Reconstruct kinematics of branching: timelike parton shower.
10609 dms=p(it,5)**2
10610 IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))
10611 IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5d0*dpd(1)*dpd(2)+
10612 & 0.5d0*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
10613 & (4d0*dsh*dpc(3)**2)
10614 IF(dpt2.LT.0d0) GOTO 100
10615 dpb(1)=(0.5d0*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
10616 & dshr)/dpc(3)-dpc(3)
10617 p(it,1)=sqrt(dpt2)
10618 p(it,3)=dpb(1)*(-1)**(jt+1)
10619 p(it,4)=sqrt(dpt2+dpb(1)**2+dms)
10620 IF(n.GE.it+1) THEN
10621 dpb(1)=sqrt(dpb(1)**2+dpt2)
10622 dpb(2)=sqrt(dpb(1)**2+dms)
10623 dpb(3)=p(it+1,3)
10624 dpb(4)=sqrt(dpb(3)**2+dms)
10625 dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
10626 & dpb(1))
10627 CALL pyrobo(it+1,n,0d0,0d0,0d0,0d0,dbez)
10628 the=pyangl(p(it,3),p(it,1))
10629 CALL pyrobo(it+1,n,the,0d0,0d0,0d0,0d0)
10630 ENDIF
10631
10632C...Reconstruct kinematics of branching: spacelike parton.
10633 DO 290 j=1,5
10634 k(n+1,j)=0
10635 p(n+1,j)=0d0
10636 v(n+1,j)=0d0
10637 290 CONTINUE
10638 k(n+1,1)=14
10639 k(n+1,2)=kflb
10640 p(n+1,1)=p(it,1)
10641 p(n+1,3)=p(it,3)+p(is(jt),3)
10642 p(n+1,4)=p(it,4)+p(is(jt),4)
10643 p(n+1,5)=-sqrt(dq2(3))
10644
10645C...Define colour flow of branching.
10646 k(is(jt),3)=n+1
10647 k(it,3)=n+1
10648 im1=n+1
10649 im2=n+1
10650C...f -> f + gamma (Z, W).
10651 IF(iabs(k(it,2)).GE.22) THEN
10652 k(it,1)=1
10653 id1=is(jt)
10654 id2=is(jt)
10655C...f -> gamma (Z, W) + f.
10656 ELSEIF(iabs(k(is(jt),2)).GE.22) THEN
10657 id1=it
10658 id2=it
10659C...gamma -> q + qbar, g + g.
10660 ELSEIF(k(n+1,2).EQ.22) THEN
10661 id1=is(jt)
10662 id2=it
10663 im1=id2
10664 im2=id1
10665C...q -> q + g.
10666 ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(it,2).EQ.21) THEN
10667 id1=it
10668 id2=is(jt)
10669C...q -> g + q.
10670 ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21) THEN
10671 id1=is(jt)
10672 id2=it
10673C...qbar -> qbar + g.
10674 ELSEIF(k(n+1,2).LT.0.AND.k(it,2).EQ.21) THEN
10675 id1=is(jt)
10676 id2=it
10677C...qbar -> g + qbar.
10678 ELSEIF(k(n+1,2).LT.0) THEN
10679 id1=it
10680 id2=is(jt)
10681C...g -> g + g; g -> q + qbar.
10682 ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
10683 id1=is(jt)
10684 id2=it
10685 ELSE
10686 id1=it
10687 id2=is(jt)
10688 ENDIF
10689 IF(im1.EQ.n+1) k(im1,4)=k(im1,4)+id1
10690 IF(im2.EQ.n+1) k(im2,5)=k(im2,5)+id2
10691 k(id1,4)=k(id1,4)+mstu(5)*im1
10692 k(id2,5)=k(id2,5)+mstu(5)*im2
10693 IF(id1.NE.id2) THEN
10694 k(id1,5)=k(id1,5)+mstu(5)*id2
10695 k(id2,4)=k(id2,4)+mstu(5)*id1
10696 ENDIF
10697 n=n+1
10698
10699C...Boost to new CM-frame.
10700 dbsvx=(p(n,1)+p(is(jr),1))/(p(n,4)+p(is(jr),4))
10701 dbsvz=(p(n,3)+p(is(jr),3))/(p(n,4)+p(is(jr),4))
10702 IF(dbsvx**2+dbsvz**2.GE.1d0) GOTO 100
10703 CALL pyrobo(ns+1,n,0d0,0d0,-dbsvx,0d0,-dbsvz)
10704 ir=n+(jt-1)*(is(1)-n)
10705 CALL pyrobo(ns+1,n,-pyangl(p(ir,3),p(ir,1)),paru(2)*pyr(0),
10706 & 0d0,0d0,0d0)
10707 ENDIF
10708
10709C...Update kinematics variables.
10710 is(jt)=n
10711 dq2(jt)=q2b
10712 IF(mstp(62).GE.3.AND.ntry2.LT.200) the2(jt)=the2t
10713 dsh=dshz
10714
10715C...Save quantities; loop back.
10716 q2s(jt)=q2b
10717 IF((mcev.EQ.1.AND.q2b.GE.0.25d0*q2mnc).OR.
10718 &(meev.EQ.1.AND.q2b.GE.q2mne)) THEN
10719 kfls(jt+2)=kfls(jt)
10720 kfls(jt)=kfla
10721 xs(jt)=xa
10722 zs(jt)=z
10723 DO 300 kfl=-25,25
10724 xfs(jt,kfl)=xfa(kfl)
10725 300 CONTINUE
10726 tevcsv(jt)=tevcb
10727 tevesv(jt)=teveb
10728 ELSE
10729 more(jt)=0
10730 IF(jt.EQ.1) ipu1=n
10731 IF(jt.EQ.2) ipu2=n
10732 ENDIF
10733 IF(n.GT.mstu(4)-mstu(32)-10) THEN
10734 CALL pyerrm(11,'(PYSSPA:) no more memory left in PYJETS')
10735 IF(mstu(21).GE.1) n=ns
10736 IF(mstu(21).GE.1) RETURN
10737 ENDIF
10738 IF(more(1).EQ.1.OR.more(2).EQ.1) GOTO 150
10739
10740C...Boost hard scattering partons to frame of shower initiators.
10741 DO 310 j=1,3
10742 robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))
10743 310 CONTINUE
10744 k(n+2,1)=1
10745 DO 320 j=1,5
10746 p(n+2,j)=p(ns+1,j)
10747 320 CONTINUE
10748 CALL pyrobo(n+2,n+2,0d0,0d0,-robo(3),-robo(4),-robo(5))
10749 robo(2)=pyangl(p(n+2,1),p(n+2,2))
10750 robo(1)=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
10751 CALL pyrobo(mint(83)+5,ns,robo(1),robo(2),robo(3),robo(4),
10752 &robo(5))
10753
10754C...Store user information. Reset Lambda value.
10755 k(ipu1,3)=mint(83)+3
10756 k(ipu2,3)=mint(83)+4
10757 DO 330 jt=1,2
10758 mint(12+jt)=kfls(jt)
10759 vint(140+jt)=xs(jt)
10760 IF(mint(18+jt).EQ.1) vint(140+jt)=vint(154+jt)*xs(jt)
10761 330 CONTINUE
10762 paru(112)=alams
10763
10764 RETURN
10765 END
10766
10767C*********************************************************************
10768
10769C...PYRESD
10770C...Allows resonances to decay (including parton showers for hadronic
10771C...channels).
10772
10773 SUBROUTINE pyresd(IRES)
10774
10775C...Double precision and integer declarations.
10776 IMPLICIT DOUBLE PRECISION(a-h, o-z)
10777 IMPLICIT INTEGER(I-N)
10778 INTEGER PYK,PYCHGE,PYCOMP
10779C...Parameter statement to help give large particle numbers.
10780 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
10781C...Commonblocks.
10782 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10783 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
10784 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
10785 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
10786 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
10787 common/pypars/mstp(200),parp(200),msti(200),pari(200)
10788 common/pyint1/mint(400),vint(400)
10789 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
10790 common/pyint4/mwid(500),wids(500,5)
10791 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
10792 &/pyint1/,/pyint2/,/pyint4/
10793C...Local arrays and complex and character variables.
10794 dimension iref(50,8),kdcy(3),kfl1(3),kfl2(3),kfl3(3),keql(3),
10795 &kcqm(3),kcq1(3),kcq2(3),kcq3(3),nsd(3),pmmn(3),ilin(6),
10796 &hgz(3,3),coup(6,4),corl(2,2,2),pk(6,4),pkk(6,6),cthe(3),
10797 &phi(3),wdtp(0:200),wdte(0:200,0:5),dbezqq(3),dpmo(5),xm(5),
10798 &vdcy(4)
10799 COMPLEX FGK,HA(6,6),HC(6,6)
10800 REAL TIR,UIR
10801 CHARACTER CODE*9,MASS*9
10802
10803C...The F, Xi and Xj functions of Gunion and Kunszt
10804C...(Phys. Rev. D33, 665, plus errata from the authors).
10805 fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*
10806 &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
10807 digk(dt,du)=-4d0*d34*d56+dt*(3d0*dt+4d0*du)+dt**2*(dt*du/
10808 &(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+2d0*(d34/d56+d56/d34))
10809 djgk(dt,du)=8d0*(d34+d56)**2-8d0*(d34+d56)*(dt+du)-6d0*dt*du-
10810 &2d0*dt*du*(dt*du/(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+
10811 &2d0*(d34/d56+d56/d34))
10812
10813C...Some general constants.
10814 xw=paru(102)
10815 xwv=xw
10816 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
10817 xw1=1d0-xw
10818 sqmz=pmas(23,1)**2
10819 gmmz=pmas(23,1)*pmas(23,2)
10820 sqmw=pmas(24,1)**2
10821 gmmw=pmas(24,1)*pmas(24,2)
10822 sh=vint(44)
10823
10824C...Reset original resonance configuration.
10825 DO 100 jt=1,8
10826 iref(1,jt)=0
10827 100 CONTINUE
10828
10829C...Define initial one, two or three objects for subprocess.
10830 IF(ires.EQ.0) THEN
10831 isub=mint(1)
10832 IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
10833 iref(1,1)=mint(84)+2+iset(isub)
10834 iref(1,4)=mint(83)+6+iset(isub)
10835 jtmax=1
10836 ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
10837 iref(1,1)=mint(84)+1+iset(isub)
10838 iref(1,2)=mint(84)+2+iset(isub)
10839 iref(1,4)=mint(83)+5+iset(isub)
10840 iref(1,5)=mint(83)+6+iset(isub)
10841 jtmax=2
10842 ELSEIF(iset(isub).EQ.5) THEN
10843 iref(1,1)=mint(84)+3
10844 iref(1,2)=mint(84)+4
10845 iref(1,3)=mint(84)+5
10846 iref(1,4)=mint(83)+7
10847 iref(1,5)=mint(83)+8
10848 iref(1,6)=mint(83)+9
10849 jtmax=3
10850 ENDIF
10851
10852C...Define original resonance for odd cases.
10853 ELSE
10854 isub=0
10855 iref(1,1)=ires
10856 jtmax=1
10857 ENDIF
10858
10859C...Check if initial resonance has been moved (in resonance + jet).
10860 DO 120 jt=1,3
10861 IF(iref(1,jt).GT.0) THEN
10862 IF(k(iref(1,jt),1).GT.10) THEN
10863 kfa=iabs(k(iref(1,jt),2))
10864 IF(kfa.GE.6.AND.kchg(pycomp(kfa),2).NE.0) THEN
10865 DO 110 i=iref(1,jt)+1,n
10866 IF(k(i,1).LE.10.AND.k(i,2).EQ.k(iref(1,jt),2))
10867 & iref(1,jt)=i
10868 110 CONTINUE
10869 ELSE
10870 kda=mod(k(iref(1,jt),4),mstu(4))
10871 IF(mwid(pycomp(kfa)).NE.0.AND.kda.GT.1) iref(1,jt)=kda
10872 ENDIF
10873 ENDIF
10874 ENDIF
10875 120 CONTINUE
10876
10877C.....Set decay vertex for initial resonances
10878 DO 140 jt=1,jtmax
10879 DO 130 i=1,4
10880 v(iref(1,jt),i)=0d0
10881 130 CONTINUE
10882 140 CONTINUE
10883
10884C...Loop over decay history.
10885 np=1
10886 ip=0
10887 150 ip=ip+1
10888 ninh=0
10889 jtmax=2
10890 IF(iref(ip,2).EQ.0) jtmax=1
10891 IF(iref(ip,3).NE.0) jtmax=3
10892 it4=0
10893 nsav=n
10894
10895C...Start treatment of one, two or three resonances in parallel.
10896 160 n=nsav
10897 DO 250 jt=1,jtmax
10898 id=iref(ip,jt)
10899 kdcy(jt)=0
10900 kfl1(jt)=0
10901 kfl2(jt)=0
10902 kfl3(jt)=0
10903 keql(jt)=0
10904 nsd(jt)=id
10905
10906C...Check whether particle can/is allowed to decay.
10907 IF(id.EQ.0) GOTO 240
10908 kfa=iabs(k(id,2))
10909 kca=pycomp(kfa)
10910 IF(mwid(kca).EQ.0) GOTO 240
10911 IF(k(id,1).GT.10.OR.mdcy(kca,1).EQ.0) GOTO 240
10912 IF(kfa.EQ.6.OR.kfa.EQ.7.OR.kfa.EQ.8.OR.kfa.EQ.17.OR.
10913 & kfa.EQ.18) it4=it4+1
10914 k(id,4)=mstu(5)*(k(id,4)/mstu(5))
10915 k(id,5)=mstu(5)*(k(id,5)/mstu(5))
10916
10917C...Choose lifetime and determine decay vertex.
10918 IF(k(id,1).EQ.5) THEN
10919 v(id,5)=0d0
10920 ELSEIF(k(id,1).NE.4) THEN
10921 v(id,5)=-pmas(kca,4)*log(pyr(0))
10922 ENDIF
10923 DO 170 j=1,4
10924 vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
10925 170 CONTINUE
10926
10927C...Determine whether decay allowed or not.
10928 mout=0
10929 IF(mstj(22).EQ.2) THEN
10930 IF(pmas(kca,4).GT.parj(71)) mout=1
10931 ELSEIF(mstj(22).EQ.3) THEN
10932 IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
10933 ELSEIF(mstj(22).EQ.4) THEN
10934 IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
10935 IF(abs(vdcy(3)).GT.parj(74)) mout=1
10936 ENDIF
10937 IF(mout.EQ.1.AND.k(id,1).NE.5) THEN
10938 k(id,1)=4
10939 GOTO 240
10940 ENDIF
10941
10942C...Info for selection of decay channel: sign, pairings.
10943 IF(kchg(kca,3).EQ.0) THEN
10944 ipm=2
10945 ELSE
10946 ipm=(5-isign(1,k(id,2)))/2
10947 ENDIF
10948 kfb=0
10949 IF(jtmax.EQ.2) THEN
10950 kfb=iabs(k(iref(ip,3-jt),2))
10951 ELSEIF(jtmax.EQ.3) THEN
10952 jt2=jt+1-3*(jt/3)
10953 kfb=iabs(k(iref(ip,jt2),2))
10954 IF(kfb.NE.kfa) THEN
10955 jt2=jt+2-3*((jt+1)/3)
10956 kfb=iabs(k(iref(ip,jt2),2))
10957 ENDIF
10958 ENDIF
10959
10960C...Select decay channel.
10961 IF(isub.EQ.1.OR.isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.
10962 & isub.EQ.30.OR.isub.EQ.35.OR.isub.EQ.141) mint(61)=1
10963 CALL pywidt(kfa,p(id,5)**2,wdtp,wdte)
10964 wdte0s=wdte(0,1)+wdte(0,ipm)+wdte(0,4)
10965 IF(kfb.EQ.kfa) wdte0s=wdte0s+wdte(0,5)
10966 IF(wdte0s.LE.0d0) GOTO 240
10967 rkfl=wdte0s*pyr(0)
10968 idl=0
10969 180 idl=idl+1
10970 idc=idl+mdcy(kca,2)-1
10971 rkfl=rkfl-(wdte(idl,1)+wdte(idl,ipm)+wdte(idl,4))
10972 IF(kfb.EQ.kfa) rkfl=rkfl-wdte(idl,5)
10973 IF(idl.LT.mdcy(kca,3).AND.rkfl.GT.0d0) GOTO 180
10974
10975C...Read out flavours and colour charges of decay channel chosen.
10976 kcqm(jt)=kchg(kca,2)*isign(1,k(id,2))
10977 IF(kcqm(jt).EQ.-2) kcqm(jt)=2
10978 kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))
10979 kfc1a=pycomp(iabs(kfl1(jt)))
10980 IF(kchg(kfc1a,3).EQ.0) kfl1(jt)=iabs(kfl1(jt))
10981 kcq1(jt)=kchg(kfc1a,2)*isign(1,kfl1(jt))
10982 IF(kcq1(jt).EQ.-2) kcq1(jt)=2
10983 kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))
10984 kfc2a=pycomp(iabs(kfl2(jt)))
10985 IF(kchg(kfc2a,3).EQ.0) kfl2(jt)=iabs(kfl2(jt))
10986 kcq2(jt)=kchg(kfc2a,2)*isign(1,kfl2(jt))
10987 IF(kcq2(jt).EQ.-2) kcq2(jt)=2
10988 kfl3(jt)=kfdp(idc,3)*isign(1,k(id,2))
10989 IF(kfl3(jt).NE.0) THEN
10990 kfc3a=pycomp(iabs(kfl3(jt)))
10991 IF(kchg(kfc3a,3).EQ.0) kfl3(jt)=iabs(kfl3(jt))
10992 kcq3(jt)=kchg(kfc3a,2)*isign(1,kfl3(jt))
10993 IF(kcq3(jt).EQ.-2) kcq3(jt)=2
10994 ENDIF
10995
10996C...Set/save further info on channel.
10997 kdcy(jt)=1
10998 IF(kfb.EQ.kfa) keql(jt)=mdme(idc,1)
10999 nsd(jt)=n
11000 hgz(jt,1)=vint(111)
11001 hgz(jt,2)=vint(112)
11002 hgz(jt,3)=vint(114)
11003 jtz=jt
11004
11005C...Select masses; to begin with assume resonances narrow.
11006 DO 200 i=1,3
11007 p(n+i,5)=0d0
11008 pmmn(i)=0d0
11009 IF(i.EQ.1) THEN
11010 kflw=iabs(kfl1(jt))
11011 kcw=kfc1a
11012 ELSEIF(i.EQ.2) THEN
11013 kflw=iabs(kfl2(jt))
11014 kcw=kfc2a
11015 ELSEIF(i.EQ.3) THEN
11016 IF(kfl3(jt).EQ.0) GOTO 200
11017 kflw=iabs(kfl3(jt))
11018 kcw=kfc3a
11019 ENDIF
11020 p(n+i,5)=pmas(kcw,1)
11021CMRENNA++
11022C...This prevents SUSY/t particles from becoming too light.
11023 IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
11024 pmmn(i)=pmas(kcw,1)
11025 DO 190 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
11026 IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
11027 pmsum=pmas(pycomp(kfdp(idc,1)),1)+
11028 & pmas(pycomp(kfdp(idc,2)),1)
11029 IF(kfdp(idc,3).NE.0) pmsum=pmsum+
11030 & pmas(pycomp(kfdp(idc,3)),1)
11031 pmmn(i)=min(pmmn(i),pmsum)
11032 ENDIF
11033 190 CONTINUE
11034CMRENNA--
11035 ELSEIF(kflw.EQ.6) THEN
11036 pmmn(i)=pmas(24,1)+pmas(5,1)
11037 ENDIF
11038 200 CONTINUE
11039
11040C...Check which two out of three are widest.
11041 iwid1=1
11042 iwid2=2
11043 pwid1=pmas(kfc1a,2)
11044 pwid2=pmas(kfc2a,2)
11045 kflw1=iabs(kfl1(jt))
11046 kflw2=iabs(kfl2(jt))
11047 IF(kfl3(jt).NE.0) THEN
11048 pwid3=pmas(kfc3a,2)
11049 IF(pwid3.GT.pwid1.AND.pwid2.GE.pwid1) THEN
11050 iwid1=3
11051 pwid1=pwid3
11052 kflw1=iabs(kfl3(jt))
11053 ELSEIF(pwid3.GT.pwid2) THEN
11054 iwid2=3
11055 pwid2=pwid3
11056 kflw2=iabs(kfl3(jt))
11057 ENDIF
11058 ENDIF
11059
11060C...If all narrow then only check that masses consistent.
11061 IF(mstp(42).LE.0.OR.(pwid1.LT.parp(41).AND.
11062 & pwid2.LT.parp(41))) THEN
11063CMRENNA++
11064C....Handle near degeneracy cases.
11065 IF(kfa/ksusy1.EQ.1.OR.kfa/ksusy1.EQ.2) THEN
11066 IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
11067 p(n+1,5)=p(id,5)-p(n+2,5)-0.5d0
11068 IF(p(n+1,5).LT.0d0) p(n+1,5)=0d0
11069 ENDIF
11070 ENDIF
11071CMRENNA--
11072 IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
11073 CALL pyerrm(13,'(PYRESD:) daughter masses too large')
11074 mint(51)=1
11075 RETURN
11076 ELSEIF(p(n+1,5)+p(n+2,5)+p(n+3,5)+parj(64).GT.p(id,5)) THEN
11077 CALL pyerrm(3,'(PYRESD:) daughter masses too large')
11078 mint(51)=1
11079 RETURN
11080 ENDIF
11081
11082C...For three wide resonances select narrower of three
11083C...according to BW decoupled from rest.
11084 ELSE
11085 pmtot=p(id,5)
11086 IF(kfl3(jt).NE.0) THEN
11087 iwid3=6-iwid1-iwid2
11088 kflw3=iabs(kfl1(jt))+iabs(kfl2(jt))+iabs(kfl3(jt))-
11089 & kflw1-kflw2
11090 loop=0
11091 210 loop=loop+1
11092 p(n+iwid3,5)=pymass(kflw3)
11093 IF(loop.LE.10.AND. p(n+iwid3,5).LE.pmmn(iwid3)) GOTO 210
11094 pmtot=pmtot-p(n+iwid3,5)
11095 ENDIF
11096C...Select other two correlated within remaining phase space.
11097 IF(ip.EQ.1) THEN
11098 ckin45=ckin(45)
11099 ckin47=ckin(47)
11100 ckin(45)=max(pmmn(iwid1),ckin(45))
11101 ckin(47)=max(pmmn(iwid2),ckin(47))
11102 CALL pyofsh(2,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
11103 & p(n+iwid2,5))
11104 ckin(45)=ckin45
11105 ckin(47)=ckin47
11106 ELSE
11107 ckin(49)=pmmn(iwid1)
11108 ckin(50)=pmmn(iwid2)
11109 CALL pyofsh(5,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
11110 & p(n+iwid2,5))
11111 ckin(49)=0d0
11112 ckin(50)=0d0
11113 ENDIF
11114 IF(mint(51).EQ.1) RETURN
11115 ENDIF
11116
11117C...Begin fill decay products, with colour flow for coloured objects.
11118 mstu10=mstu(10)
11119 mstu(10)=1
11120 mstu(19)=1
11121
11122CMRENNA++
11123C...1) Three-body decays of SUSY particles (plus special case top).
11124 IF(kfl3(jt).NE.0) THEN
11125 DO 230 i=n+1,n+3
11126 DO 220 j=1,5
11127 k(i,j)=0
11128C V(I,J)=0D0
11129 220 CONTINUE
11130 230 CONTINUE
11131 xm(1)=p(n+1,5)
11132 xm(2)=p(n+2,5)
11133 xm(3)=p(n+3,5)
11134 xm(5)=p(id,5)
11135 CALL pytbdy(xm)
11136 k(n+1,1)=1
11137 k(n+1,2)=kfl1(jt)
11138 k(n+2,1)=1
11139 k(n+2,2)=kfl2(jt)
11140 k(n+3,1)=1
11141 k(n+3,2)=kfl3(jt)
11142
11143C...Set colour flow for t -> W + b + Z.
11144 IF(kfa.EQ.6) THEN
11145 k(n+2,1)=3
11146 isid=4
11147 IF(kcqm(jt).EQ.-1) isid=5
11148 idau=n+2
11149 k(id,isid)=k(id,isid)+idau
11150 k(idau,isid)=mstu(5)*id
11151
11152C...Set colour flow in three-body decays - programmed as special cases.
11153 ELSEIF(kfc2a.LE.6) THEN
11154 k(n+2,1)=3
11155 k(n+3,1)=3
11156 isid=4
11157 IF(kfl2(jt).LT.0) isid=5
11158 k(n+2,isid)=mstu(5)*(n+3)
11159 k(n+3,9-isid)=mstu(5)*(n+2)
11160 ENDIF
11161 IF(kfl1(jt).EQ.ksusy1+21) THEN
11162 k(n+1,1)=3
11163 k(n+2,1)=3
11164 k(n+3,1)=3
11165 isid=4
11166 IF(kfl2(jt).LT.0) isid=5
11167 k(n+1,isid)=mstu(5)*(n+2)
11168 k(n+1,9-isid)=mstu(5)*(n+3)
11169 k(n+2,isid)=mstu(5)*(n+1)
11170 k(n+3,9-isid)=mstu(5)*(n+1)
11171 ENDIF
11172 IF(kfa.EQ.ksusy1+21) THEN
11173 k(n+2,1)=3
11174 k(n+3,1)=3
11175 isid=4
11176 IF(kfl2(jt).LT.0) isid=5
11177 k(id,isid)=k(id,isid)+(n+2)
11178 k(id,9-isid)=k(id,9-isid)+(n+3)
11179 k(n+2,isid)=mstu(5)*id
11180 k(n+3,9-isid)=mstu(5)*id
11181 ENDIF
11182 n=n+3
11183CMRENNA--
11184
11185C...2) Everything else two-body decay.
11186 ELSE
11187 CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
11188C...First set colour flow as if mother colour singlet.
11189 IF(kcq1(jt).NE.0) THEN
11190 k(n-1,1)=3
11191 IF(kcq1(jt).NE.-1) k(n-1,4)=mstu(5)*n
11192 IF(kcq1(jt).NE.1) k(n-1,5)=mstu(5)*n
11193 ENDIF
11194 IF(kcq2(jt).NE.0) THEN
11195 k(n,1)=3
11196 IF(kcq2(jt).NE.-1) k(n,4)=mstu(5)*(n-1)
11197 IF(kcq2(jt).NE.1) k(n,5)=mstu(5)*(n-1)
11198 ENDIF
11199C...Then redirect colour flow if mother (anti)triplet.
11200 IF(kcqm(jt).EQ.0) THEN
11201 ELSEIF(kcqm(jt).NE.2) THEN
11202 isid=4
11203 IF(kcqm(jt).EQ.-1) isid=5
11204 idau=n-1
11205 IF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.2) idau=n
11206 k(id,isid)=k(id,isid)+idau
11207 k(idau,isid)=mstu(5)*id
11208C...Then redirect colour flow if mother octet.
11209 ELSEIF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.0) THEN
11210 idau=n-1
11211 IF(kcq1(jt).EQ.0) idau=n
11212 k(id,4)=k(id,4)+idau
11213 k(id,5)=k(id,5)+idau
11214 k(idau,4)=mstu(5)*id
11215 k(idau,5)=mstu(5)*id
11216 ELSE
11217 isid=4
11218 IF(kcq1(jt).EQ.-1) isid=5
11219 IF(kcq1(jt).EQ.2) isid=int(4.5d0+pyr(0))
11220 k(id,isid)=k(id,isid)+(n-1)
11221 k(id,9-isid)=k(id,9-isid)+n
11222 k(n-1,isid)=mstu(5)*id
11223 k(n,9-isid)=mstu(5)*id
11224 ENDIF
11225 ENDIF
11226
11227C...End loop over resonances for daughter flavour and mass selection.
11228 mstu(10)=mstu10
11229 240 IF(mwid(kca).NE.0.AND.(kfl1(jt).EQ.0.OR.kfl3(jt).NE.0))
11230 & ninh=ninh+1
11231 IF(ires.GT.0.AND.mwid(kca).NE.0.AND.kfl1(jt).EQ.0) THEN
11232 WRITE(code,'(I9)') k(id,2)
11233 WRITE(mass,'(F9.3)') p(id,5)
11234 CALL pyerrm(3,'(PYRESD:) Failed to decay particle'//
11235 & code//' with mass'//mass)
11236 mint(51)=1
11237 RETURN
11238 ENDIF
11239 250 CONTINUE
11240
11241C...Check for allowed combinations. Skip if no decays.
11242 IF(jtmax.EQ.1) THEN
11243 IF(kdcy(1).EQ.0) GOTO 620
11244 ELSEIF(jtmax.EQ.2) THEN
11245 IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0) GOTO 620
11246 IF(keql(1).EQ.4.AND.keql(2).EQ.4) GOTO 160
11247 IF(keql(1).EQ.5.AND.keql(2).EQ.5) GOTO 160
11248 ELSEIF(jtmax.EQ.3) THEN
11249 IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0.AND.kdcy(3).EQ.0) GOTO 620
11250 IF(keql(1).EQ.4.AND.keql(2).EQ.4) GOTO 160
11251 IF(keql(1).EQ.4.AND.keql(3).EQ.4) GOTO 160
11252 IF(keql(2).EQ.4.AND.keql(3).EQ.4) GOTO 160
11253 IF(keql(1).EQ.5.AND.keql(2).EQ.5) GOTO 160
11254 IF(keql(1).EQ.5.AND.keql(3).EQ.5) GOTO 160
11255 IF(keql(2).EQ.5.AND.keql(3).EQ.5) GOTO 160
11256 ENDIF
11257
11258C...Special case: matrix element option for Z0 decay to quarks.
11259 IF(mstp(48).EQ.1.AND.isub.EQ.1.AND.jtmax.EQ.1.AND.
11260 &iabs(mint(11)).EQ.11.AND.iabs(kfl1(1)).LE.5) THEN
11261
11262C...Check consistency of MSTJ options set.
11263 IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
11264 CALL pyerrm(6,
11265 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
11266 mstj(110)=1
11267 ENDIF
11268 IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
11269 CALL pyerrm(6,
11270 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
11271 mstj(111)=0
11272 ENDIF
11273
11274C...Select alpha_strong behaviour.
11275 mst111=mstu(111)
11276 par112=paru(112)
11277 mstu(111)=mstj(108)
11278 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
11279 & mstu(111)=1
11280 paru(112)=parj(121)
11281 IF(mstu(111).EQ.2) paru(112)=parj(122)
11282
11283C...Find axial fraction in total cross section for scalar gluon model.
11284 parj(171)=0d0
11285 IF((iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.1).OR.
11286 & (mstj(101).EQ.5.AND.mstj(49).EQ.1)) THEN
11287 poll=1d0-parj(131)*parj(132)
11288 sff=1d0/(16d0*xw*xw1)
11289 sfw=p(id,5)**4/((p(id,5)**2-parj(123)**2)**2+
11290 & (parj(123)*parj(124))**2)
11291 sfi=sfw*(1d0-(parj(123)/p(id,5))**2)
11292 ve=4d0*xw-1d0
11293 hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
11294 hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*
11295 & (parj(132)-parj(131)))
11296 kflc=iabs(kfl1(1))
11297 pmq=pymass(kflc)
11298 qf=kchg(kflc,1)/3d0
11299 vq=1d0
11300 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,
11301 & 1d0-(2d0*pmq/p(id,5))**2))
11302 vf=sign(1d0,qf)-4d0*qf*xw
11303 rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+
11304 & vf**2*hf1w)+vq**3*hf1w
11305 IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
11306 ENDIF
11307
11308C...Choice of jet configuration.
11309 CALL pyxjet(p(id,5),njet,cut)
11310 kflc=iabs(kfl1(1))
11311 kfln=21
11312 IF(njet.EQ.4) THEN
11313 CALL pyx4jt(njet,cut,kflc,p(id,5),kfln,x1,x2,x4,x12,x14)
11314 ELSEIF(njet.EQ.3) THEN
11315 CALL pyx3jt(njet,cut,kflc,p(id,5),x1,x3)
11316 ELSE
11317 mstj(120)=1
11318 ENDIF
11319
11320C...Fill jet configuration; return if incorrect kinematics.
11321 nc=n-2
11322 IF(njet.EQ.2.AND.mstj(101).NE.5) THEN
11323 CALL py2ent(nc+1,kflc,-kflc,p(id,5))
11324 ELSEIF(njet.EQ.2) THEN
11325 CALL py2ent(-(nc+1),kflc,-kflc,p(id,5))
11326 ELSEIF(njet.EQ.3) THEN
11327 CALL py3ent(nc+1,kflc,21,-kflc,p(id,5),x1,x3)
11328 ELSEIF(kfln.EQ.21) THEN
11329 CALL py4ent(nc+1,kflc,kfln,kfln,-kflc,p(id,5),x1,x2,x4,
11330 & x12,x14)
11331 ELSE
11332 CALL py4ent(nc+1,kflc,-kfln,kfln,-kflc,p(id,5),x1,x2,x4,
11333 & x12,x14)
11334 ENDIF
11335 IF(mstu(24).NE.0) THEN
11336 mint(51)=1
11337 mstu(111)=mst111
11338 paru(112)=par112
11339 RETURN
11340 ENDIF
11341
11342C...Angular orientation according to matrix element.
11343 IF(mstj(106).EQ.1) THEN
11344 CALL pyxdif(nc,njet,kflc,p(id,5),chiz,thez,phiz)
11345 IF(mint(11).LT.0) thez=paru(1)-thez
11346 cthe(1)=cos(thez)
11347 CALL pyrobo(nc+1,n,0d0,chiz,0d0,0d0,0d0)
11348 CALL pyrobo(nc+1,n,thez,phiz,0d0,0d0,0d0)
11349 ENDIF
11350
11351C...Boost partons to Z0 rest frame.
11352 CALL pyrobo(nc+1,n,0d0,0d0,p(id,1)/p(id,4),
11353 & p(id,2)/p(id,4),p(id,3)/p(id,4))
11354
11355C...Mark decayed resonance and add documentation lines,
11356 k(id,1)=k(id,1)+10
11357 idoc=mint(83)+mint(4)
11358 DO 270 i=nc+1,n
11359 i1=mint(83)+mint(4)+1
11360 k(i,3)=i1
11361 IF(mstp(128).GE.1) k(i,3)=id
11362 IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
11363 mint(4)=mint(4)+1
11364 k(i1,1)=21
11365 k(i1,2)=k(i,2)
11366 k(i1,3)=iref(ip,4)
11367 DO 260 j=1,5
11368 p(i1,j)=p(i,j)
11369 260 CONTINUE
11370 ENDIF
11371 270 CONTINUE
11372
11373C...Generate parton shower.
11374 IF(mstj(101).EQ.5) CALL pyshow(n-1,n,p(id,5))
11375
11376C... End special case for Z0: skip ahead.
11377 mstu(111)=mst111
11378 paru(112)=par112
11379 GOTO 610
11380 ENDIF
11381
11382C...Order incoming partons and outgoing resonances.
11383 IF(jtmax.EQ.2.AND.isub.NE.0.AND.mstp(47).GE.1.AND.
11384 &ninh.EQ.0) THEN
11385 ilin(1)=mint(84)+1
11386 IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2
11387 IF(k(ilin(1),2).EQ.21.OR.k(ilin(1),2).EQ.22)
11388 & ilin(1)=2*mint(84)+3-ilin(1)
11389 ilin(2)=2*mint(84)+3-ilin(1)
11390 imin=1
11391 IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
11392 & .EQ.36) imin=3
11393 imax=2
11394 iord=1
11395 IF(k(iref(ip,1),2).EQ.23) iord=2
11396 IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2
11397 iakipd=iabs(k(iref(ip,iord),2))
11398 IF(iakipd.EQ.25.OR.iakipd.EQ.35.OR.iakipd.EQ.36) iord=3-iord
11399 IF(kdcy(iord).EQ.0) iord=3-iord
11400
11401C...Order decay products of resonances.
11402 DO 280 jt=iord,3-iord,3-2*iord
11403 IF(kdcy(jt).EQ.0) THEN
11404 ilin(imax+1)=nsd(jt)
11405 imax=imax+1
11406 ELSEIF(k(nsd(jt)+1,2).GT.0) THEN
11407 ilin(imax+1)=n+2*jt-1
11408 ilin(imax+2)=n+2*jt
11409 imax=imax+2
11410 k(n+2*jt-1,2)=k(nsd(jt)+1,2)
11411 k(n+2*jt,2)=k(nsd(jt)+2,2)
11412 ELSE
11413 ilin(imax+1)=n+2*jt
11414 ilin(imax+2)=n+2*jt-1
11415 imax=imax+2
11416 k(n+2*jt-1,2)=k(nsd(jt)+1,2)
11417 k(n+2*jt,2)=k(nsd(jt)+2,2)
11418 ENDIF
11419 280 CONTINUE
11420
11421C...Find charge, isospin, left- and righthanded couplings.
11422 DO 300 i=imin,imax
11423 DO 290 j=1,4
11424 coup(i,j)=0d0
11425 290 CONTINUE
11426 kfa=iabs(k(ilin(i),2))
11427 IF(kfa.EQ.0.OR.kfa.GT.20) GOTO 300
11428 coup(i,1)=kchg(kfa,1)/3d0
11429 coup(i,2)=(-1)**mod(kfa,2)
11430 coup(i,4)=-2d0*coup(i,1)*xwv
11431 coup(i,3)=coup(i,2)+coup(i,4)
11432 300 CONTINUE
11433
11434C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
11435 IF(isub.EQ.22) THEN
11436 DO 330 i=3,5,2
11437 i1=iord
11438 IF(i.EQ.5) i1=3-iord
11439 DO 320 j1=1,2
11440 DO 310 j2=1,2
11441 corl(i/2,j1,j2)=coup(1,1)**2*hgz(i1,1)*coup(i,1)**2/
11442 & 16d0+coup(1,1)*coup(1,j1+2)*hgz(i1,2)*coup(i,1)*
11443 & coup(i,j2+2)/4d0+coup(1,j1+2)**2*hgz(i1,3)*
11444 & coup(i,j2+2)**2
11445 310 CONTINUE
11446 320 CONTINUE
11447 330 CONTINUE
11448 cowt12=(corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
11449 & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2))
11450 comx12=(corl(1,1,1)+corl(1,1,2)+corl(1,2,1)+corl(1,2,2))*
11451 & (corl(2,1,1)+corl(2,1,2)+corl(2,2,1)+corl(2,2,2))
11452 IF(cowt12.LT.pyr(0)*comx12) GOTO 160
11453 ENDIF
11454 ENDIF
11455
11456C...Select angular orientation type - Z'/W' only.
11457 mzpwp=0
11458 IF(isub.EQ.141) THEN
11459 IF(pyr(0).LT.paru(130)) mzpwp=1
11460 IF(ip.EQ.2) THEN
11461 IF(iabs(k(iref(2,1),2)).EQ.37) mzpwp=2
11462 iakir=iabs(k(iref(2,2),2))
11463 IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
11464 IF(iakir.LE.20) mzpwp=2
11465 ENDIF
11466 IF(ip.GE.3) mzpwp=2
11467 ELSEIF(isub.EQ.142) THEN
11468 IF(pyr(0).LT.paru(136)) mzpwp=1
11469 IF(ip.EQ.2) THEN
11470 iakir=iabs(k(iref(2,2),2))
11471 IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
11472 IF(iakir.LE.20) mzpwp=2
11473 ENDIF
11474 IF(ip.GE.3) mzpwp=2
11475 ENDIF
11476
11477C...Select random angles (begin of weighting procedure).
11478 340 DO 350 jt=1,jtmax
11479 IF(kdcy(jt).EQ.0) GOTO 350
11480 IF(jtmax.EQ.1.AND.isub.NE.0) THEN
11481 cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*pyr(0)
11482 IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)
11483 phi(jt)=vint(24)
11484 ELSE
11485 cthe(jt)=2d0*pyr(0)-1d0
11486 phi(jt)=paru(2)*pyr(0)
11487 ENDIF
11488 350 CONTINUE
11489
11490 IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN
11491C...Construct massless four-vectors.
11492 DO 370 i=n+1,n+4
11493 k(i,1)=1
11494 DO 360 j=1,5
11495 p(i,j)=0d0
11496C V(I,J)=0D0
11497 360 CONTINUE
11498 370 CONTINUE
11499 DO 380 jt=1,jtmax
11500 IF(kdcy(jt).EQ.0) GOTO 380
11501 id=iref(ip,jt)
11502 p(n+2*jt-1,3)=0.5d0*p(id,5)
11503 p(n+2*jt-1,4)=0.5d0*p(id,5)
11504 p(n+2*jt,3)=-0.5d0*p(id,5)
11505 p(n+2*jt,4)=0.5d0*p(id,5)
11506 CALL pyrobo(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),
11507 & p(id,1)/p(id,4),p(id,2)/p(id,4),p(id,3)/p(id,4))
11508 380 CONTINUE
11509
11510C...Store incoming and outgoing momenta, with random rotation to
11511C...avoid accidental zeroes in HA expressions.
11512 IF(isub.NE.0) THEN
11513 DO 400 i=1,imax
11514 k(n+4+i,1)=1
11515 p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+
11516 & p(ilin(i),3)**2+p(ilin(i),5)**2)
11517 p(n+4+i,5)=p(ilin(i),5)
11518 DO 390 j=1,3
11519 p(n+4+i,j)=p(ilin(i),j)
11520 390 CONTINUE
11521 400 CONTINUE
11522 410 therr=acos(2d0*pyr(0)-1d0)
11523 phirr=paru(2)*pyr(0)
11524 CALL pyrobo(n+5,n+4+imax,therr,phirr,0d0,0d0,0d0)
11525 DO 430 i=1,imax
11526 IF(p(n+4+i,1)**2+p(n+4+i,2)**2.LT.1d-4*p(n+4+i,4)**2)
11527 & GOTO 410
11528 DO 420 j=1,4
11529 pk(i,j)=p(n+4+i,j)
11530 420 CONTINUE
11531 430 CONTINUE
11532 ENDIF
11533
11534C...Calculate internal products.
11535 IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25.OR.isub.EQ.141.OR.
11536 & isub.EQ.142) THEN
11537 DO 450 i1=imin,imax-1
11538 DO 440 i2=i1+1,imax
11539 ha(i1,i2)=sngl(sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+
11540 & pk(i2,3))/(1d-20+pk(i1,1)**2+pk(i1,2)**2)))*
11541 & cmplx(sngl(pk(i1,1)),sngl(pk(i1,2)))-
11542 & sngl(sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/
11543 & (1d-20+pk(i2,1)**2+pk(i2,2)**2)))*
11544 & cmplx(sngl(pk(i2,1)),sngl(pk(i2,2)))
11545 hc(i1,i2)=conjg(ha(i1,i2))
11546 IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)
11547 IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)
11548 ha(i2,i1)=-ha(i1,i2)
11549 hc(i2,i1)=-hc(i1,i2)
11550 440 CONTINUE
11551 450 CONTINUE
11552 ENDIF
11553
11554C...Calculate four-products.
11555 IF(isub.NE.0) THEN
11556 DO 470 i=1,2
11557 DO 460 j=1,4
11558 pk(i,j)=-pk(i,j)
11559 460 CONTINUE
11560 470 CONTINUE
11561 DO 490 i1=imin,imax-1
11562 DO 480 i2=i1+1,imax
11563 pkk(i1,i2)=2d0*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-
11564 & pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
11565 pkk(i2,i1)=pkk(i1,i2)
11566 480 CONTINUE
11567 490 CONTINUE
11568 ENDIF
11569 ENDIF
11570
11571 kfagm=iabs(iref(ip,7))
11572 IF(mstp(47).LE.0.OR.ninh.NE.0) THEN
11573C...Isotropic decay selected by user.
11574 wt=1d0
11575 wtmax=1d0
11576
11577 ELSEIF(jtmax.EQ.3) THEN
11578C...Isotropic decay when three mother particles.
11579 wt=1d0
11580 wtmax=1d0
11581
11582 ELSEIF(it4.GE.1) THEN
11583C... Isotropic decay t -> b + W etc for 4th generation q and l.
11584 wt=1d0
11585 wtmax=1d0
11586
11587 ELSEIF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.
11588 & iref(ip,7).EQ.36) THEN
11589C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
11590 IF(ip.EQ.1) wtmax=sh**2
11591 IF(ip.GE.2) wtmax=p(iref(ip,8),5)**4
11592 kfa=iabs(k(iref(ip,1),2))
11593 IF(kfa.EQ.23) THEN
11594 kflf1a=iabs(kfl1(1))
11595 ef1=kchg(kflf1a,1)/3d0
11596 af1=sign(1d0,ef1+0.1d0)
11597 vf1=af1-4d0*ef1*xwv
11598 kflf2a=iabs(kfl1(2))
11599 ef2=kchg(kflf2a,1)/3d0
11600 af2=sign(1d0,ef2+0.1d0)
11601 vf2=af2-4d0*ef2*xwv
11602 va12as=4d0*vf1*af1*vf2*af2/((vf1**2+af1**2)*(vf2**2+af2**2))
11603 wt=8d0*(1d0+va12as)*pkk(3,5)*pkk(4,6)+
11604 & 8d0*(1d0-va12as)*pkk(3,6)*pkk(4,5)
11605 ELSEIF(kfa.EQ.24) THEN
11606 wt=16d0*pkk(3,5)*pkk(4,6)
11607 ELSE
11608 wt=wtmax
11609 ENDIF
11610
11611 ELSEIF((kfagm.EQ.6.OR.kfagm.EQ.7.OR.kfagm.EQ.8.OR.
11612 & kfagm.EQ.17.OR.kfagm.EQ.18).AND.iabs(k(iref(ip,1),2)).EQ.24)
11613 & THEN
11614C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
11615 i1=iref(ip,8)
11616 IF(mod(kfagm,2).EQ.0) THEN
11617 i2=n+1
11618 i3=n+2
11619 ELSE
11620 i2=n+2
11621 i3=n+1
11622 ENDIF
11623 i4=iref(ip,2)
11624 wt=(p(i1,4)*p(i2,4)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
11625 & p(i1,3)*p(i2,3))*(p(i3,4)*p(i4,4)-p(i3,1)*p(i4,1)-
11626 & p(i3,2)*p(i4,2)-p(i3,3)*p(i4,3))
11627 wtmax=(p(i1,5)**4-p(iref(ip,1),5)**4)/8d0
11628
11629 ELSEIF(isub.EQ.1) THEN
11630C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
11631 ei=kchg(iabs(mint(15)),1)/3d0
11632 ai=sign(1d0,ei+0.1d0)
11633 vi=ai-4d0*ei*xwv
11634 ef=kchg(iabs(kfl1(1)),1)/3d0
11635 af=sign(1d0,ef+0.1d0)
11636 vf=af-4d0*ef*xwv
11637 rmf=min(1d0,4d0*pmas(iabs(kfl1(1)),1)**2/sh)
11638 wt1=ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
11639 & (vi**2+ai**2)*vint(114)*(vf**2+(1d0-rmf)*af**2)
11640 wt2=rmf*(ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
11641 & (vi**2+ai**2)*vint(114)*vf**2)
11642 wt3=sqrt(1d0-rmf)*(ei*ai*vint(112)*ef*af+
11643 & 4d0*vi*ai*vint(114)*vf*af)
11644 wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
11645 & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
11646 wtmax=2d0*(wt1+abs(wt3))
11647
11648 ELSEIF(isub.EQ.2) THEN
11649C...Angular weight for W+/- -> 2 quarks/leptons.
11650 wt=(1d0+cthe(1)*isign(1,mint(15)*kfl1(1)))**2
11651 wtmax=4d0
11652
11653 ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN
11654C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
11655C...-> gluon/gamma + 2 quarks/leptons.
11656 clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11657 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
11658 & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
11659 clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11660 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
11661 & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
11662 crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11663 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
11664 & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
11665 crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11666 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
11667 & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
11668 wt=(clilf+crirf)*(pkk(1,3)**2+pkk(2,4)**2)+
11669 & (clirf+crilf)*(pkk(1,4)**2+pkk(2,3)**2)
11670 wtmax=(clilf+clirf+crilf+crirf)*
11671 & ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
11672
11673 ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN
11674C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
11675C...-> gluon/gamma + 2 quarks/leptons.
11676 wt=pkk(1,3)**2+pkk(2,4)**2
11677 wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2
11678
11679 ELSEIF(isub.EQ.22) THEN
11680C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
11681 s34=p(iref(ip,iord),5)**2
11682 s56=p(iref(ip,3-iord),5)**2
11683 ti=pkk(1,3)+pkk(1,4)+s34
11684 ui=pkk(1,5)+pkk(1,6)+s56
11685 tir=real(ti)
11686 uir=real(ui)
11687 fgk135=abs(fgk(1,2,3,4,5,6)/tir+fgk(1,2,5,6,3,4)/uir)**2
11688 fgk145=abs(fgk(1,2,4,3,5,6)/tir+fgk(1,2,5,6,4,3)/uir)**2
11689 fgk136=abs(fgk(1,2,3,4,6,5)/tir+fgk(1,2,6,5,3,4)/uir)**2
11690 fgk146=abs(fgk(1,2,4,3,6,5)/tir+fgk(1,2,6,5,4,3)/uir)**2
11691 fgk253=abs(fgk(2,1,5,6,3,4)/tir+fgk(2,1,3,4,5,6)/uir)**2
11692 fgk263=abs(fgk(2,1,6,5,3,4)/tir+fgk(2,1,3,4,6,5)/uir)**2
11693 fgk254=abs(fgk(2,1,5,6,4,3)/tir+fgk(2,1,4,3,5,6)/uir)**2
11694 fgk264=abs(fgk(2,1,6,5,4,3)/tir+fgk(2,1,4,3,6,5)/uir)**2
11695 wt=
11696 & corl(1,1,1)*corl(2,1,1)*fgk135+corl(1,1,2)*corl(2,1,1)*fgk145+
11697 & corl(1,1,1)*corl(2,1,2)*fgk136+corl(1,1,2)*corl(2,1,2)*fgk146+
11698 & corl(1,2,1)*corl(2,2,1)*fgk253+corl(1,2,2)*corl(2,2,1)*fgk263+
11699 & corl(1,2,1)*corl(2,2,2)*fgk254+corl(1,2,2)*corl(2,2,2)*fgk264
11700 wtmax=16d0*((corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
11701 & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2)))*s34*s56*
11702 & ((ti**2+ui**2+2d0*sh*(s34+s56))/(ti*ui)-s34*s56*(1d0/ti**2+
11703 & 1d0/ui**2))
11704
11705 ELSEIF(isub.EQ.23) THEN
11706C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
11707 d34=p(iref(ip,iord),5)**2
11708 d56=p(iref(ip,3-iord),5)**2
11709 dt=pkk(1,3)+pkk(1,4)+d34
11710 du=pkk(1,5)+pkk(1,6)+d56
11711 facbw=1d0/((sh-sqmw)**2+gmmw**2)
11712 cawz=coup(2,3)/dt-2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
11713 cbwz=coup(1,3)/du+2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
11714 fgk135=abs(real(cawz)*fgk(1,2,3,4,5,6)+
11715 & real(cbwz)*fgk(1,2,5,6,3,4))
11716 fgk136=abs(real(cawz)*fgk(1,2,3,4,6,5)+
11717 & real(cbwz)*fgk(1,2,6,5,3,4))
11718 wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
11719 wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*
11720 & digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))
11721
11722 ELSEIF(isub.EQ.24.OR.isub.EQ.171.OR.isub.EQ.176) THEN
11723C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
11724C...(or H0, or A0).
11725 wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
11726 & pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*
11727 & coup(3,3))**2)*pkk(1,4)*pkk(2,3)
11728 wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
11729 & (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
11730
11731 ELSEIF(isub.EQ.25) THEN
11732C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
11733 d34=p(iref(ip,iord),5)**2
11734 d56=p(iref(ip,3-iord),5)**2
11735 dt=pkk(1,3)+pkk(1,4)+d34
11736 du=pkk(1,5)+pkk(1,6)+d56
11737 facbw=1d0/((sh-sqmz)**2+sqmz*pmas(23,2)**2)
11738 cdww=(coup(1,3)*sqmz*(sh-sqmz)*facbw+coup(1,2))/sh
11739 caww=cdww+0.5d0*(coup(1,2)+1d0)/dt
11740 cbww=cdww+0.5d0*(coup(1,2)-1d0)/du
11741 ccww=coup(1,4)*sqmz*(sh-sqmz)*facbw/sh
11742 fgk135=abs(real(caww)*fgk(1,2,3,4,5,6)-
11743 & real(cbww)*fgk(1,2,5,6,3,4))
11744 fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
11745 wt=fgk135**2+(ccww*fgk253)**2
11746 wtmax=4d0*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-caww*
11747 & cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
11748
11749 ELSEIF(isub.EQ.26.OR.isub.EQ.172.OR.isub.EQ.177) THEN
11750C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
11751C...(or H0, or A0).
11752 wt=pkk(1,3)*pkk(2,4)
11753 wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
11754
11755 ELSEIF(isub.EQ.30.OR.isub.EQ.35) THEN
11756C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
11757C...-> f + 2 quarks/leptons.
11758 clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11759 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
11760 & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
11761 clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11762 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
11763 & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
11764 crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11765 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
11766 & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
11767 crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
11768 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
11769 & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
11770 IF(k(ilin(1),2).GT.0) wt=(clilf+crirf)*(pkk(1,4)**2+
11771 & pkk(3,5)**2)+(clirf+crilf)*(pkk(1,3)**2+pkk(4,5)**2)
11772 IF(k(ilin(1),2).LT.0) wt=(clilf+crirf)*(pkk(1,3)**2+
11773 & pkk(4,5)**2)+(clirf+crilf)*(pkk(1,4)**2+pkk(3,5)**2)
11774 wtmax=(clilf+clirf+crilf+crirf)*
11775 & ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
11776
11777 ELSEIF(isub.EQ.31.OR.isub.EQ.36) THEN
11778C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
11779 IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2
11780 IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2
11781 wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2
11782
11783 ELSEIF(isub.EQ.71.OR.isub.EQ.72.OR.isub.EQ.73.OR.isub.EQ.76.OR.
11784 & isub.EQ.77) THEN
11785C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
11786 wt=16d0*pkk(3,5)*pkk(4,6)
11787 wtmax=sh**2
11788
11789 ELSEIF(isub.EQ.110) THEN
11790C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
11791 wt=1d0
11792 wtmax=1d0
11793
11794 ELSEIF(isub.EQ.141) THEN
11795 IF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
11796C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
11797C...Couplings of incoming flavour.
11798 kfai=iabs(mint(15))
11799 ei=kchg(kfai,1)/3d0
11800 ai=sign(1d0,ei+0.1d0)
11801 vi=ai-4d0*ei*xwv
11802 kfaic=1
11803 IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
11804 IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
11805 IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
11806 IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
11807 vpi=paru(119+2*kfaic)
11808 api=paru(120+2*kfaic)
11809 ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
11810 vpi=parj(178+2*kfaic)
11811 api=parj(179+2*kfaic)
11812 ELSE
11813 vpi=parj(186+2*kfaic)
11814 api=parj(187+2*kfaic)
11815 ENDIF
11816C...Couplings of final flavour.
11817 kfaf=iabs(kfl1(1))
11818 ef=kchg(kfaf,1)/3d0
11819 af=sign(1d0,ef+0.1d0)
11820 vf=af-4d0*ef*xwv
11821 kfafc=1
11822 IF(kfaf.LE.10.AND.mod(kfaf,2).EQ.0) kfafc=2
11823 IF(kfaf.GT.10.AND.mod(kfaf,2).NE.0) kfafc=3
11824 IF(kfaf.GT.10.AND.mod(kfaf,2).EQ.0) kfafc=4
11825 IF(kfaf.LE.2.OR.kfaf.EQ.11.OR.kfaf.EQ.12) THEN
11826 vpf=paru(119+2*kfafc)
11827 apf=paru(120+2*kfafc)
11828 ELSEIF(kfaf.LE.4.OR.kfaf.EQ.13.OR.kfaf.EQ.14) THEN
11829 vpf=parj(178+2*kfafc)
11830 apf=parj(179+2*kfafc)
11831 ELSE
11832 vpf=parj(186+2*kfafc)
11833 apf=parj(187+2*kfafc)
11834 ENDIF
11835C...Asymmetry and weight.
11836 asym=2d0*(ei*ai*vint(112)*ef*af+ei*api*vint(113)*ef*apf+
11837 & 4d0*vi*ai*vint(114)*vf*af+(vi*api+vpi*ai)*vint(115)*
11838 & (vf*apf+vpf*af)+4d0*vpi*api*vint(116)*vpf*apf)/
11839 & (ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
11840 & ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
11841 & (vf**2+af**2)+(vi*vpi+ai*api)*vint(115)*(vf*vpf+af*apf)+
11842 & (vpi**2+api**2)*vint(116)*(vpf**2+apf**2))
11843 wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
11844 wtmax=2d0+abs(asym)
11845 ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).EQ.24) THEN
11846C...Angular weight for f + fbar -> Z' -> W+ + W-.
11847 rm1=p(nsd(1)+1,5)**2/sh
11848 rm2=p(nsd(1)+2,5)**2/sh
11849 ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
11850 & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
11851 cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
11852 & (rm2-rm1)**2)
11853 wt=cflat+ccos2*cthe(1)**2
11854 wtmax=cflat+max(0d0,ccos2)
11855 ELSEIF(ip.EQ.1.AND.(kfl1(1).EQ.25.OR.kfl1(1).EQ.35.OR.
11856 & iabs(kfl1(1)).EQ.37)) THEN
11857C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
11858 wt=1d0-cthe(1)**2
11859 wtmax=1d0
11860 ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
11861C...Angular weight for f + fbar -> Z' -> Z0 + h0.
11862 rm1=p(nsd(1)+1,5)**2/sh
11863 rm2=p(nsd(1)+2,5)**2/sh
11864 flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
11865 wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
11866 wtmax=1d0+flam2/(8d0*rm1)
11867 ELSEIF(mzpwp.EQ.0) THEN
11868C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11869C...(W:s like if intermediate Z).
11870 d34=p(iref(ip,iord),5)**2
11871 d56=p(iref(ip,3-iord),5)**2
11872 dt=pkk(1,3)+pkk(1,4)+d34
11873 du=pkk(1,5)+pkk(1,6)+d56
11874 fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
11875 fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
11876 wt=(coup(1,3)*fgk135)**2+(coup(1,4)*fgk253)**2
11877 wtmax=4d0*d34*d56*(coup(1,3)**2+coup(1,4)**2)*
11878 & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
11879 ELSEIF(mzpwp.EQ.1) THEN
11880C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11881C...(W:s approximately longitudinal, like if intermediate H).
11882 wt=16d0*pkk(3,5)*pkk(4,6)
11883 wtmax=sh**2
11884 ELSE
11885C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
11886C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
11887 wt=1d0
11888 wtmax=1d0
11889 ENDIF
11890
11891 ELSEIF(isub.EQ.142) THEN
11892 IF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
11893C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
11894 kfai=iabs(mint(15))
11895 kfaic=1
11896 IF(kfai.GT.10) kfaic=2
11897 vi=paru(129+2*kfaic)
11898 ai=paru(130+2*kfaic)
11899 kfaf=iabs(kfl1(1))
11900 kfafc=1
11901 IF(kfaf.GT.10) kfafc=2
11902 vf=paru(129+2*kfafc)
11903 af=paru(130+2*kfafc)
11904 asym=8d0*vi*ai*vf*af/((vi**2+ai**2)*(vf**2+af**2))
11905 wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
11906 wtmax=2d0+abs(asym)
11907 ELSEIF(ip.EQ.1.AND.iabs(kfl2(1)).EQ.23) THEN
11908C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
11909 rm1=p(nsd(1)+1,5)**2/sh
11910 rm2=p(nsd(1)+2,5)**2/sh
11911 ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
11912 & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
11913 cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
11914 & (rm2-rm1)**2)
11915 wt=cflat+ccos2*cthe(1)**2
11916 wtmax=cflat+max(0d0,ccos2)
11917 ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
11918C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
11919 rm1=p(nsd(1)+1,5)**2/sh
11920 rm2=p(nsd(1)+2,5)**2/sh
11921 flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
11922 wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
11923 wtmax=1d0+flam2/(8d0*rm1)
11924 ELSEIF(mzpwp.EQ.0) THEN
11925C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11926C...(W/Z like if intermediate W).
11927 d34=p(iref(ip,iord),5)**2
11928 d56=p(iref(ip,3-iord),5)**2
11929 dt=pkk(1,3)+pkk(1,4)+d34
11930 du=pkk(1,5)+pkk(1,6)+d56
11931 fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
11932 fgk136=abs(fgk(1,2,3,4,6,5)-fgk(1,2,6,5,3,4))
11933 wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
11934 wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*
11935 & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
11936 ELSEIF(mzpwp.EQ.1) THEN
11937C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11938C...(W/Z approximately longitudinal, like if intermediate H).
11939 wt=16d0*pkk(3,5)*pkk(4,6)
11940 wtmax=sh**2
11941 ELSE
11942C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
11943C...t + bbar -> t + W + bbar.
11944 wt=1d0
11945 wtmax=1d0
11946 ENDIF
11947
11948 ELSEIF(isub.EQ.145.OR.isub.EQ.162.OR.isub.EQ.163.OR.isub.EQ.164)
11949 & THEN
11950C...Isotropic decay of leptoquarks (assumed spin 0).
11951 wt=1d0
11952 wtmax=1d0
11953
11954 ELSEIF(isub.GE.146.AND.isub.LE.148) THEN
11955C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
11956 side=1d0
11957 IF(mint(16).EQ.21.OR.mint(16).EQ.22) side=-1d0
11958 IF(ip.EQ.1.AND.(kfl1(1).EQ.21.OR.kfl1(1).EQ.22)) THEN
11959 wt=1d0+side*cthe(1)
11960 wtmax=2d0
11961 ELSEIF(ip.EQ.1) THEN
11962 rm1=p(nsd(1)+1,5)**2/sh
11963 wt=1d0+side*cthe(1)*(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
11964 wtmax=1d0+(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
11965 ELSE
11966C...W/Z decay assumed isotropic, since not known.
11967 wt=1d0
11968 wtmax=1d0
11969 ENDIF
11970
11971 ELSEIF(isub.EQ.149) THEN
11972C...Isotropic decay of techni-eta.
11973 wt=1d0
11974 wtmax=1d0
11975
11976 ELSEIF(isub.EQ.191) THEN
11977 IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
11978C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
11979C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
11980 wt=1d0-cthe(1)**2
11981 wtmax=1d0
11982 ELSEIF(ip.EQ.1) THEN
11983C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
11984 cthesg=cthe(1)*isign(1,mint(15))
11985 xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
11986 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
11987 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
11988 kfai=iabs(mint(15))
11989 ei=kchg(kfai,1)/3d0
11990 ai=sign(1d0,ei+0.1d0)
11991 vi=ai-4d0*ei*xwv
11992 vali=0.5d0*(vi+ai)
11993 vari=0.5d0*(vi-ai)
11994 alefti=(ei+vali*bwzr)**2+(vali*bwzi)**2
11995 arighi=(ei+vari*bwzr)**2+(vari*bwzi)**2
11996 kfaf=iabs(kfl1(1))
11997 ef=kchg(kfaf,1)/3d0
11998 af=sign(1d0,ef+0.1d0)
11999 vf=af-4d0*ef*xwv
12000 valf=0.5d0*(vf+af)
12001 varf=0.5d0*(vf-af)
12002 aleftf=(ef+valf*bwzr)**2+(valf*bwzi)**2
12003 arighf=(ef+varf*bwzr)**2+(varf*bwzi)**2
12004 asame=alefti*aleftf+arighi*arighf
12005 aflip=alefti*arighf+arighi*aleftf
12006 wt=asame*(1d0+cthesg)**2+aflip*(1d0-cthesg)**2
12007 wtmax=4d0*max(asame,aflip)
12008 ELSE
12009C...Isotropic decay of W/pi_tech produced in rho_tech decay.
12010 wt=1d0
12011 wtmax=1d0
12012 ENDIF
12013
12014 ELSEIF(isub.EQ.192) THEN
12015 IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
12016C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
12017C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
12018 wt=1d0-cthe(1)**2
12019 wtmax=1d0
12020 ELSEIF(ip.EQ.1) THEN
12021C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
12022 cthesg=cthe(1)*isign(1,mint(15))
12023 wt=(1d0+cthesg)**2
12024 wtmax=4d0
12025 ELSE
12026C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
12027 wt=1d0
12028 wtmax=1d0
12029 ENDIF
12030
12031 ELSEIF(isub.EQ.193) THEN
12032 IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
12033C...Angular weight for f + fbar -> omega_tech0 ->
12034C...gamma pi_tech0 or Z0 pi_tech0.
12035 wt=1d0+cthe(1)**2
12036 wtmax=2d0
12037 ELSEIF(ip.EQ.1) THEN
12038C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
12039 cthesg=cthe(1)*isign(1,mint(15))
12040 bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
12041 bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
12042 kfai=iabs(mint(15))
12043 ei=kchg(kfai,1)/3d0
12044 ai=sign(1d0,ei+0.1d0)
12045 vi=ai-4d0*ei*xwv
12046 vali=0.5d0*(vi+ai)
12047 vari=0.5d0*(vi-ai)
12048 blefti=(ei-vali*bwzr)**2+(vali*bwzi)**2
12049 brighi=(ei-vari*bwzr)**2+(vari*bwzi)**2
12050 kfaf=iabs(kfl1(1))
12051 ef=kchg(kfaf,1)/3d0
12052 af=sign(1d0,ef+0.1d0)
12053 vf=af-4d0*ef*xwv
12054 valf=0.5d0*(vf+af)
12055 varf=0.5d0*(vf-af)
12056 bleftf=(ef-valf*bwzr)**2+(valf*bwzi)**2
12057 brighf=(ef-varf*bwzr)**2+(varf*bwzi)**2
12058 bsame=blefti*bleftf+brighi*brighf
12059 bflip=blefti*brighf+brighi*bleftf
12060 wt=bsame*(1d0+cthesg)**2+bflip*(1d0-cthesg)**2
12061 wtmax=4d0*max(bsame,bflip)
12062 ELSE
12063C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
12064 wt=1d0
12065 wtmax=1d0
12066 ENDIF
12067
12068C...Obtain correct angular distribution by rejection techniques.
12069 ELSE
12070 wt=1d0
12071 wtmax=1d0
12072 ENDIF
12073 IF(wt.LT.pyr(0)*wtmax) GOTO 340
12074
12075C...Construct massive four-vectors using angles chosen.
12076 500 DO 600 jt=1,jtmax
12077 IF(kdcy(jt).EQ.0) GOTO 600
12078 id=iref(ip,jt)
12079 DO 510 j=1,5
12080 dpmo(j)=p(id,j)
12081 510 CONTINUE
12082 dpmo(4)=sqrt(dpmo(1)**2+dpmo(2)**2+dpmo(3)**2+dpmo(5)**2)
12083CMRENNA++
12084 IF(kfl3(jt).EQ.0) THEN
12085 CALL pyrobo(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),
12086 & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
12087 n0=nsd(jt)+2
12088 ELSE
12089 CALL pyrobo(nsd(jt)+1,nsd(jt)+3,acos(cthe(jt)),phi(jt),
12090 & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
12091 n0=nsd(jt)+3
12092 ENDIF
12093
12094 DO 520 j=1,4
12095 vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
12096 520 CONTINUE
12097C...Fill in position of decay vertex.
12098 DO 540 i=nsd(jt)+1,n0
12099 DO 530 j=1,4
12100 v(i,j)=vdcy(j)
12101 530 CONTINUE
12102 v(i,5)=0d0
12103 540 CONTINUE
12104CMRENNA--
12105
12106C...Mark decayed resonances; trace history.
12107 k(id,1)=k(id,1)+10
12108 kfa=iabs(k(id,2))
12109 kca=pycomp(kfa)
12110 IF(kcqm(jt).NE.0) THEN
12111C...Do not kill colour flow through coloured resonance!
12112 ELSE
12113 k(id,4)=nsd(jt)+1
12114 k(id,5)=nsd(jt)+2
12115 IF(kfl3(jt).NE.0) k(id,5)=nsd(jt)+3
12116 ENDIF
12117
12118C...Add documentation lines.
12119 IF(isub.NE.0) THEN
12120 idoc=mint(83)+mint(4)
12121CMRENNA+++
12122 ihi=nsd(jt)+2
12123 IF(kfl3(jt).NE.0) ihi=ihi+1
12124 DO 560 i=nsd(jt)+1,ihi
12125CMRENNA---
12126 i1=mint(83)+mint(4)+1
12127 k(i,3)=i1
12128 IF(mstp(128).GE.1) k(i,3)=id
12129 IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
12130 mint(4)=mint(4)+1
12131 k(i1,1)=21
12132 k(i1,2)=k(i,2)
12133 k(i1,3)=iref(ip,jt+3)
12134 DO 550 j=1,5
12135 p(i1,j)=p(i,j)
12136 550 CONTINUE
12137 ENDIF
12138 560 CONTINUE
12139 ELSE
12140 k(nsd(jt)+1,3)=id
12141 k(nsd(jt)+2,3)=id
12142 IF(kfl3(jt).NE.0) k(nsd(jt)+3,3)=id
12143 ENDIF
12144
12145C...Do showering if any of the two/three products can shower.
12146 nshbef=n
12147 IF(mstp(71).GE.1) THEN
12148 ishow1=0
12149 kfl1a=iabs(kfl1(jt))
12150 IF(kfl1a.LE.22) ishow1=1
12151 ishow2=0
12152 kfl2a=iabs(kfl2(jt))
12153 IF(kfl2a.LE.22) ishow2=1
12154 ishow3=0
12155 IF(kfl3(jt).NE.0) THEN
12156 kfl3a=iabs(kfl3(jt))
12157 IF(kfl3a.LE.22) ishow3=1
12158 ENDIF
12159 IF(ishow1.EQ.0.AND.ishow2.EQ.0.AND.ishow3.EQ.0) THEN
12160 ELSEIF(kfl3(jt).EQ.0) THEN
12161 CALL pyshow(nsd(jt)+1,nsd(jt)+2,p(id,5))
12162 ELSE
12163 nsd1=nsd(jt)+1
12164 nsd2=nsd(jt)+2
12165 IF(ishow1.EQ.0.AND.ishow3.NE.0) THEN
12166 nsd1=nsd(jt)+3
12167 ELSEIF(ishow2.EQ.0.AND.ishow3.NE.0) THEN
12168 nsd2=nsd(jt)+3
12169 ENDIF
12170 pmshow=sqrt(max(0d0,(p(nsd1,4)+p(nsd2,4))**2-
12171 & (p(nsd1,1)+p(nsd2,1))**2-(p(nsd1,2)+p(nsd2,2))**2-
12172 & (p(nsd1,3)+p(nsd2,3))**2))
12173 CALL pyshow(nsd1,nsd2,pmshow)
12174 ENDIF
12175 ENDIF
12176 nshaft=n
12177 IF(jt.EQ.1) naft1=n
12178
12179C...Check if decay products moved by shower.
12180 nsd1=nsd(jt)+1
12181 nsd2=nsd(jt)+2
12182 nsd3=nsd(jt)+3
12183 IF(nshaft.GT.nshbef) THEN
12184 IF(k(nsd1,1).GT.10) THEN
12185 DO 570 i=nshbef+1,nshaft
12186 IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd1,2)) nsd1=i
12187 570 CONTINUE
12188 ENDIF
12189 IF(k(nsd2,1).GT.10) THEN
12190 DO 580 i=nshbef+1,nshaft
12191 IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd2,2).AND.
12192 & i.NE.nsd1) nsd2=i
12193 580 CONTINUE
12194 ENDIF
12195 IF(kfl3(jt).NE.0.AND.k(nsd3,1).GT.10) THEN
12196 DO 590 i=nshbef+1,nshaft
12197 IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd3,2).AND.
12198 & i.NE.nsd1.AND.i.NE.nsd2) nsd3=i
12199 590 CONTINUE
12200 ENDIF
12201 ENDIF
12202
12203C...Store decay products for further treatment.
12204 np=np+1
12205 iref(np,1)=nsd1
12206 iref(np,2)=nsd2
12207 iref(np,3)=0
12208 IF(kfl3(jt).NE.0) iref(np,3)=nsd3
12209 iref(np,4)=idoc+1
12210 iref(np,5)=idoc+2
12211 iref(np,6)=0
12212 IF(kfl3(jt).NE.0) iref(np,6)=idoc+3
12213 iref(np,7)=k(iref(ip,jt),2)
12214 iref(np,8)=iref(ip,jt)
12215 600 CONTINUE
12216
12217C...Fill information for 2 -> 1 -> 2.
12218 610 IF(jtmax.EQ.1.AND.kdcy(1).NE.0.AND.isub.NE.0) THEN
12219 mint(7)=mint(83)+6+2*iset(isub)
12220 mint(8)=mint(83)+7+2*iset(isub)
12221 mint(25)=kfl1(1)
12222 mint(26)=kfl2(1)
12223 vint(23)=cthe(1)
12224 rm3=p(n-1,5)**2/sh
12225 rm4=p(n,5)**2/sh
12226 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
12227 vint(45)=-0.5d0*sh*(1d0-rm3-rm4-be34*cthe(1))
12228 vint(46)=-0.5d0*sh*(1d0-rm3-rm4+be34*cthe(1))
12229 vint(48)=0.25d0*sh*be34**2*max(0d0,1d0-cthe(1)**2)
12230 vint(47)=sqrt(vint(48))
12231 ENDIF
12232
12233C...Possibility of colour rearrangement in W+W- events.
12234 IF((isub.EQ.25.OR.isub.EQ.22).AND.mstp(115).GE.1) THEN
12235 iakf1=iabs(kfl1(1))
12236 iakf2=iabs(kfl1(2))
12237 iakf3=iabs(kfl2(1))
12238 iakf4=iabs(kfl2(2))
12239 IF(min(iakf1,iakf2,iakf3,iakf4).GE.1.AND.
12240 & max(iakf1,iakf2,iakf3,iakf4).LE.5) call
12241 & pyreco(iref(1,1),iref(1,2),nsd(1),naft1)
12242 ENDIF
12243
12244C...Loop back if needed.
12245 620 IF(ip.LT.np) GOTO 150
12246
12247 RETURN
12248 END
12249
12250C*********************************************************************
12251
12252C...PYMULT
12253C...Initializes treatment of multiple interactions, selects kinematics
12254C...of hardest interaction if low-pT physics included in run, and
12255C...generates all non-hardest interactions.
12256
12257 SUBROUTINE pymult(MMUL)
12258
12259C...Double precision and integer declarations.
12260 IMPLICIT DOUBLE PRECISION(a-h, o-z)
12261 IMPLICIT INTEGER(I-N)
12262 INTEGER PYK,PYCHGE,PYCOMP
12263C...Commonblocks.
12264 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
12265 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
12266 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
12267 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
12268 common/pypars/mstp(200),parp(200),msti(200),pari(200)
12269 common/pyint1/mint(400),vint(400)
12270 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
12271 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
12272 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
12273 common/pyint7/sigt(0:6,0:6,0:5)
12274 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
12275 &/pyint2/,/pyint3/,/pyint5/,/pyint7/
12276C...Local arrays and saved variables.
12277 dimension nmul(20),sigm(20),kstr(500,2),vintsv(80)
12278 SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm
12279
12280C...Initialization of multiple interaction treatment.
12281 IF(mmul.EQ.1) THEN
12282 IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
12283 isub=96
12284 mint(1)=96
12285 vint(63)=0d0
12286 vint(64)=0d0
12287 vint(143)=1d0
12288 vint(144)=1d0
12289
12290C...Loop over phase space points: xT2 choice in 20 bins.
12291 100 sigsum=0d0
12292 DO 120 ixt2=1,20
12293 nmul(ixt2)=mstp(83)
12294 sigm(ixt2)=0d0
12295 DO 110 itry=1,mstp(83)
12296 rsca=0.05d0*((21-ixt2)-pyr(0))
12297 xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
12298 xt2=max(0.01d0*vint(149),xt2)
12299 vint(25)=xt2
12300
12301C...Choose tau and y*. Calculate cos(theta-hat).
12302 IF(pyr(0).LE.coef(isub,1)) THEN
12303 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
12304 tau=xt2*(1d0+taut)**2/(4d0*taut)
12305 ELSE
12306 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
12307 ENDIF
12308 vint(21)=tau
12309 CALL pyklim(2)
12310 ryst=pyr(0)
12311 myst=1
12312 IF(ryst.GT.coef(isub,8)) myst=2
12313 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
12314 CALL pykmap(2,myst,pyr(0))
12315 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
12316
12317C...Calculate differential cross-section.
12318 vint(71)=0.5d0*vint(1)*sqrt(xt2)
12319 CALL pysigh(nchn,sigs)
12320 sigm(ixt2)=sigm(ixt2)+sigs
12321 110 CONTINUE
12322 sigsum=sigsum+sigm(ixt2)
12323 120 CONTINUE
12324 sigsum=sigsum/(20d0*mstp(83))
12325
12326C...Reject result if sigma(parton-parton) is smaller than hadronic one.
12327 IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
12328 IF(mstp(122).GE.1) WRITE(mstu(11),5100)
12329 & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
12330 parp(82)=0.9d0*parp(82)
12331 vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
12332 & vint(2)
12333 GOTO 100
12334 ENDIF
12335 IF(mstp(122).GE.1) WRITE(mstu(11),5200)
12336 & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
12337
12338C...Start iteration to find k factor.
12339 yke=sigsum/max(1d-10,sigt(0,0,5))
12340 so=0.5d0
12341 xi=0d0
12342 yi=0d0
12343 xf=0d0
12344 yf=0d0
12345 xk=0.5d0
12346 iit=0
12347 130 IF(iit.EQ.0) THEN
12348 xk=2d0*xk
12349 ELSEIF(iit.EQ.1) THEN
12350 xk=0.5d0*xk
12351 ELSE
12352 xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
12353 ENDIF
12354
12355C...Evaluate overlap integrals.
12356 IF(mstp(82).EQ.2) THEN
12357 sp=0.5d0*paru(1)*(1d0-exp(-xk))
12358 sop=sp/paru(1)
12359 ELSE
12360 IF(mstp(82).EQ.3) deltab=0.02d0
12361 IF(mstp(82).EQ.4) deltab=min(0.01d0,0.05d0*parp(84))
12362 sp=0d0
12363 sop=0d0
12364 b=-0.5d0*deltab
12365 140 b=b+deltab
12366 IF(mstp(82).EQ.3) THEN
12367 ov=exp(-b**2)/paru(2)
12368 ELSE
12369 cq2=parp(84)**2
12370 ov=((1d0-parp(83))**2*exp(-min(50d0,b**2))+
12371 & 2d0*parp(83)*(1d0-parp(83))*2d0/(1d0+cq2)*
12372 & exp(-min(50d0,b**2*2d0/(1d0+cq2)))+
12373 & parp(83)**2/cq2*exp(-min(50d0,b**2/cq2)))/paru(2)
12374 ENDIF
12375 pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
12376 sp=sp+paru(2)*b*deltab*pacc
12377 sop=sop+paru(2)*b*deltab*ov*pacc
12378 IF(b.LT.1d0.OR.b*pacc.GT.1d-6) GOTO 140
12379 ENDIF
12380 yk=paru(1)*xk*so/sp
12381
12382C...Continue iteration until convergence.
12383 IF(yk.LT.yke) THEN
12384 xi=xk
12385 yi=yk
12386 IF(iit.EQ.1) iit=2
12387 ELSE
12388 xf=xk
12389 yf=yk
12390 IF(iit.EQ.0) iit=1
12391 ENDIF
12392 IF(abs(yk-yke).GE.1d-5*yke) GOTO 130
12393
12394C...Store some results for subsequent use.
12395 vint(145)=sigsum
12396 vint(146)=sop/so
12397 vint(147)=sop/sp
12398
12399C...Initialize iteration in xT2 for hardest interaction.
12400 ELSEIF(mmul.EQ.2) THEN
12401 IF(mstp(82).LE.0) THEN
12402 ELSEIF(mstp(82).EQ.1) THEN
12403 xt2=1d0
12404 sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
12405 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
12406 & vint(317)/(vint(318)*vint(320))
12407 xt2fac=sigrat*vint(149)/(1d0-vint(149))
12408 ELSEIF(mstp(82).EQ.2) THEN
12409 xt2=1d0
12410 xt2fac=vint(146)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
12411 & vint(149)*(1d0+vint(149))
12412 ELSE
12413 xc2=4d0*ckin(3)**2/vint(2)
12414 IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
12415 ENDIF
12416
12417 ELSEIF(mmul.EQ.3) THEN
12418C...Low-pT or multiple interactions (first semihard interaction):
12419C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
12420C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
12421 isub=mint(1)
12422 IF(mstp(82).LE.0) THEN
12423 xt2=0d0
12424 ELSEIF(mstp(82).EQ.1) THEN
12425 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
12426 ELSEIF(mstp(82).EQ.2) THEN
12427 IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
12428 & vint(149)))).GT.pyr(0)) xt2=1d0
12429 IF(xt2.GE.1d0) THEN
12430 xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
12431 & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
12432 & vint(149)
12433 ELSE
12434 xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
12435 & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
12436 & vint(149)
12437 ENDIF
12438 xt2=max(0.01d0*vint(149),xt2)
12439 ELSE
12440 xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
12441 & pyr(0)*(1d0-xc2))-vint(149)
12442 xt2=max(0.01d0*vint(149),xt2)
12443 ENDIF
12444 vint(25)=xt2
12445
12446C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
12447 IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
12448 IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-1
12449 IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-1
12450 isub=95
12451 mint(1)=isub
12452 vint(21)=0.01d0*vint(149)
12453 vint(22)=0d0
12454 vint(23)=0d0
12455 vint(25)=0.01d0*vint(149)
12456
12457 ELSE
12458C...Multiple interactions (first semihard interaction).
12459C...Choose tau and y*. Calculate cos(theta-hat).
12460 IF(pyr(0).LE.coef(isub,1)) THEN
12461 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
12462 tau=xt2*(1d0+taut)**2/(4d0*taut)
12463 ELSE
12464 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
12465 ENDIF
12466 vint(21)=tau
12467 CALL pyklim(2)
12468 ryst=pyr(0)
12469 myst=1
12470 IF(ryst.GT.coef(isub,8)) myst=2
12471 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
12472 CALL pykmap(2,myst,pyr(0))
12473 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
12474 ENDIF
12475 vint(71)=0.5d0*vint(1)*sqrt(vint(25))
12476
12477C...Store results of cross-section calculation.
12478 ELSEIF(mmul.EQ.4) THEN
12479 isub=mint(1)
12480 xts=vint(25)
12481 IF(iset(isub).EQ.1) xts=vint(21)
12482 IF(iset(isub).EQ.2)
12483 & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
12484 IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
12485 rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
12486 & (xts+vint(149))))
12487 irbin=int(1d0+20d0*rbin)
12488 IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
12489 nmul(irbin)=nmul(irbin)+1
12490 sigm(irbin)=sigm(irbin)+vint(153)
12491 ENDIF
12492
12493C...Choose impact parameter.
12494 ELSEIF(mmul.EQ.5) THEN
12495 isub=mint(1)
12496 145 IF(mstp(82).EQ.3) THEN
12497 vint(148)=pyr(0)/(paru(2)*vint(147))
12498 ELSE
12499 rtype=pyr(0)
12500 cq2=parp(84)**2
12501 IF(rtype.LT.(1d0-parp(83))**2) THEN
12502 b2=-log(pyr(0))
12503 ELSEIF(rtype.LT.1d0-parp(83)**2) THEN
12504 b2=-0.5d0*(1d0+cq2)*log(pyr(0))
12505 ELSE
12506 b2=-cq2*log(pyr(0))
12507 ENDIF
12508 vint(148)=((1d0-parp(83))**2*exp(-min(50d0,b2))+2d0*parp(83)*
12509 & (1d0-parp(83))*2d0/(1d0+cq2)*exp(-min(50d0,b2*2d0/(1d0+cq2)))+
12510 & parp(83)**2/cq2*exp(-min(50d0,b2/cq2)))/(paru(2)*vint(147))
12511 ENDIF
12512
12513C...Multiple interactions (variable impact parameter) : reject with
12514C...probability exp(-overlap*cross-section above pT/normalization).
12515 rncor=(irbin-20d0*rbin)*nmul(irbin)
12516 sigcor=(irbin-20d0*rbin)*sigm(irbin)
12517 DO 150 ibin=irbin+1,20
12518 rncor=rncor+nmul(ibin)
12519 sigcor=sigcor+sigm(ibin)
12520 150 CONTINUE
12521 sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
12522 IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
12523 vint(150)=exp(-min(50d0,vint(146)*vint(148)*
12524 & sigabv/max(1d-10,sigt(0,0,5))))
12525 IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
12526 & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
12527 & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
12528 IF(vint(150).LT.pyr(0)) GOTO 145
12529 vint(150)=1d0
12530 ENDIF
12531
12532C...Generate additional multiple semihard interactions.
12533 ELSEIF(mmul.EQ.6) THEN
12534 isubsv=mint(1)
12535 DO 160 j=11,80
12536 vintsv(j)=vint(j)
12537 160 CONTINUE
12538 isub=96
12539 mint(1)=96
12540 vint(151)=0d0
12541 vint(152)=0d0
12542
12543C...Reconstruct strings in hard scattering.
12544 nmax=mint(84)+4
12545 IF(iset(isubsv).EQ.1) nmax=mint(84)+2
12546 IF(iset(isubsv).EQ.11) nmax=mint(84)+2+mint(3)
12547 nstr=0
12548 DO 180 i=mint(84)+1,nmax
12549 kcs=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
12550 IF(kcs.EQ.0) GOTO 180
12551 DO 170 j=1,4
12552 IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) GOTO 170
12553 IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) GOTO 170
12554 IF(j.LE.2) THEN
12555 ist=mod(k(i,j+3)/mstu(5),mstu(5))
12556 ELSE
12557 ist=mod(k(i,j+1),mstu(5))
12558 ENDIF
12559 IF(ist.LT.mint(84).OR.ist.GT.i) GOTO 170
12560 IF(kchg(pycomp(k(ist,2)),2).EQ.0) GOTO 170
12561 nstr=nstr+1
12562 IF(j.EQ.1.OR.j.EQ.4) THEN
12563 kstr(nstr,1)=i
12564 kstr(nstr,2)=ist
12565 ELSE
12566 kstr(nstr,1)=ist
12567 kstr(nstr,2)=i
12568 ENDIF
12569 170 CONTINUE
12570 180 CONTINUE
12571
12572C...Set up starting values for iteration in xT2.
12573 IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
12574 & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
12575 & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
12576 & isubsv.NE.96)) THEN
12577 xt2=(1d0-vint(141))*(1d0-vint(142))
12578 ELSE
12579 xt2=vint(25)
12580 IF(iset(isubsv).EQ.1) xt2=vint(21)
12581 IF(iset(isubsv).EQ.2)
12582 & xt2=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
12583 IF(iset(isubsv).GE.3.AND.iset(isubsv).LE.5) xt2=vint(26)
12584 ENDIF
12585 IF(mstp(82).LE.1) THEN
12586 sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
12587 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
12588 & vint(317)/(vint(318)*vint(320))
12589 xt2fac=sigrat*vint(149)/(1d0-vint(149))
12590 ELSE
12591 xt2fac=vint(146)*vint(148)*xsec(isub,1)/
12592 & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
12593 ENDIF
12594 vint(63)=0d0
12595 vint(64)=0d0
12596 vint(143)=1d0-vint(141)
12597 vint(144)=1d0-vint(142)
12598
12599C...Iterate downwards in xT2.
12600 190 IF(mstp(82).LE.1) THEN
12601 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
12602 IF(xt2.LT.vint(149)) GOTO 240
12603 ELSE
12604 IF(xt2.LE.0.01001d0*vint(149)) GOTO 240
12605 xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
12606 & log(pyr(0)))-vint(149)
12607 IF(xt2.LE.0d0) GOTO 240
12608 xt2=max(0.01d0*vint(149),xt2)
12609 ENDIF
12610 vint(25)=xt2
12611
12612C...Choose tau and y*. Calculate cos(theta-hat).
12613 IF(pyr(0).LE.coef(isub,1)) THEN
12614 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
12615 tau=xt2*(1d0+taut)**2/(4d0*taut)
12616 ELSE
12617 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
12618 ENDIF
12619 vint(21)=tau
12620 CALL pyklim(2)
12621 ryst=pyr(0)
12622 myst=1
12623 IF(ryst.GT.coef(isub,8)) myst=2
12624 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
12625 CALL pykmap(2,myst,pyr(0))
12626 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
12627
12628C...Check that x not used up. Accept or reject kinematical variables.
12629 x1m=sqrt(tau)*exp(vint(22))
12630 x2m=sqrt(tau)*exp(-vint(22))
12631 IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 190
12632 vint(71)=0.5d0*vint(1)*sqrt(xt2)
12633 CALL pysigh(nchn,sigs)
12634 IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
12635 IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 190
12636
12637C...Reset K, P and V vectors. Select some variables.
12638 DO 210 i=n+1,n+2
12639 DO 200 j=1,5
12640 k(i,j)=0
12641 p(i,j)=0d0
12642 v(i,j)=0d0
12643 200 CONTINUE
12644 210 CONTINUE
12645 rflav=pyr(0)
12646 pt=0.5d0*vint(1)*sqrt(xt2)
12647 phi=paru(2)*pyr(0)
12648 cth=vint(23)
12649
12650C...Add first parton to event record.
12651 k(n+1,1)=3
12652 k(n+1,2)=21
12653 IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=
12654 & 1+int((2d0+parj(2))*pyr(0))
12655 p(n+1,1)=pt*cos(phi)
12656 p(n+1,2)=pt*sin(phi)
12657 p(n+1,3)=0.25d0*vint(1)*(vint(41)*(1d0+cth)-vint(42)*(1d0-cth))
12658 p(n+1,4)=0.25d0*vint(1)*(vint(41)*(1d0+cth)+vint(42)*(1d0-cth))
12659 p(n+1,5)=0d0
12660
12661C...Add second parton to event record.
12662 k(n+2,1)=3
12663 k(n+2,2)=21
12664 IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)
12665 p(n+2,1)=-p(n+1,1)
12666 p(n+2,2)=-p(n+1,2)
12667 p(n+2,3)=0.25d0*vint(1)*(vint(41)*(1d0-cth)-vint(42)*(1d0+cth))
12668 p(n+2,4)=0.25d0*vint(1)*(vint(41)*(1d0-cth)+vint(42)*(1d0+cth))
12669 p(n+2,5)=0d0
12670
12671 IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN
12672C....Choose relevant string pieces to place gluons on.
12673 DO 230 i=n+1,n+2
12674 dmin=1d8
12675 DO 220 istr=1,nstr
12676 i1=kstr(istr,1)
12677 i2=kstr(istr,2)
12678 dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-
12679 & p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-
12680 & p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1d0,p(i1,4)*p(i2,4)-
12681 & p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))
12682 IF(istr.EQ.1.OR.dist.LT.dmin) THEN
12683 dmin=dist
12684 ist1=i1
12685 ist2=i2
12686 istm=istr
12687 ENDIF
12688 220 CONTINUE
12689
12690C....Colour flow adjustments, new string pieces.
12691 IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+
12692 & mod(k(ist1,4),mstu(5))
12693 IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=
12694 & mstu(5)*(k(ist1,5)/mstu(5))+i
12695 k(i,5)=mstu(5)*ist1
12696 k(i,4)=mstu(5)*ist2
12697 IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+
12698 & mod(k(ist2,5),mstu(5))
12699 IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=
12700 & mstu(5)*(k(ist2,4)/mstu(5))+i
12701 kstr(istm,2)=i
12702 kstr(nstr+1,1)=i
12703 kstr(nstr+1,2)=ist2
12704 nstr=nstr+1
12705 230 CONTINUE
12706
12707C...String drawing and colour flow for gluon loop.
12708 ELSEIF(k(n+1,2).EQ.21) THEN
12709 k(n+1,4)=mstu(5)*(n+2)
12710 k(n+1,5)=mstu(5)*(n+2)
12711 k(n+2,4)=mstu(5)*(n+1)
12712 k(n+2,5)=mstu(5)*(n+1)
12713 kstr(nstr+1,1)=n+1
12714 kstr(nstr+1,2)=n+2
12715 kstr(nstr+2,1)=n+2
12716 kstr(nstr+2,2)=n+1
12717 nstr=nstr+2
12718
12719C...String drawing and colour flow for qqbar pair.
12720 ELSE
12721 k(n+1,4)=mstu(5)*(n+2)
12722 k(n+2,5)=mstu(5)*(n+1)
12723 kstr(nstr+1,1)=n+1
12724 kstr(nstr+1,2)=n+2
12725 nstr=nstr+1
12726 ENDIF
12727
12728C...Update remaining energy; iterate.
12729 n=n+2
12730 IF(n.GT.mstu(4)-mstu(32)-10) THEN
12731 CALL pyerrm(11,'(PYMULT:) no more memory left in PYJETS')
12732 IF(mstu(21).GE.1) RETURN
12733 ENDIF
12734 mint(31)=mint(31)+1
12735 vint(151)=vint(151)+vint(41)
12736 vint(152)=vint(152)+vint(42)
12737 vint(143)=vint(143)-vint(41)
12738 vint(144)=vint(144)-vint(42)
12739 IF(mint(31).LT.240) GOTO 190
12740 240 CONTINUE
12741 mint(1)=isubsv
12742 DO 250 j=11,80
12743 vint(j)=vintsv(j)
12744 250 CONTINUE
12745 ENDIF
12746
12747C...Format statements for printout.
12748 5000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',
12749 &'actions for MSTP(82) =',i2,' ******')
12750 5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
12751 &d9.2,' mb: rejected')
12752 5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
12753 &d9.2,' mb: accepted')
12754
12755 RETURN
12756 END
12757
12758C*********************************************************************
12759
12760C...PYREMN
12761C...Adds on target remnants (one or two from each side) and
12762C...includes primordial kT for hadron beams.
12763
12764 SUBROUTINE pyremn(IPU1,IPU2)
12765
12766C...Double precision and integer declarations.
12767 IMPLICIT DOUBLE PRECISION(a-h, o-z)
12768 IMPLICIT INTEGER(I-N)
12769 INTEGER PYK,PYCHGE,PYCOMP
12770C...Commonblocks.
12771 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
12772 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
12773 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
12774 common/pypars/mstp(200),parp(200),msti(200),pari(200)
12775 common/pyint1/mint(400),vint(400)
12776 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
12777C...Local arrays.
12778 dimension kflch(2),kflsp(2),chi(2),pms(0:6),is(2),isn(2),robo(5),
12779 &psys(0:2,5),pmin(0:2),qold(4),qnew(4),dbe(3),psum(4)
12780
12781C...Find event type and remaining energy.
12782 isub=mint(1)
12783 ns=n
12784 IF(mint(50).EQ.0.OR.mstp(81).LE.0) THEN
12785 vint(143)=1d0-vint(141)
12786 vint(144)=1d0-vint(142)
12787 ENDIF
12788
12789C...Define initial partons.
12790 ntry=0
12791 100 ntry=ntry+1
12792 DO 130 jt=1,2
12793 i=mint(83)+jt+2
12794 IF(jt.EQ.1) ipu=ipu1
12795 IF(jt.EQ.2) ipu=ipu2
12796 k(i,1)=21
12797 k(i,2)=k(ipu,2)
12798 k(i,3)=i-2
12799 pms(jt)=0d0
12800 vint(156+jt)=0d0
12801 vint(158+jt)=0d0
12802 IF(mint(47).EQ.1) THEN
12803 DO 110 j=1,5
12804 p(i,j)=p(i-2,j)
12805 110 CONTINUE
12806 ELSEIF(isub.EQ.95) THEN
12807 k(i,2)=21
12808 ELSE
12809 p(i,5)=p(ipu,5)
12810
12811C...No primordial kT, or chosen according to truncated Gaussian or
12812C...exponential, or (for photon) predetermined or power law.
12813 120 IF(mint(40+jt).EQ.2.AND.mint(10+jt).NE.22) THEN
12814 IF(mstp(91).LE.0) THEN
12815 pt=0d0
12816 ELSEIF(mstp(91).EQ.1) THEN
12817 pt=parp(91)*sqrt(-log(pyr(0)))
12818 ELSE
12819 rpt1=pyr(0)
12820 rpt2=pyr(0)
12821 pt=-parp(92)*log(rpt1*rpt2)
12822 ENDIF
12823 IF(pt.GT.parp(93)) GOTO 120
12824 ELSEIF(mint(106+jt).EQ.3) THEN
12825 pta=sqrt(vint(282+jt))
12826 ptb=0d0
12827 IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
12828 ptb=parp(99)*sqrt(-log(pyr(0)))
12829 ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
12830 rpt1=pyr(0)
12831 rpt2=pyr(0)
12832 ptb=-parp(99)*log(rpt1*rpt2)
12833 ENDIF
12834 IF(ptb.GT.parp(100)) GOTO 120
12835 pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
12836 pt=pt*0.8d0**mint(57)
12837 IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
12838 ELSEIF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) THEN
12839 IF(mstp(93).LE.0) THEN
12840 pt=0d0
12841 ELSEIF(mstp(93).EQ.1) THEN
12842 pt=parp(99)*sqrt(-log(pyr(0)))
12843 ELSEIF(mstp(93).EQ.2) THEN
12844 rpt1=pyr(0)
12845 rpt2=pyr(0)
12846 pt=-parp(99)*log(rpt1*rpt2)
12847 ELSEIF(mstp(93).EQ.3) THEN
12848 ha=parp(99)**2
12849 hb=parp(100)**2
12850 pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
12851 ELSE
12852 ha=parp(99)**2
12853 hb=parp(100)**2
12854 IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
12855 pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
12856 ENDIF
12857 IF(pt.GT.parp(100)) GOTO 120
12858 ELSE
12859 pt=0d0
12860 ENDIF
12861 vint(156+jt)=pt
12862 phi=paru(2)*pyr(0)
12863 p(i,1)=pt*cos(phi)
12864 p(i,2)=pt*sin(phi)
12865 pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
12866 ENDIF
12867 130 CONTINUE
12868 IF(mint(47).EQ.1) RETURN
12869
12870C...Kinematics construction for initial partons.
12871 i1=mint(83)+3
12872 i2=mint(83)+4
12873 IF(isub.EQ.95) THEN
12874 shs=0d0
12875 shr=0d0
12876 ELSE
12877 shs=vint(141)*vint(142)*vint(2)+(p(i1,1)+p(i2,1))**2+
12878 & (p(i1,2)+p(i2,2))**2
12879 shr=sqrt(max(0d0,shs))
12880 IF((shs-pms(1)-pms(2))**2-4d0*pms(1)*pms(2).LE.0d0) GOTO 100
12881 p(i1,4)=0.5d0*(shr+(pms(1)-pms(2))/shr)
12882 p(i1,3)=sqrt(max(0d0,p(i1,4)**2-pms(1)))
12883 p(i2,4)=shr-p(i1,4)
12884 p(i2,3)=-p(i1,3)
12885
12886C...Transform partons to overall CM-frame.
12887 robo(3)=(p(i1,1)+p(i2,1))/shr
12888 robo(4)=(p(i1,2)+p(i2,2))/shr
12889 CALL pyrobo(i1,i2,0d0,0d0,-robo(3),-robo(4),0d0)
12890 robo(2)=pyangl(p(i1,1),p(i1,2))
12891 CALL pyrobo(i1,i2,0d0,-robo(2),0d0,0d0,0d0)
12892 robo(1)=pyangl(p(i1,3),p(i1,1))
12893 CALL pyrobo(i1,i2,-robo(1),0d0,0d0,0d0,0d0)
12894 CALL pyrobo(i1,mint(52),robo(1),robo(2),robo(3),robo(4),0d0)
12895 robo(5)=(vint(141)-vint(142))/(vint(141)+vint(142))
12896 CALL pyrobo(i1,mint(52),0d0,0d0,0d0,0d0,robo(5))
12897 ENDIF
12898
12899C...Optionally fix up x and Q2 definitions for leptoproduction.
12900 idisxq=0
12901 IF((mint(43).EQ.2.OR.mint(43).EQ.3).AND.((isub.EQ.10.AND.
12902 &mstp(23).GE.1).OR.(isub.EQ.83.AND.mstp(23).GE.2))) idisxq=1
12903 IF(idisxq.EQ.1) THEN
12904
12905C...Find where incoming and outgoing leptons/partons are sitting.
12906 lesd=1
12907 IF(mint(42).EQ.1) lesd=2
12908 lpin=mint(83)+3-lesd
12909 lein=mint(84)+lesd
12910 lqin=mint(84)+3-lesd
12911 leout=mint(84)+2+lesd
12912 lqout=mint(84)+5-lesd
12913 IF(k(lein,3).GT.lein) lein=k(lein,3)
12914 IF(k(lqin,3).GT.lqin) lqin=k(lqin,3)
12915 lscms=0
12916 DO 140 i=mint(84)+5,n
12917 IF(k(i,2).EQ.94) THEN
12918 lscms=i
12919 leout=i+lesd
12920 lqout=i+3-lesd
12921 ENDIF
12922 140 CONTINUE
12923 lqbg=ipu1
12924 IF(lesd.EQ.1) lqbg=ipu2
12925
12926C...Calculate actual and wanted momentum transfer.
12927 xnom=vint(43-lesd)
12928 q2nom=-vint(45)
12929 hpk=2d0*(p(lpin,4)*p(lein,4)-p(lpin,1)*p(lein,1)-
12930 & p(lpin,2)*p(lein,2)-p(lpin,3)*p(lein,3))*
12931 & (p(mint(83)+lesd,4)*vint(40+lesd)/p(lein,4))
12932 hpt2=max(0d0,q2nom*(1d0-q2nom/(xnom*hpk)))
12933 fac=sqrt(hpt2/(p(leout,1)**2+p(leout,2)**2))
12934 p(n+1,1)=fac*p(leout,1)
12935 p(n+1,2)=fac*p(leout,2)
12936 p(n+1,3)=0.25d0*((hpk-q2nom/xnom)/p(lpin,4)-
12937 & q2nom/(p(mint(83)+lesd,4)*vint(40+lesd)))*(-1)**(lesd+1)
12938 p(n+1,4)=sqrt(p(leout,5)**2+p(n+1,1)**2+p(n+1,2)**2+
12939 & p(n+1,3)**2)
12940 DO 150 j=1,4
12941 qold(j)=p(lein,j)-p(leout,j)
12942 qnew(j)=p(lein,j)-p(n+1,j)
12943 150 CONTINUE
12944
12945C...Boost outgoing electron and daughters.
12946 IF(lscms.EQ.0) THEN
12947 DO 160 j=1,4
12948 p(leout,j)=p(n+1,j)
12949 160 CONTINUE
12950 ELSE
12951 DO 170 j=1,3
12952 p(n+2,j)=(p(n+1,j)-p(leout,j))/(p(n+1,4)+p(leout,4))
12953 170 CONTINUE
12954 pinv=2d0/(1d0+p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2)
12955 DO 180 j=1,3
12956 dbe(j)=pinv*p(n+2,j)
12957 180 CONTINUE
12958 DO 200 i=lscms+1,n
12959 iorig=i
12960 190 iorig=k(iorig,3)
12961 IF(iorig.GT.leout) GOTO 190
12962 IF(i.EQ.leout.OR.iorig.EQ.leout)
12963 & CALL pyrobo(i,i,0d0,0d0,dbe(1),dbe(2),dbe(3))
12964 200 CONTINUE
12965 ENDIF
12966
12967C...Copy shower initiator and all outgoing partons.
12968 ncop=n+1
12969 k(ncop,3)=lqbg
12970 DO 210 j=1,5
12971 p(ncop,j)=p(lqbg,j)
12972 210 CONTINUE
12973 DO 240 i=mint(84)+1,n
12974 icop=0
12975 IF(k(i,1).GT.10) GOTO 240
12976 IF(i.EQ.lqbg.OR.i.EQ.lqout) THEN
12977 icop=i
12978 ELSE
12979 iorig=i
12980 220 iorig=k(iorig,3)
12981 IF(iorig.EQ.lqbg.OR.iorig.EQ.lqout) THEN
12982 icop=iorig
12983 ELSEIF(iorig.GT.mint(84).AND.iorig.LE.n) THEN
12984 GOTO 220
12985 ENDIF
12986 ENDIF
12987 IF(icop.NE.0) THEN
12988 ncop=ncop+1
12989 k(ncop,3)=i
12990 DO 230 j=1,5
12991 p(ncop,j)=p(i,j)
12992 230 CONTINUE
12993 ENDIF
12994 240 CONTINUE
12995
12996C...Calculate relative rescaling factors.
12997 slc=3-2*lesd
12998 plcsum=0d0
12999 DO 250 i=n+2,ncop
13000 plcsum=plcsum+(p(i,4)+slc*p(i,3))
13001 250 CONTINUE
13002 DO 260 i=n+2,ncop
13003 v(i,1)=(p(i,4)+slc*p(i,3))/plcsum
13004 260 CONTINUE
13005
13006C...Transfer extra three-momentum of current.
13007 DO 280 i=n+2,ncop
13008 DO 270 j=1,3
13009 p(i,j)=p(i,j)+v(i,1)*(qnew(j)-qold(j))
13010 270 CONTINUE
13011 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
13012 280 CONTINUE
13013
13014C...Iterate change of initiator momentum to get energy right.
13015 iter=0
13016 290 iter=iter+1
13017 peex=-p(n+1,4)-qnew(4)
13018 pemv=-p(n+1,3)/p(n+1,4)
13019 DO 300 i=n+2,ncop
13020 peex=peex+p(i,4)
13021 pemv=pemv+v(i,1)*p(i,3)/p(i,4)
13022 300 CONTINUE
13023 IF(abs(pemv).LT.1d-10) THEN
13024 mint(51)=1
13025 mint(57)=mint(57)+1
13026 RETURN
13027 ENDIF
13028 pzch=-peex/pemv
13029 p(n+1,3)=p(n+1,3)+pzch
13030 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)
13031 DO 310 i=n+2,ncop
13032 p(i,3)=p(i,3)+v(i,1)*pzch
13033 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
13034 310 CONTINUE
13035 IF(iter.LT.10.AND.abs(peex).GT.1d-6*p(n+1,4)) GOTO 290
13036
13037C...Modify momenta in event record.
13038 hbe=2d0*(p(n+1,4)+p(lqbg,4))*(p(n+1,3)-p(lqbg,3))/
13039 & ((p(n+1,4)+p(lqbg,4))**2+(p(n+1,3)-p(lqbg,3))**2)
13040 IF(abs(hbe).GE.1d0) THEN
13041 mint(51)=1
13042 mint(57)=mint(57)+1
13043 RETURN
13044 ENDIF
13045 i=mint(83)+5-lesd
13046 CALL pyrobo(i,i,0d0,0d0,0d0,0d0,hbe)
13047 DO 330 i=n+1,ncop
13048 icop=k(i,3)
13049 DO 320 j=1,4
13050 p(icop,j)=p(i,j)
13051 320 CONTINUE
13052 330 CONTINUE
13053 ENDIF
13054
13055C...Check minimum invariant mass of remnant system(s).
13056 psys(0,4)=p(i1,4)+p(i2,4)+0.5d0*vint(1)*(vint(151)+vint(152))
13057 psys(0,3)=p(i1,3)+p(i2,3)+0.5d0*vint(1)*(vint(151)-vint(152))
13058 pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
13059 pmin(0)=sqrt(pms(0))
13060 DO 340 jt=1,2
13061 psys(jt,4)=0.5d0*vint(1)*vint(142+jt)
13062 psys(jt,3)=psys(jt,4)*(-1)**(jt-1)
13063 pmin(jt)=0d0
13064 IF(mint(44+jt).EQ.1) GOTO 340
13065 mint(105)=mint(102+jt)
13066 mint(109)=mint(106+jt)
13067 CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))
13068 IF(mint(51).NE.0) THEN
13069 mint(57)=mint(57)+1
13070 RETURN
13071 ENDIF
13072 IF(kflch(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflch(jt))
13073 IF(kflsp(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflsp(jt))
13074 IF(kflch(jt)*kflsp(jt).NE.0) pmin(jt)=pmin(jt)+0.5d0*parp(111)
13075 pmin(jt)=sqrt(pmin(jt)**2+p(mint(83)+jt+2,1)**2+
13076 & p(mint(83)+jt+2,2)**2)
13077 340 CONTINUE
13078 IF(pmin(0)+pmin(1)+pmin(2).GT.vint(1).OR.(mint(45).GE.2.AND.
13079 &pmin(1).GT.psys(1,4)).OR.(mint(46).GE.2.AND.pmin(2).GT.
13080 &psys(2,4))) THEN
13081 mint(51)=1
13082 mint(57)=mint(57)+1
13083 RETURN
13084 ENDIF
13085
13086C...Loop over two remnants; skip if none there.
13087 i=ns
13088 DO 410 jt=1,2
13089 isn(jt)=0
13090 IF(mint(44+jt).EQ.1) GOTO 410
13091 IF(jt.EQ.1) ipu=ipu1
13092 IF(jt.EQ.2) ipu=ipu2
13093
13094C...Store first remnant parton.
13095 i=i+1
13096 is(jt)=i
13097 isn(jt)=1
13098 DO 350 j=1,5
13099 k(i,j)=0
13100 p(i,j)=0d0
13101 v(i,j)=0d0
13102 350 CONTINUE
13103 k(i,1)=1
13104 k(i,2)=kflsp(jt)
13105 k(i,3)=mint(83)+jt
13106 p(i,5)=pymass(k(i,2))
13107
13108C...First parton colour connections and kinematics.
13109 kcol=kchg(pycomp(kflsp(jt)),2)
13110 IF(kcol.EQ.2) THEN
13111 k(i,1)=3
13112 k(i,4)=mstu(5)*ipu+ipu
13113 k(i,5)=mstu(5)*ipu+ipu
13114 k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
13115 k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
13116 ELSEIF(kcol.NE.0) THEN
13117 k(i,1)=3
13118 kfls=(3-kcol*isign(1,kflsp(jt)))/2
13119 k(i,kfls+3)=ipu
13120 k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
13121 ENDIF
13122 IF(kflch(jt).EQ.0) THEN
13123 p(i,1)=-p(mint(83)+jt+2,1)
13124 p(i,2)=-p(mint(83)+jt+2,2)
13125 pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
13126 psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
13127 p(i,3)=psys(jt,3)
13128 p(i,4)=psys(jt,4)
13129
13130C...When extra remnant parton or hadron: store extra remnant.
13131 ELSE
13132 i=i+1
13133 isn(jt)=2
13134 DO 360 j=1,5
13135 k(i,j)=0
13136 p(i,j)=0d0
13137 v(i,j)=0d0
13138 360 CONTINUE
13139 k(i,1)=1
13140 k(i,2)=kflch(jt)
13141 k(i,3)=mint(83)+jt
13142 p(i,5)=pymass(k(i,2))
13143
13144C...Find parton colour connections of extra remnant.
13145 kcol=kchg(pycomp(kflch(jt)),2)
13146 IF(kcol.EQ.2) THEN
13147 k(i,1)=3
13148 k(i,4)=mstu(5)*ipu+ipu
13149 k(i,5)=mstu(5)*ipu+ipu
13150 k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
13151 k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
13152 ELSEIF(kcol.NE.0) THEN
13153 k(i,1)=3
13154 kfls=(3-kcol*isign(1,kflch(jt)))/2
13155 k(i,kfls+3)=ipu
13156 k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
13157 ENDIF
13158
13159C...Relative transverse momentum when two remnants.
13160 loop=0
13161 370 loop=loop+1
13162 CALL pyptdi(1,p(i-1,1),p(i-1,2))
13163 IF(iabs(mint(10+jt)).LT.20) THEN
13164 p(i-1,1)=0d0
13165 p(i-1,2)=0d0
13166 ELSE
13167 p(i-1,1)=p(i-1,1)-0.5d0*p(mint(83)+jt+2,1)
13168 p(i-1,2)=p(i-1,2)-0.5d0*p(mint(83)+jt+2,2)
13169 ENDIF
13170 pms(jt+2)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
13171 p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)
13172 p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)
13173 pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
13174
13175C...Meson or baryon; photon as meson. For splitup below.
13176 imb=1
13177 IF(mod(mint(10+jt)/1000,10).NE.0) imb=2
13178
13179C***Relative distribution for electron into two electrons. Temporary!
13180 IF(iabs(mint(10+jt)).LT.20.AND.mint(14+jt).EQ.-mint(10+jt))
13181 & THEN
13182 chi(jt)=pyr(0)
13183
13184C...Relative distribution of electron energy into electron plus parton.
13185 ELSEIF(iabs(mint(10+jt)).LT.20) THEN
13186 xhrd=vint(140+jt)
13187 xe=vint(154+jt)
13188 chi(jt)=(xe-xhrd)/(1d0-xhrd)
13189
13190C...Relative distribution of energy for particle into two jets.
13191 ELSEIF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN
13192 chik=parp(92+2*imb)
13193 IF(mstp(92).LE.1) THEN
13194 IF(imb.EQ.1) chi(jt)=pyr(0)
13195 IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
13196 ELSEIF(mstp(92).EQ.2) THEN
13197 chi(jt)=1d0-pyr(0)**(1d0/(1d0+chik))
13198 ELSEIF(mstp(92).EQ.3) THEN
13199 cut=2d0*0.3d0/vint(1)
13200 380 chi(jt)=pyr(0)**2
13201 IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25d0*
13202 & (1d0-chi(jt))**chik.LT.pyr(0)) GOTO 380
13203 ELSEIF(mstp(92).EQ.4) THEN
13204 cut=2d0*0.3d0/vint(1)
13205 cutr=(1d0+sqrt(1d0+cut**2))/cut
13206 390 chir=cut*cutr**pyr(0)
13207 chi(jt)=(chir**2-cut**2)/(2d0*chir)
13208 IF((1d0-chi(jt))**chik.LT.pyr(0)) GOTO 390
13209 ELSE
13210 cut=2d0*0.3d0/vint(1)
13211 cuta=cut**(1d0-parp(98))
13212 cutb=(1d0+cut)**(1d0-parp(98))
13213 400 chi(jt)=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
13214 IF(((chi(jt)+cut)**2/(2d0*(chi(jt)**2+cut**2)))**
13215 & (0.5d0*parp(98))*(1d0-chi(jt))**chik.LT.pyr(0)) GOTO 400
13216 ENDIF
13217
13218C...Relative distribution of energy for particle into jet plus particle.
13219 ELSE
13220 IF(mstp(94).LE.1) THEN
13221 IF(imb.EQ.1) chi(jt)=pyr(0)
13222 IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
13223 IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
13224 ELSEIF(mstp(94).EQ.2) THEN
13225 chi(jt)=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
13226 IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
13227 ELSEIF(mstp(94).EQ.3) THEN
13228 CALL pyzdis(1,0,pms(jt+4),zz)
13229 chi(jt)=zz
13230 ELSE
13231 CALL pyzdis(1000,0,pms(jt+4),zz)
13232 chi(jt)=zz
13233 ENDIF
13234 ENDIF
13235
13236C...Construct total transverse mass; reject if too large.
13237 chi(jt)=max(1d-8,min(1d0-1d-8,chi(jt)))
13238 pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1d0-chi(jt))
13239 IF(pms(jt).GT.psys(jt,4)**2) THEN
13240 IF(loop.LT.10) THEN
13241 GOTO 370
13242 ELSE
13243 mint(51)=1
13244 mint(57)=mint(57)+1
13245 RETURN
13246 ENDIF
13247 ENDIF
13248 psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
13249 vint(158+jt)=chi(jt)
13250
13251C...Subdivide longitudinal momentum according to value selected above.
13252 pw1=chi(jt)*(psys(jt,4)+abs(psys(jt,3)))
13253 p(is(jt)+1,4)=0.5d0*(pw1+pms(jt+4)/pw1)
13254 p(is(jt)+1,3)=0.5d0*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
13255 p(is(jt),4)=psys(jt,4)-p(is(jt)+1,4)
13256 p(is(jt),3)=psys(jt,3)-p(is(jt)+1,3)
13257 ENDIF
13258 410 CONTINUE
13259 n=i
13260
13261C...Check if longitudinal boosts needed - if so pick two systems.
13262 pdev=abs(psys(0,4)+psys(1,4)+psys(2,4)-vint(1))+
13263 &abs(psys(0,3)+psys(1,3)+psys(2,3))
13264 IF(pdev.LE.1d-6*vint(1)) RETURN
13265 IF(isn(1).EQ.0) THEN
13266 ir=0
13267 il=2
13268 ELSEIF(isn(2).EQ.0) THEN
13269 ir=1
13270 il=0
13271 ELSEIF(vint(143).GT.0.2d0.AND.vint(144).GT.0.2d0) THEN
13272 ir=1
13273 il=2
13274 ELSEIF(vint(143).GT.0.2d0) THEN
13275 ir=1
13276 il=0
13277 ELSEIF(vint(144).GT.0.2d0) THEN
13278 ir=0
13279 il=2
13280 ELSEIF(pms(1)/psys(1,4)**2.GT.pms(2)/psys(2,4)**2) THEN
13281 ir=1
13282 il=0
13283 ELSE
13284 ir=0
13285 il=2
13286 ENDIF
13287 ig=3-ir-il
13288
13289C...E+-pL wanted for system to be modified.
13290 IF((ig.EQ.1.AND.isn(1).EQ.0).OR.(ig.EQ.2.AND.isn(2).EQ.0)) THEN
13291 ppb=vint(1)
13292 pnb=vint(1)
13293 ELSE
13294 ppb=vint(1)-(psys(ig,4)+psys(ig,3))
13295 pnb=vint(1)-(psys(ig,4)-psys(ig,3))
13296 ENDIF
13297
13298C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
13299 IF(idisxq.EQ.1.AND.ig.NE.0) THEN
13300 pmtb=ppb*pnb
13301 pmtr=pms(ir)
13302 pmtl=pms(il)
13303 sqlam=sqrt(max(0d0,(pmtb-pmtr-pmtl)**2-4d0*pmtr*pmtl))
13304 sqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
13305 rkr=(pmtb+pmtr-pmtl+sqlam*sqsgn)/(2d0*(psys(ir,4)+psys(ir,3))
13306 & *pnb)
13307 rkl=(pmtb+pmtl-pmtr+sqlam*sqsgn)/(2d0*(psys(il,4)-psys(il,3))
13308 & *ppb)
13309 ber=(rkr**2-1d0)/(rkr**2+1d0)
13310 bel=-(rkl**2-1d0)/(rkl**2+1d0)
13311 ppb=ppb-(psys(0,4)+psys(0,3))
13312 pnb=pnb-(psys(0,4)-psys(0,3))
13313 DO 420 j=1,4
13314 psys(0,j)=0d0
13315 420 CONTINUE
13316 DO 450 i=mint(84)+1,ns
13317 IF(k(i,1).GT.10) GOTO 450
13318 incl=0
13319 iorig=i
13320 430 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
13321 iorig=k(iorig,3)
13322 IF(iorig.GT.lpin) GOTO 430
13323 IF(incl.EQ.0) GOTO 450
13324 DO 440 j=1,4
13325 psys(0,j)=psys(0,j)+p(i,j)
13326 440 CONTINUE
13327 450 CONTINUE
13328 pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
13329 ppb=ppb+(psys(0,4)+psys(0,3))
13330 pnb=pnb+(psys(0,4)-psys(0,3))
13331 ENDIF
13332
13333C...Construct longitudinal boosts.
13334 dpmtb=ppb*pnb
13335 dpmtr=pms(ir)
13336 dpmtl=pms(il)
13337 dsqlam=sqrt(max(0d0,(dpmtb-dpmtr-dpmtl)**2-4d0*dpmtr*dpmtl))
13338 IF(dsqlam.LE.1d-6*dpmtb) THEN
13339 mint(51)=1
13340 mint(57)=mint(57)+1
13341 RETURN
13342 ENDIF
13343 dsqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
13344 drkr=(dpmtb+dpmtr-dpmtl+dsqlam*dsqsgn)/
13345 &(2d0*(psys(ir,4)+psys(ir,3))*pnb)
13346 drkl=(dpmtb+dpmtl-dpmtr+dsqlam*dsqsgn)/
13347 &(2d0*(psys(il,4)-psys(il,3))*ppb)
13348 dber=(drkr**2-1d0)/(drkr**2+1d0)
13349 dbel=-(drkl**2-1d0)/(drkl**2+1d0)
13350
13351C...Perform longitudinal boosts.
13352 IF(ir.EQ.1.AND.isn(1).EQ.1.AND.dber.LE.-0.99999999d0) THEN
13353 p(is(1),3)=0d0
13354 p(is(1),4)=sqrt(p(is(1),5)**2+p(is(1),1)**2+p(is(1),2)**2)
13355 ELSEIF(ir.EQ.1) THEN
13356 CALL pyrobo(is(1),is(1)+isn(1)-1,0d0,0d0,0d0,0d0,dber)
13357 ELSEIF(idisxq.EQ.1) THEN
13358 DO 470 i=i1,ns
13359 incl=0
13360 iorig=i
13361 460 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
13362 iorig=k(iorig,3)
13363 IF(iorig.GT.lpin) GOTO 460
13364 IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dber)
13365 470 CONTINUE
13366 ELSE
13367 CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dber)
13368 ENDIF
13369 IF(il.EQ.2.AND.isn(2).EQ.1.AND.dbel.GE.0.99999999d0) THEN
13370 p(is(2),3)=0d0
13371 p(is(2),4)=sqrt(p(is(2),5)**2+p(is(2),1)**2+p(is(2),2)**2)
13372 ELSEIF(il.EQ.2) THEN
13373 CALL pyrobo(is(2),is(2)+isn(2)-1,0d0,0d0,0d0,0d0,dbel)
13374 ELSEIF(idisxq.EQ.1) THEN
13375 DO 490 i=i1,ns
13376 incl=0
13377 iorig=i
13378 480 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
13379 iorig=k(iorig,3)
13380 IF(iorig.GT.lpin) GOTO 480
13381 IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dbel)
13382 490 CONTINUE
13383 ELSE
13384 CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dbel)
13385 ENDIF
13386
13387C...Final check that energy-momentum conservation worked.
13388 pesum=0d0
13389 pzsum=0d0
13390 DO 500 i=mint(84)+1,n
13391 IF(k(i,1).GT.10) GOTO 500
13392 pesum=pesum+p(i,4)
13393 pzsum=pzsum+p(i,3)
13394 500 CONTINUE
13395 pdev=abs(pesum-vint(1))+abs(pzsum)
13396 IF(pdev.GT.1d-4*vint(1)) THEN
13397 mint(51)=1
13398 mint(57)=mint(57)+1
13399 RETURN
13400 ENDIF
13401
13402C...Calculate rotation and boost from overall CM frame to
13403C...hadronic CM frame in leptoproduction.
13404 mint(91)=0
13405 IF(mint(82).EQ.1.AND.(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
13406 mint(91)=1
13407 lesd=1
13408 IF(mint(42).EQ.1) lesd=2
13409 lpin=mint(83)+3-lesd
13410
13411C...Sum upp momenta of everything not lepton or photon to define boost.
13412 DO 510 j=1,4
13413 psum(j)=0d0
13414 510 CONTINUE
13415 DO 530 i=1,n
13416 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 530
13417 IF(iabs(k(i,2)).GE.11.AND.iabs(k(i,2)).LE.20) GOTO 530
13418 IF(k(i,2).EQ.22) GOTO 530
13419 DO 520 j=1,4
13420 psum(j)=psum(j)+p(i,j)
13421 520 CONTINUE
13422 530 CONTINUE
13423 vint(223)=-psum(1)/psum(4)
13424 vint(224)=-psum(2)/psum(4)
13425 vint(225)=-psum(3)/psum(4)
13426
13427C...Boost incoming hadron to hadronic CM frame to determine rotations.
13428 k(n+1,1)=1
13429 DO 540 j=1,5
13430 p(n+1,j)=p(lpin,j)
13431 v(n+1,j)=v(lpin,j)
13432 540 CONTINUE
13433 CALL pyrobo(n+1,n+1,0d0,0d0,vint(223),vint(224),vint(225))
13434 vint(222)=-pyangl(p(n+1,1),p(n+1,2))
13435 CALL pyrobo(n+1,n+1,0d0,vint(222),0d0,0d0,0d0)
13436 IF(lesd.EQ.2) THEN
13437 vint(221)=-pyangl(p(n+1,3),p(n+1,1))
13438 ELSE
13439 vint(221)=pyangl(-p(n+1,3),p(n+1,1))
13440 ENDIF
13441 ENDIF
13442
13443 RETURN
13444 END
13445
13446C*********************************************************************
13447
13448C...PYDIFF
13449C...Handles diffractive and elastic scattering.
13450
13451 SUBROUTINE pydiff
13452
13453C...Double precision and integer declarations.
13454 IMPLICIT DOUBLE PRECISION(a-h, o-z)
13455 IMPLICIT INTEGER(I-N)
13456 INTEGER PYK,PYCHGE,PYCOMP
13457C...Commonblocks.
13458 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13459 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13460 common/pypars/mstp(200),parp(200),msti(200),pari(200)
13461 common/pyint1/mint(400),vint(400)
13462 SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
13463
13464C...Reset K, P and V vectors. Store incoming particles.
13465 DO 110 jt=1,mstp(126)+10
13466 i=mint(83)+jt
13467 DO 100 j=1,5
13468 k(i,j)=0
13469 p(i,j)=0d0
13470 v(i,j)=0d0
13471 100 CONTINUE
13472 110 CONTINUE
13473 n=mint(84)
13474 mint(3)=0
13475 mint(21)=0
13476 mint(22)=0
13477 mint(23)=0
13478 mint(24)=0
13479 mint(4)=4
13480 DO 130 jt=1,2
13481 i=mint(83)+jt
13482 k(i,1)=21
13483 k(i,2)=mint(10+jt)
13484 DO 120 j=1,5
13485 p(i,j)=vint(285+5*jt+j)
13486 120 CONTINUE
13487 130 CONTINUE
13488 mint(6)=2
13489
13490C...Subprocess; kinematics.
13491 sqlam=(vint(2)-vint(63)-vint(64))**2-4d0*vint(63)*vint(64)
13492 pz=sqrt(sqlam)/(2d0*vint(1))
13493 DO 200 jt=1,2
13494 i=mint(83)+jt
13495 pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2d0*vint(1))
13496 kfh=mint(102+jt)
13497
13498C...Elastically scattered particle. (Except elastic GVMD states.)
13499 IF(mint(16+jt).LE.0.AND.(mint(10+jt).NE.22.OR.
13500 & mint(106+jt).NE.3)) THEN
13501 n=n+1
13502 k(n,1)=1
13503 k(n,2)=kfh
13504 k(n,3)=i+2
13505 p(n,3)=pz*(-1)**(jt+1)
13506 p(n,4)=pe
13507 p(n,5)=sqrt(vint(62+jt))
13508
13509C...Decay rho from elastic scattering of gamma with sin**2(theta)
13510C...distribution of decay products (in rho rest frame).
13511 IF(kfh.EQ.113.AND.mint(10+jt).EQ.22.AND.mstp(102).EQ.1) THEN
13512 nsav=n
13513 dbetaz=p(n,3)/sqrt(p(n,3)**2+p(n,5)**2)
13514 p(n,3)=0d0
13515 p(n,4)=p(n,5)
13516 CALL pydecy(nsav)
13517 IF(n.EQ.nsav+2.AND.iabs(k(nsav+1,2)).EQ.211) THEN
13518 phi=pyangl(p(nsav+1,1),p(nsav+1,2))
13519 CALL pyrobo(nsav+1,nsav+2,0d0,-phi,0d0,0d0,0d0)
13520 the=pyangl(p(nsav+1,3),p(nsav+1,1))
13521 CALL pyrobo(nsav+1,nsav+2,-the,0d0,0d0,0d0,0d0)
13522 140 cthe=2d0*pyr(0)-1d0
13523 IF(1d0-cthe**2.LT.pyr(0)) GOTO 140
13524 CALL pyrobo(nsav+1,nsav+2,acos(cthe),phi,0d0,0d0,0d0)
13525 ENDIF
13526 CALL pyrobo(nsav,nsav+2,0d0,0d0,0d0,0d0,dbetaz)
13527 ENDIF
13528
13529C...Diffracted particle: low-mass system to two particles.
13530 ELSEIF(vint(62+jt).LT.(vint(66+jt)+parp(103))**2) THEN
13531 n=n+2
13532 k(n-1,1)=1
13533 k(n,1)=1
13534 k(n-1,3)=i+2
13535 k(n,3)=i+2
13536 pmmas=sqrt(vint(62+jt))
13537 ntry=0
13538 150 ntry=ntry+1
13539 IF(ntry.LT.20) THEN
13540 mint(105)=mint(102+jt)
13541 mint(109)=mint(106+jt)
13542 CALL pyspli(kfh,21,kfl1,kfl2)
13543 CALL pykfdi(kfl1,0,kfl3,kf1)
13544 IF(kf1.EQ.0) GOTO 150
13545 CALL pykfdi(kfl2,-kfl3,kfldum,kf2)
13546 IF(kf2.EQ.0) GOTO 150
13547 ELSE
13548 kf1=kfh
13549 kf2=111
13550 ENDIF
13551 pm1=pymass(kf1)
13552 pm2=pymass(kf2)
13553 IF(pm1+pm2+parj(64).GT.pmmas) GOTO 150
13554 k(n-1,2)=kf1
13555 k(n,2)=kf2
13556 p(n-1,5)=pm1
13557 p(n,5)=pm2
13558 pzp=sqrt(max(0d0,(pmmas**2-pm1**2-pm2**2)**2-
13559 & 4d0*pm1**2*pm2**2))/(2d0*pmmas)
13560 p(n-1,3)=pzp
13561 p(n,3)=-pzp
13562 p(n-1,4)=sqrt(pm1**2+pzp**2)
13563 p(n,4)=sqrt(pm2**2+pzp**2)
13564 CALL pyrobo(n-1,n,acos(2d0*pyr(0)-1d0),paru(2)*pyr(0),
13565 & 0d0,0d0,0d0)
13566 dbetaz=pz*(-1)**(jt+1)/sqrt(pz**2+pmmas**2)
13567 CALL pyrobo(n-1,n,0d0,0d0,0d0,0d0,dbetaz)
13568
13569C...Diffracted particle: valence quark kicked out.
13570 ELSEIF(mstp(101).EQ.1.OR.(mstp(101).EQ.3.AND.pyr(0).LT.
13571 & parp(101))) THEN
13572 n=n+2
13573 k(n-1,1)=2
13574 k(n,1)=1
13575 k(n-1,3)=i+2
13576 k(n,3)=i+2
13577 mint(105)=mint(102+jt)
13578 mint(109)=mint(106+jt)
13579 CALL pyspli(kfh,21,k(n,2),k(n-1,2))
13580 p(n-1,5)=pymass(k(n-1,2))
13581 p(n,5)=pymass(k(n,2))
13582 sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-
13583 & 4d0*p(n-1,5)**2*p(n,5)**2
13584 p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-
13585 & p(n,5)**2))/(2d0*vint(62+jt))*(-1)**(jt+1)
13586 p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)
13587 p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)
13588 p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
13589
13590C...Diffracted particle: gluon kicked out.
13591 ELSE
13592 n=n+3
13593 k(n-2,1)=2
13594 k(n-1,1)=2
13595 k(n,1)=1
13596 k(n-2,3)=i+2
13597 k(n-1,3)=i+2
13598 k(n,3)=i+2
13599 mint(105)=mint(102+jt)
13600 mint(109)=mint(106+jt)
13601 CALL pyspli(kfh,21,k(n,2),k(n-2,2))
13602 k(n-1,2)=21
13603 p(n-2,5)=pymass(k(n-2,2))
13604 p(n-1,5)=0d0
13605 p(n,5)=pymass(k(n,2))
13606C...Energy distribution for particle into two jets.
13607 160 imb=1
13608 IF(mod(kfh/1000,10).NE.0) imb=2
13609 chik=parp(92+2*imb)
13610 IF(mstp(92).LE.1) THEN
13611 IF(imb.EQ.1) chi=pyr(0)
13612 IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
13613 ELSEIF(mstp(92).EQ.2) THEN
13614 chi=1d0-pyr(0)**(1d0/(1d0+chik))
13615 ELSEIF(mstp(92).EQ.3) THEN
13616 cut=2d0*0.3d0/vint(1)
13617 170 chi=pyr(0)**2
13618 IF((chi**2/(chi**2+cut**2))**0.25d0*(1d0-chi)**chik.LT.
13619 & pyr(0)) GOTO 170
13620 ELSEIF(mstp(92).EQ.4) THEN
13621 cut=2d0*0.3d0/vint(1)
13622 cutr=(1d0+sqrt(1d0+cut**2))/cut
13623 180 chir=cut*cutr**pyr(0)
13624 chi=(chir**2-cut**2)/(2d0*chir)
13625 IF((1d0-chi)**chik.LT.pyr(0)) GOTO 180
13626 ELSE
13627 cut=2d0*0.3d0/vint(1)
13628 cuta=cut**(1d0-parp(98))
13629 cutb=(1d0+cut)**(1d0-parp(98))
13630 190 chi=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
13631 IF(((chi+cut)**2/(2d0*(chi**2+cut**2)))**
13632 & (0.5d0*parp(98))*(1d0-chi)**chik.LT.pyr(0)) GOTO 190
13633 ENDIF
13634 IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1d0-p(n-2,5)**2/
13635 & vint(62+jt)) GOTO 160
13636 sqm=p(n-2,5)**2/(1d0-chi)+p(n,5)**2/chi
13637 pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/
13638 & (2d0*vint(62+jt))
13639 pei=sqrt(pzi**2+sqm)
13640 pqqp=(1d0-chi)*(pei+pzi)
13641 p(n-2,3)=0.5d0*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)
13642 p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)
13643 p(n-1,4)=0.5d0*(vint(62+jt)-sqm)/(pei+pzi)
13644 p(n-1,3)=p(n-1,4)*(-1)**jt
13645 p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)
13646 p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
13647 ENDIF
13648
13649C...Documentation lines.
13650 k(i+2,1)=21
13651 IF(mint(16+jt).EQ.0) k(i+2,2)=kfh
13652 IF(mint(16+jt).NE.0.OR.(mint(10+jt).EQ.22.AND.
13653 & mint(106+jt).EQ.3)) k(i+2,2)=10*(kfh/10)
13654 k(i+2,3)=i
13655 p(i+2,3)=pz*(-1)**(jt+1)
13656 p(i+2,4)=pe
13657 p(i+2,5)=sqrt(vint(62+jt))
13658 200 CONTINUE
13659
13660C...Rotate outgoing partons/particles using cos(theta).
13661 IF(vint(23).LT.0.9d0) THEN
13662 CALL pyrobo(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)
13663 ELSE
13664 CALL pyrobo(mint(83)+3,n,asin(vint(59)),vint(24),0d0,0d0,0d0)
13665 ENDIF
13666
13667 RETURN
13668 END
13669
13670C*********************************************************************
13671
13672C...PYDISG
13673C...Set up a DIS process as gamma* + f -> f, with beam remnant
13674C...and showering added consecutively. Photon flux by the PYGAGA
13675C...routine (if at all).
13676
13677 SUBROUTINE pydisg
13678
13679C...Double precision and integer declarations.
13680 IMPLICIT DOUBLE PRECISION(a-h, o-z)
13681 IMPLICIT INTEGER(I-N)
13682 INTEGER PYK,PYCHGE,PYCOMP
13683C...Parameter statement to help give large particle numbers.
13684 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
13685C...Commonblocks.
13686 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13687 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13688 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13689 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
13690 common/pypars/mstp(200),parp(200),msti(200),pari(200)
13691 common/pyint1/mint(400),vint(400)
13692 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
13693C...Local arrays.
13694 dimension pms(4)
13695
13696C...Choice of subprocess, number of documentation lines
13697 idoc=7
13698 mint(3)=idoc-6
13699 mint(4)=idoc
13700 ipu1=mint(84)+1
13701 ipu2=mint(84)+2
13702 ipu3=mint(84)+3
13703 iside=1
13704 IF(mint(107).EQ.4) iside=2
13705
13706C...Reset K, P and V vectors. Store incoming particles
13707 DO 120 jt=1,mstp(126)+20
13708 i=mint(83)+jt
13709 DO 110 j=1,5
13710 k(i,j)=0
13711 p(i,j)=0d0
13712 v(i,j)=0d0
13713 110 CONTINUE
13714 120 CONTINUE
13715 DO 140 jt=1,2
13716 i=mint(83)+jt
13717 k(i,1)=21
13718 k(i,2)=mint(10+jt)
13719 DO 130 j=1,5
13720 p(i,j)=vint(285+5*jt+j)
13721 130 CONTINUE
13722 140 CONTINUE
13723 mint(6)=2
13724
13725C...Store incoming partons in hadronic CM-frame
13726 DO 150 jt=1,2
13727 i=mint(84)+jt
13728 k(i,1)=14
13729 k(i,2)=mint(14+jt)
13730 k(i,3)=mint(83)+2+jt
13731 150 CONTINUE
13732 IF(mint(15).EQ.22) THEN
13733 p(mint(84)+1,3)=0.5d0*(vint(1)+vint(307)/vint(1))
13734 p(mint(84)+1,4)=0.5d0*(vint(1)-vint(307)/vint(1))
13735 p(mint(84)+1,5)=-sqrt(vint(307))
13736 p(mint(84)+2,3)=-0.5d0*vint(307)/vint(1)
13737 p(mint(84)+2,4)=0.5d0*vint(307)/vint(1)
13738 kfres=mint(16)
13739 iside=2
13740 ELSE
13741 p(mint(84)+1,3)=0.5d0*vint(308)/vint(1)
13742 p(mint(84)+1,4)=0.5d0*vint(308)/vint(1)
13743 p(mint(84)+2,3)=-0.5d0*(vint(1)+vint(308)/vint(1))
13744 p(mint(84)+2,4)=0.5d0*(vint(1)-vint(308)/vint(1))
13745 p(mint(84)+1,5)=-sqrt(vint(308))
13746 kfres=mint(15)
13747 iside=1
13748 ENDIF
13749 sidesg=(-1d0)**(iside-1)
13750
13751C...Copy incoming partons to documentation lines.
13752 DO 170 jt=1,2
13753 i1=mint(83)+4+jt
13754 i2=mint(84)+jt
13755 k(i1,1)=21
13756 k(i1,2)=k(i2,2)
13757 k(i1,3)=i1-2
13758 DO 160 j=1,5
13759 p(i1,j)=p(i2,j)
13760 160 CONTINUE
13761
13762C...Second copy for partons before ISR shower, since no such.
13763 i1=mint(83)+2+jt
13764 k(i1,1)=21
13765 k(i1,2)=k(i2,2)
13766 k(i1,3)=i1-2
13767 DO 165 j=1,5
13768 p(i1,j)=p(i2,j)
13769 165 CONTINUE
13770 170 CONTINUE
13771
13772C...Define initial partons.
13773 ntry=0
13774 200 ntry=ntry+1
13775 IF(ntry.GT.100) THEN
13776 mint(51)=1
13777 RETURN
13778 ENDIF
13779
13780C...Scattered quark in hadronic CM frame.
13781 i=mint(83)+7
13782 k(ipu3,1)=3
13783 k(ipu3,2)=kfres
13784 k(ipu3,3)=i
13785 p(ipu3,5)=pymass(kfres)
13786 p(ipu3,3)=p(ipu1,3)+p(ipu2,3)
13787 p(ipu3,4)=p(ipu1,4)+p(ipu2,4)
13788 p(ipu3,5)=0d0
13789 k(i,1)=21
13790 k(i,2)=kfres
13791 k(i,3)=mint(83)+4+iside
13792 p(i,3)=p(ipu3,3)
13793 p(i,4)=p(ipu3,4)
13794 p(i,5)=p(ipu3,5)
13795 n=ipu3
13796 mint(21)=kfres
13797 mint(22)=0
13798
13799C...No primordial kT, or chosen according to truncated Gaussian or
13800C...exponential, or (for photon) predetermined or power law.
13801 220 IF(mint(40+iside).EQ.2.AND.mint(10+iside).NE.22) THEN
13802 IF(mstp(91).LE.0) THEN
13803 pt=0d0
13804 ELSEIF(mstp(91).EQ.1) THEN
13805 pt=parp(91)*sqrt(-log(pyr(0)))
13806 ELSE
13807 rpt1=pyr(0)
13808 rpt2=pyr(0)
13809 pt=-parp(92)*log(rpt1*rpt2)
13810 ENDIF
13811 IF(pt.GT.parp(93)) GOTO 220
13812 ELSEIF(mint(106+iside).EQ.3) THEN
13813 pta=sqrt(vint(282+iside))
13814 ptb=0d0
13815 IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
13816 ptb=parp(99)*sqrt(-log(pyr(0)))
13817 ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
13818 rpt1=pyr(0)
13819 rpt2=pyr(0)
13820 ptb=-parp(99)*log(rpt1*rpt2)
13821 ENDIF
13822 IF(ptb.GT.parp(100)) GOTO 220
13823 pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
13824 IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
13825 ELSEIF(iabs(mint(14+iside)).LE.8.OR.mint(14+iside).EQ.21) THEN
13826 IF(mstp(93).LE.0) THEN
13827 pt=0d0
13828 ELSEIF(mstp(93).EQ.1) THEN
13829 pt=parp(99)*sqrt(-log(pyr(0)))
13830 ELSEIF(mstp(93).EQ.2) THEN
13831 rpt1=pyr(0)
13832 rpt2=pyr(0)
13833 pt=-parp(99)*log(rpt1*rpt2)
13834 ELSEIF(mstp(93).EQ.3) THEN
13835 ha=parp(99)**2
13836 hb=parp(100)**2
13837 pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
13838 ELSE
13839 ha=parp(99)**2
13840 hb=parp(100)**2
13841 IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
13842 pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
13843 ENDIF
13844 IF(pt.GT.parp(100)) GOTO 220
13845 ELSE
13846 pt=0d0
13847 ENDIF
13848 vint(156+iside)=pt
13849 phi=paru(2)*pyr(0)
13850 p(ipu3,1)=pt*cos(phi)
13851 p(ipu3,2)=pt*sin(phi)
13852 p(ipu3,4)=sqrt(p(ipu3,5)**2+pt**2+p(ipu3,3)**2)
13853 pms(3-iside)=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
13854 pcp=p(ipu3,4)+abs(p(ipu3,3))
13855
13856C...Find one or two beam remnants.
13857 mint(105)=mint(102+iside)
13858 mint(109)=mint(106+iside)
13859 CALL pyspli(mint(10+iside),mint(12+iside),kflch,kflsp)
13860 IF(mint(51).NE.0) THEN
13861 mint(51)=0
13862 GOTO 200
13863 ENDIF
13864
13865C...Store first remnant parton, with colour info and kinematics.
13866 i=n+1
13867 k(i,1)=1
13868 k(i,2)=kflsp
13869 k(i,3)=mint(83)+iside
13870 p(i,5)=pymass(k(i,2))
13871 kcol=kchg(pycomp(kflsp),2)
13872 IF(kcol.NE.0) THEN
13873 k(i,1)=3
13874 kfls=(3-kcol*isign(1,kflsp))/2
13875 k(i,kfls+3)=mstu(5)*ipu3
13876 k(ipu3,6-kfls)=mstu(5)*i
13877 icolr=i
13878 ENDIF
13879 IF(kflch.EQ.0) THEN
13880 p(i,1)=-p(ipu3,1)
13881 p(i,2)=-p(ipu3,2)
13882 pms(iside)=p(i,5)**2+p(i,1)**2+p(i,2)**2
13883 p(i,3)=-p(ipu3,3)
13884 p(i,4)=sqrt(pms(iside)+p(i,3)**2)
13885 prp=p(i,4)+abs(p(i,3))
13886
13887C...When extra remnant parton or hadron: store extra remnant.
13888 ELSE
13889 i=i+1
13890 k(i,1)=1
13891 k(i,2)=kflch
13892 k(i,3)=mint(83)+iside
13893 p(i,5)=pymass(k(i,2))
13894 kcol=kchg(pycomp(kflch),2)
13895 IF(kcol.NE.0) THEN
13896 k(i,1)=3
13897 kfls=(3-kcol*isign(1,kflch))/2
13898 k(i,kfls+3)=mstu(5)*ipu3
13899 k(ipu3,6-kfls)=mstu(5)*i
13900 icolr=i
13901 ENDIF
13902
13903C...Relative transverse momentum when two remnants.
13904 loop=0
13905 370 loop=loop+1
13906 CALL pyptdi(1,p(i-1,1),p(i-1,2))
13907 p(i-1,1)=p(i-1,1)-0.5d0*p(ipu3,1)
13908 p(i-1,2)=p(i-1,2)-0.5d0*p(ipu3,2)
13909 pms(3)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
13910 p(i,1)=-p(ipu3,1)-p(i-1,1)
13911 p(i,2)=-p(ipu3,2)-p(i-1,2)
13912 pms(4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
13913
13914C...Relative distribution of energy for particle into jet plus particle.
13915 imb=1
13916 IF(mod(mint(10+iside)/1000,10).NE.0) imb=2
13917 IF(mstp(94).LE.1) THEN
13918 IF(imb.EQ.1) chi=pyr(0)
13919 IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
13920 IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
13921 ELSEIF(mstp(94).EQ.2) THEN
13922 chi=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
13923 IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
13924 ELSEIF(mstp(94).EQ.3) THEN
13925 CALL pyzdis(1,0,pms(4),zz)
13926 chi=zz
13927 ELSE
13928 CALL pyzdis(1000,0,pms(4),zz)
13929 chi=zz
13930 ENDIF
13931
13932C...Construct total transverse mass; reject if too large.
13933 chi=max(1d-8,min(1d0-1d-8,chi))
13934 pms(iside)=pms(4)/chi+pms(3)/(1d0-chi)
13935 IF(pms(iside).GT.p(ipu3,4)**2) THEN
13936 IF(loop.LT.10) GOTO 370
13937 GOTO 200
13938 ENDIF
13939 vint(158+iside)=chi
13940
13941C...Subdivide longitudinal momentum according to value selected above.
13942 prp=sqrt(pms(iside)+p(ipu3,3)**2)+abs(p(ipu3,3))
13943 pw1=(1d0-chi)*prp
13944 p(i-1,4)=0.5d0*(pw1+pms(3)/pw1)
13945 p(i-1,3)=0.5d0*(pw1-pms(3)/pw1)*sidesg
13946 pw2=chi*prp
13947 p(i,4)=0.5d0*(pw2+pms(4)/pw2)
13948 p(i,3)=0.5d0*(pw2-pms(4)/pw2)*sidesg
13949 ENDIF
13950 n=i
13951
13952C...Boost current and remnant systems to correct frame.
13953 IF(sqrt(pms(1))+sqrt(pms(2)).GT.0.99d0*vint(1)) GOTO 200
13954 dsqlam=sqrt(max(0d0,(vint(2)-pms(1)-pms(2))**2-4d0*pms(1)*pms(2)))
13955 drkc=(vint(2)+pms(3-iside)-pms(iside)+dsqlam)/
13956 &(2d0*vint(1)*pcp)
13957 drkr=(vint(2)+pms(iside)-pms(3-iside)+dsqlam)/
13958 &(2d0*vint(1)*prp)
13959 dbec=-sidesg*(drkc**2-1d0)/(drkc**2+1d0)
13960 dber=sidesg*(drkr**2-1d0)/(drkr**2+1d0)
13961 CALL pyrobo(ipu3,ipu3,0d0,0d0,0d0,0d0,dbec)
13962 CALL pyrobo(ipu3+1,n,0d0,0d0,0d0,0d0,dber)
13963
13964C...Let current quark shower; recoil but no showering by colour partner.
13965 qmax=2d0*sqrt(vint(309-iside))
13966 mstj48=mstj(48)
13967 mstj(48)=1
13968 parj86=parj(86)
13969 parj(86)=0d0
13970 IF(mstp(71).EQ.1) CALL pyshow(ipu3,icolr,qmax)
13971 mstj(48)=mstj48
13972 parj(86)=parj86
13973
13974 RETURN
13975 END
13976
13977C*********************************************************************
13978
13979C...PYDOCU
13980C...Handles the documentation of the process in MSTI and PARI,
13981C...and also computes cross-sections based on accumulated statistics.
13982
13983 SUBROUTINE pydocu
13984
13985C...Double precision and integer declarations.
13986 IMPLICIT DOUBLE PRECISION(a-h, o-z)
13987 IMPLICIT INTEGER(I-N)
13988 INTEGER PYK,PYCHGE,PYCOMP
13989C...Commonblocks.
13990 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13991 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13992 common/pypars/mstp(200),parp(200),msti(200),pari(200)
13993 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
13994 common/pyint1/mint(400),vint(400)
13995 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13996 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
13997 SAVE /pyjets/,/pydat1/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
13998 &/pyint5/
13999
14000C...Calculate Monte Carlo estimates of cross-sections.
14001 isub=mint(1)
14002 IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1
14003 ngen(0,3)=ngen(0,3)+1
14004 xsec(0,3)=0d0
14005 DO 100 i=1,500
14006 IF(i.EQ.96.OR.i.EQ.97) THEN
14007 xsec(i,3)=0d0
14008 ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.
14009 & i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN
14010 xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
14011 & dble(ngen(96,2)))
14012 ELSEIF(msub(i).EQ.0.OR.ngen(i,1).EQ.0) THEN
14013 xsec(i,3)=0d0
14014 ELSEIF(ngen(i,2).EQ.0) THEN
14015 xsec(i,3)=xsec(i,2)*ngen(0,3)/(dble(ngen(i,1))*
14016 & dble(ngen(0,2)))
14017 ELSE
14018 xsec(i,3)=xsec(i,2)*ngen(i,3)/(dble(ngen(i,1))*
14019 & dble(ngen(i,2)))
14020 ENDIF
14021 xsec(0,3)=xsec(0,3)+xsec(i,3)
14022 100 CONTINUE
14023
14024C...Rescale to known low-pT cross-section for standard QCD processes.
14025 IF(msub(95).EQ.1) THEN
14026 xsech=xsec(11,3)+xsec(12,3)+xsec(13,3)+xsec(28,3)+xsec(53,3)+
14027 & xsec(68,3)+xsec(95,3)
14028 xsecw=xsec(97,2)/max(1d0,dble(ngen(97,1)))
14029 IF(xsech.GT.1d-20.AND.xsecw.GT.1d-20) THEN
14030 fac=xsecw/xsech
14031 xsec(11,3)=fac*xsec(11,3)
14032 xsec(12,3)=fac*xsec(12,3)
14033 xsec(13,3)=fac*xsec(13,3)
14034 xsec(28,3)=fac*xsec(28,3)
14035 xsec(53,3)=fac*xsec(53,3)
14036 xsec(68,3)=fac*xsec(68,3)
14037 xsec(95,3)=fac*xsec(95,3)
14038 xsec(0,3)=xsec(0,3)-xsech+xsecw
14039 ENDIF
14040 ENDIF
14041
14042C...Save information for gamma-p and gamma-gamma.
14043 IF(mint(121).GT.1) THEN
14044 iga=mint(122)
14045 CALL pysave(2,iga)
14046 CALL pysave(5,0)
14047 ENDIF
14048
14049C...Reset information on hard interaction.
14050 DO 110 j=1,200
14051 msti(j)=0
14052 pari(j)=0d0
14053 110 CONTINUE
14054
14055C...Copy integer valued information from MINT into MSTI.
14056 DO 120 j=1,32
14057 msti(j)=mint(j)
14058 120 CONTINUE
14059 IF(mint(121).GT.1) msti(9)=mint(122)
14060
14061C...Store cross-section variables in PARI.
14062 pari(1)=xsec(0,3)
14063 pari(2)=xsec(0,3)/mint(5)
14064 pari(9)=vint(99)
14065 pari(10)=vint(100)
14066 vint(98)=vint(98)+vint(100)
14067 IF(mstp(142).EQ.1) pari(2)=xsec(0,3)/vint(98)
14068
14069C...Store kinematics variables in PARI.
14070 pari(11)=vint(1)
14071 pari(12)=vint(2)
14072 IF(isub.NE.95) THEN
14073 DO 130 j=13,26
14074 pari(j)=vint(30+j)
14075 130 CONTINUE
14076 pari(31)=vint(141)
14077 pari(32)=vint(142)
14078 pari(33)=vint(41)
14079 pari(34)=vint(42)
14080 pari(35)=pari(33)-pari(34)
14081 pari(36)=vint(21)
14082 pari(37)=vint(22)
14083 pari(38)=vint(26)
14084 pari(39)=vint(157)
14085 pari(40)=vint(158)
14086 pari(41)=vint(23)
14087 pari(42)=2d0*vint(47)/vint(1)
14088 ENDIF
14089
14090C...Store information on scattered partons in PARI.
14091 IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN
14092 DO 140 is=7,8
14093 i=mint(is)
14094 pari(36+is)=p(i,3)/vint(1)
14095 pari(38+is)=p(i,4)/vint(1)
14096 pr=max(1d-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)
14097 pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
14098 & sqrt(pr),1d20)),p(i,3))
14099 pr=max(1d-20,p(i,1)**2+p(i,2)**2)
14100 pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
14101 & sqrt(pr),1d20)),p(i,3))
14102 pari(44+is)=p(i,3)/sqrt(1d-20+p(i,1)**2+p(i,2)**2+p(i,3)**2)
14103 pari(46+is)=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
14104 pari(48+is)=pyangl(p(i,1),p(i,2))
14105 140 CONTINUE
14106 ENDIF
14107
14108C...Store sum up transverse and longitudinal momenta.
14109 pari(65)=2d0*pari(17)
14110 IF(isub.LE.90.OR.isub.GE.95) THEN
14111 DO 150 i=mstp(126)+1,n
14112 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150
14113 pt=sqrt(p(i,1)**2+p(i,2)**2)
14114 pari(69)=pari(69)+pt
14115 IF(i.LE.mint(52)) pari(66)=pari(66)+pt
14116 IF(i.GT.mint(52).AND.i.LE.mint(53)) pari(68)=pari(68)+pt
14117 150 CONTINUE
14118 pari(67)=pari(68)
14119 pari(71)=vint(151)
14120 pari(72)=vint(152)
14121 pari(73)=vint(151)
14122 pari(74)=vint(152)
14123 ELSE
14124 pari(66)=pari(65)
14125 pari(69)=pari(65)
14126 ENDIF
14127
14128C...Store various other pieces of information into PARI.
14129 pari(61)=vint(148)
14130 pari(75)=vint(155)
14131 pari(76)=vint(156)
14132 pari(77)=vint(159)
14133 pari(78)=vint(160)
14134 pari(81)=vint(138)
14135
14136C...Store information on lepton -> lepton + gamma in PYGAGA.
14137 msti(71)=mint(141)
14138 msti(72)=mint(142)
14139 pari(101)=vint(301)
14140 pari(102)=vint(302)
14141 DO 160 i=103,114
14142 pari(i)=vint(i+202)
14143 160 CONTINUE
14144
14145C...Set information for PYTABU.
14146 IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
14147 mstu(161)=mint(21)
14148 mstu(162)=0
14149 ELSEIF(iset(isub).EQ.5) THEN
14150 mstu(161)=mint(23)
14151 mstu(162)=0
14152 ELSE
14153 mstu(161)=mint(21)
14154 mstu(162)=mint(22)
14155 ENDIF
14156
14157 RETURN
14158 END
14159
14160C*********************************************************************
14161
14162C...PYFRAM
14163C...Performs transformations between different coordinate frames.
14164
14165 SUBROUTINE pyfram(IFRAME)
14166
14167C...Double precision and integer declarations.
14168 IMPLICIT DOUBLE PRECISION(a-h, o-z)
14169 IMPLICIT INTEGER(I-N)
14170 INTEGER PYK,PYCHGE,PYCOMP
14171C...Commonblocks.
14172 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14173 common/pypars/mstp(200),parp(200),msti(200),pari(200)
14174 common/pyint1/mint(400),vint(400)
14175 SAVE /pydat1/,/pypars/,/pyint1/
14176
14177C...Check that transformation can and should be done.
14178 IF(iframe.EQ.1.OR.iframe.EQ.2.OR.(iframe.EQ.3.AND.
14179 &mint(91).EQ.1)) THEN
14180 IF(iframe.EQ.mint(6)) RETURN
14181 ELSE
14182 WRITE(mstu(11),5000) iframe,mint(6)
14183 RETURN
14184 ENDIF
14185
14186 IF(mint(6).EQ.1) THEN
14187C...Transform from fixed target or user specified frame to
14188C...overall CM frame.
14189 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
14190 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
14191 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
14192 ELSEIF(mint(6).EQ.3) THEN
14193C...Transform from hadronic CM frame in DIS to overall CM frame.
14194 CALL pyrobo(0,0,-vint(221),-vint(222),-vint(223),-vint(224),
14195 & -vint(225))
14196 ENDIF
14197
14198 IF(iframe.EQ.1) THEN
14199C...Transform from overall CM frame to fixed target or user specified
14200C...frame.
14201 CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))
14202 ELSEIF(iframe.EQ.3) THEN
14203C...Transform from overall CM frame to hadronic CM frame in DIS.
14204 CALL pyrobo(0,0,0d0,0d0,vint(223),vint(224),vint(225))
14205 CALL pyrobo(0,0,0d0,vint(222),0d0,0d0,0d0)
14206 CALL pyrobo(0,0,vint(221),0d0,0d0,0d0,0d0)
14207 ENDIF
14208
14209C...Set information about new frame.
14210 mint(6)=iframe
14211 msti(6)=iframe
14212
14213 5000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,
14214 &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',
14215 &1x,i5)
14216
14217 RETURN
14218 END
14219
14220C*********************************************************************
14221
14222C...PYWIDT
14223C...Calculates full and partial widths of resonances.
14224
14225 SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)
14226
14227C...Double precision and integer declarations.
14228 IMPLICIT DOUBLE PRECISION(a-h, o-z)
14229 IMPLICIT INTEGER(I-N)
14230 INTEGER PYK,PYCHGE,PYCOMP
14231C...Parameter statement to help give large particle numbers.
14232 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
14233C...Commonblocks.
14234 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14235 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14236 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
14237 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
14238 common/pypars/mstp(200),parp(200),msti(200),pari(200)
14239 common/pyint1/mint(400),vint(400)
14240 common/pyint4/mwid(500),wids(500,5)
14241 common/pymssm/imss(0:99),rmss(0:99)
14242 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
14243 &sfmix(16,4)
14244 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
14245 &/pyint4/,/pymssm/,/pyssmt/
14246C...Local arrays and saved variables.
14247 dimension wdtp(0:200),wdte(0:200,0:5),mofsv(3,2),widwsv(3,2),
14248 &wid2sv(3,2),wdtpp(0:200),wdtep(0:200,0:5)
14249 SAVE mofsv,widwsv,wid2sv
14250 DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
14251
14252C...Compressed code and sign; mass.
14253 kfla=iabs(kflr)
14254 kfls=isign(1,kflr)
14255 kc=pycomp(kfla)
14256 shr=sqrt(sh)
14257 pmr=pmas(kc,1)
14258
14259C...Reset width information.
14260 DO 110 i=0,200
14261 wdtp(i)=0d0
14262 DO 100 j=0,5
14263 wdte(i,j)=0d0
14264 100 CONTINUE
14265 110 CONTINUE
14266
14267C...Not to be treated as a resonance: return.
14268 IF((mwid(kc).LE.0.OR.mwid(kc).GE.4).AND.kfla.NE.21.AND.
14269 &kfla.NE.22) THEN
14270 wdtp(0)=1d0
14271 wdte(0,0)=1d0
14272 mint(61)=0
14273 mint(62)=0
14274 mint(63)=0
14275 RETURN
14276
14277C...Treatment as a resonance based on tabulated branching ratios.
14278 ELSEIF(mwid(kc).EQ.2.OR.(mwid(kc).EQ.3.AND.mint(63).EQ.0)) THEN
14279C...Loop over possible decay channels; skip irrelevant ones.
14280 DO 120 i=1,mdcy(kc,3)
14281 idc=i+mdcy(kc,2)-1
14282 IF(mdme(idc,1).LT.0) GOTO 120
14283
14284C...Read out decay products and nominal masses.
14285 kfd1=kfdp(idc,1)
14286 kfc1=pycomp(kfd1)
14287 IF(kchg(kfc1,3).EQ.1) kfd1=kfls*kfd1
14288 pm1=pmas(kfc1,1)
14289 kfd2=kfdp(idc,2)
14290 kfc2=pycomp(kfd2)
14291 IF(kchg(kfc2,3).EQ.1) kfd2=kfls*kfd2
14292 pm2=pmas(kfc2,1)
14293 kfd3=kfdp(idc,3)
14294 pm3=0d0
14295 IF(kfd3.NE.0) THEN
14296 kfc3=pycomp(kfd3)
14297 IF(kchg(kfc3,3).EQ.1) kfd3=kfls*kfd3
14298 pm3=pmas(kfc3,1)
14299 ENDIF
14300
14301C...Naive partial width and alternative threshold factors.
14302 wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)
14303 IF(mdme(idc,2).GE.51.AND.mdme(idc,2).LE.53.AND.
14304 & pm1+pm2+pm3.GE.shr) THEN
14305 wdtp(i)=0d0
14306 ELSEIF(mdme(idc,2).EQ.52.AND.kfd3.EQ.0) THEN
14307 wdtp(i)=wdtp(i)*sqrt(max(0d0,(sh-pm1**2-pm2**2)**2-
14308 & 4d0*pm1**2*pm2**2))/sh
14309 ELSEIF(mdme(idc,2).EQ.52) THEN
14310 pma=max(pm1,pm2,pm3)
14311 pmc=min(pm1,pm2,pm3)
14312 pmb=pm1+pm2+pm3-pma-pmc
14313 pmbc=pmb+pmc+0.5d0*(shr-pma-pmc-pmc)
14314 pman=pma**2/sh
14315 pmbn=pmb**2/sh
14316 pmcn=pmc**2/sh
14317 pmbcn=pmbc**2/sh
14318 wdtp(i)=wdtp(i)*sqrt(max(0d0,
14319 & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
14320 & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
14321 & ((shr-pma)**2-(pmb+pmc)**2)*
14322 & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
14323 & ((1d0-pmbcn)*pmbcn*sh)
14324 ELSEIF(mdme(idc,2).EQ.53.AND.kfd3.EQ.0) THEN
14325 wdtp(i)=wdtp(i)*sqrt(
14326 & max(0d0,(sh-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2)/
14327 & max(1d-4,(pmr**2-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2))
14328 ELSEIF(mdme(idc,2).EQ.53) THEN
14329 pma=max(pm1,pm2,pm3)
14330 pmc=min(pm1,pm2,pm3)
14331 pmb=pm1+pm2+pm3-pma-pmc
14332 pmbc=pmb+pmc+0.5d0*(shr-pma-pmb-pmc)
14333 pman=pma**2/sh
14334 pmbn=pmb**2/sh
14335 pmcn=pmc**2/sh
14336 pmbcn=pmbc**2/sh
14337 facact=sqrt(max(0d0,
14338 & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
14339 & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
14340 & ((shr-pma)**2-(pmb+pmc)**2)*
14341 & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
14342 & ((1d0-pmbcn)*pmbcn*sh)
14343 pmbc=pmb+pmc+0.5d0*(pmr-pma-pmb-pmc)
14344 pman=pma**2/pmr**2
14345 pmbn=pmb**2/pmr**2
14346 pmcn=pmc**2/pmr**2
14347 pmbcn=pmbc**2/pmr**2
14348 facnom=sqrt(max(0d0,
14349 & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
14350 & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
14351 & ((pmr-pma)**2-(pmb+pmc)**2)*
14352 & (1d0+0.25d0*(pma+pmb+pmc)/pmr)/
14353 & ((1d0-pmbcn)*pmbcn*pmr**2)
14354 wdtp(i)=wdtp(i)*facact/max(1d-6,facnom)
14355 ENDIF
14356 wdtp(0)=wdtp(0)+wdtp(i)
14357
14358C...Calculate secondary width (at most two identical/opposite).
14359 wid2=1d0
14360 IF(mdme(idc,1).GT.0) THEN
14361 IF(kfd2.EQ.kfd1) THEN
14362 IF(kchg(kfc1,3).EQ.0) THEN
14363 wid2=wids(kfc1,1)
14364 ELSEIF(kfd1.GT.0) THEN
14365 wid2=wids(kfc1,4)
14366 ELSE
14367 wid2=wids(kfc1,5)
14368 ENDIF
14369 IF(kfd3.GT.0) THEN
14370 wid2=wid2*wids(kfc3,2)
14371 ELSEIF(kfd3.LT.0) THEN
14372 wid2=wid2*wids(kfc3,3)
14373 ENDIF
14374 ELSEIF(kfd2.EQ.-kfd1) THEN
14375 wid2=wids(kfc1,1)
14376 IF(kfd3.GT.0) THEN
14377 wid2=wid2*wids(kfc3,2)
14378 ELSEIF(kfd3.LT.0) THEN
14379 wid2=wid2*wids(kfc3,3)
14380 ENDIF
14381 ELSEIF(kfd3.EQ.kfd1) THEN
14382 IF(kchg(kfc1,3).EQ.0) THEN
14383 wid2=wids(kfc1,1)
14384 ELSEIF(kfd1.GT.0) THEN
14385 wid2=wids(kfc1,4)
14386 ELSE
14387 wid2=wids(kfc1,5)
14388 ENDIF
14389 IF(kfd2.GT.0) THEN
14390 wid2=wid2*wids(kfc2,2)
14391 ELSEIF(kfd2.LT.0) THEN
14392 wid2=wid2*wids(kfc2,3)
14393 ENDIF
14394 ELSEIF(kfd3.EQ.-kfd1) THEN
14395 wid2=wids(kfc1,1)
14396 IF(kfd2.GT.0) THEN
14397 wid2=wid2*wids(kfc2,2)
14398 ELSEIF(kfd2.LT.0) THEN
14399 wid2=wid2*wids(kfc2,3)
14400 ENDIF
14401 ELSEIF(kfd3.EQ.kfd2) THEN
14402 IF(kchg(kfc2,3).EQ.0) THEN
14403 wid2=wids(kfc2,1)
14404 ELSEIF(kfd2.GT.0) THEN
14405 wid2=wids(kfc2,4)
14406 ELSE
14407 wid2=wids(kfc2,5)
14408 ENDIF
14409 IF(kfd1.GT.0) THEN
14410 wid2=wid2*wids(kfc1,2)
14411 ELSEIF(kfd1.LT.0) THEN
14412 wid2=wid2*wids(kfc1,3)
14413 ENDIF
14414 ELSEIF(kfd3.EQ.-kfd2) THEN
14415 wid2=wids(kfc2,1)
14416 IF(kfd1.GT.0) THEN
14417 wid2=wid2*wids(kfc1,2)
14418 ELSEIF(kfd1.LT.0) THEN
14419 wid2=wid2*wids(kfc1,3)
14420 ENDIF
14421 ELSE
14422 IF(kfd1.GT.0) THEN
14423 wid2=wids(kfc1,2)
14424 ELSE
14425 wid2=wids(kfc1,3)
14426 ENDIF
14427 IF(kfd2.GT.0) THEN
14428 wid2=wid2*wids(kfc2,2)
14429 ELSE
14430 wid2=wid2*wids(kfc2,3)
14431 ENDIF
14432 IF(kfd3.GT.0) THEN
14433 wid2=wid2*wids(kfc3,2)
14434 ELSEIF(kfd3.LT.0) THEN
14435 wid2=wid2*wids(kfc3,3)
14436 ENDIF
14437 ENDIF
14438
14439C...Store effective widths according to case.
14440 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14441 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14442 wdte(i,0)=wdte(i,mdme(idc,1))
14443 wdte(0,0)=wdte(0,0)+wdte(i,0)
14444 ENDIF
14445 120 CONTINUE
14446C...Return.
14447 mint(61)=0
14448 mint(62)=0
14449 mint(63)=0
14450 RETURN
14451 ENDIF
14452
14453C...Here begins detailed dynamical calculation of resonance widths.
14454C...Shared treatment of Higgs states.
14455 kfhigg=25
14456 ihigg=1
14457 IF(kfla.EQ.35.OR.kfla.EQ.36) THEN
14458 kfhigg=kfla
14459 ihigg=kfla-33
14460 ENDIF
14461
14462C...Common electroweak and strong constants.
14463 xw=paru(102)
14464 xwv=xw
14465 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
14466 xw1=1d0-xw
14467 aem=pyalem(sh)
14468 IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
14469 as=pyalps(sh)
14470 radc=1d0+as/paru(1)
14471
14472 IF(kfla.EQ.6) THEN
14473C...t quark.
14474 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
14475 radct=1d0-2.5d0*as/paru(1)
14476 DO 130 i=1,mdcy(kc,3)
14477 idc=i+mdcy(kc,2)-1
14478 IF(mdme(idc,1).LT.0) GOTO 130
14479 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
14480 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
14481 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 130
14482 wid2=1d0
14483 IF(i.GE.4.AND.i.LE.7) THEN
14484C...t -> W + q; including approximate QCD correction factor.
14485 wdtp(i)=fac*vckm(3,i-3)*radct*
14486 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14487 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
14488 IF(kflr.GT.0) THEN
14489 wid2=wids(24,2)
14490 IF(i.EQ.7) wid2=wid2*wids(7,2)
14491 ELSE
14492 wid2=wids(24,3)
14493 IF(i.EQ.7) wid2=wid2*wids(7,3)
14494 ENDIF
14495 ELSEIF(i.EQ.9) THEN
14496C...t -> H + b.
14497 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14498 & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
14499 wid2=wids(37,2)
14500 IF(kflr.LT.0) wid2=wids(37,3)
14501CMRENNA++
14502 ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN
14503C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
14504 beta=atan(rmss(5))
14505 sinb=sin(beta)
14506 tanw=sqrt(paru(102)/(1d0-paru(102)))
14507 et=kchg(6,1)/3d0
14508 t3l=sign(0.5d0,et)
14509 kfc1=pycomp(kfdp(idc,1))
14510 kfc2=pycomp(kfdp(idc,2))
14511 pmnchi=pmas(kfc1,1)
14512 pmstop=pmas(kfc2,1)
14513 IF(shr.GT.pmnchi+pmstop) THEN
14514 iz=i-9
14515 al=shr*zmix(iz,4)/(2.0d0*pmas(24,1)*sinb)
14516 ar=-et*zmix(iz,1)*tanw
14517 bl=t3l*(zmix(iz,2)-zmix(iz,1)*tanw)-ar
14518 br=al
14519 fl=sfmix(6,1)*al+sfmix(6,2)*ar
14520 fr=sfmix(6,1)*bl+sfmix(6,2)*br
14521 pcm=sqrt((sh-(pmnchi+pmstop)**2)*
14522 & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
14523 wdtp(i)=(0.5d0*pyalem(sh)/paru(102))*pcm*((fl**2+fr**2)*
14524 & (sh+pmnchi**2-pmstop**2)+smz(iz)*4d0*shr*fl*fr)/sh
14525 IF(kflr.GT.0) THEN
14526 wid2=wids(kfc1,2)*wids(kfc2,2)
14527 ELSE
14528 wid2=wids(kfc1,2)*wids(kfc2,3)
14529 ENDIF
14530 ENDIF
14531 ELSEIF(i.EQ.14.AND.imss(1).NE.0) THEN
14532C...t -> ~g + ~t
14533 kfc1=pycomp(kfdp(idc,1))
14534 kfc2=pycomp(kfdp(idc,2))
14535 pmnchi=pmas(kfc1,1)
14536 pmstop=pmas(kfc2,1)
14537 IF(shr.GT.pmnchi+pmstop) THEN
14538 fl=sfmix(6,1)
14539 fr=-sfmix(6,2)
14540 pcm=sqrt((sh-(pmnchi+pmstop)**2)*
14541 & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
14542 wdtp(i)=4d0/3d0*0.5d0*pyalps(sh)*pcm*((fl**2+fr**2)*
14543 & (sh+pmnchi**2-pmstop**2)+pmnchi*4d0*shr*fl*fr)/sh
14544 IF(kflr.GT.0) THEN
14545 wid2=wids(kfc1,2)*wids(kfc2,2)
14546 ELSE
14547 wid2=wids(kfc1,2)*wids(kfc2,3)
14548 ENDIF
14549 ENDIF
14550 ELSEIF(i.EQ.15.AND.imss(1).NE.0) THEN
14551C...t -> ~gravitino + ~t
14552 xmp2=rmss(29)**2
14553 kfc1=pycomp(kfdp(idc,1))
14554 xmgr2=pmas(kfc1,1)**2
14555 wdtp(i)=sh**2*shr/(96d0*paru(1)*xmp2*xmgr2)*(1d0-rm2)**4
14556 kfc2=pycomp(kfdp(idc,2))
14557 wid2=wids(kfc2,2)
14558 IF(kflr.LT.0) wid2=wids(kfc2,3)
14559CMRENNA--
14560 ENDIF
14561 wdtp(0)=wdtp(0)+wdtp(i)
14562 IF(mdme(idc,1).GT.0) THEN
14563 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14564 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14565 wdte(i,0)=wdte(i,mdme(idc,1))
14566 wdte(0,0)=wdte(0,0)+wdte(i,0)
14567 ENDIF
14568 130 CONTINUE
14569
14570 ELSEIF(kfla.EQ.7) THEN
14571C...b' quark.
14572 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
14573 DO 140 i=1,mdcy(kc,3)
14574 idc=i+mdcy(kc,2)-1
14575 IF(mdme(idc,1).LT.0) GOTO 140
14576 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
14577 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
14578 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 140
14579 wid2=1d0
14580 IF(i.GE.4.AND.i.LE.7) THEN
14581C...b' -> W + q.
14582 wdtp(i)=fac*vckm(i-3,4)*
14583 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14584 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
14585 IF(kflr.GT.0) THEN
14586 wid2=wids(24,3)
14587 IF(i.EQ.6) wid2=wid2*wids(6,2)
14588 IF(i.EQ.7) wid2=wid2*wids(8,2)
14589 ELSE
14590 wid2=wids(24,2)
14591 IF(i.EQ.6) wid2=wid2*wids(6,3)
14592 IF(i.EQ.7) wid2=wid2*wids(8,3)
14593 ENDIF
14594 wid2=wids(24,3)
14595 IF(kflr.LT.0) wid2=wids(24,2)
14596 ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
14597C...b' -> H + q.
14598 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14599 & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
14600 IF(kflr.GT.0) THEN
14601 wid2=wids(37,3)
14602 IF(i.EQ.10) wid2=wid2*wids(6,2)
14603 ELSE
14604 wid2=wids(37,2)
14605 IF(i.EQ.10) wid2=wid2*wids(6,3)
14606 ENDIF
14607 ENDIF
14608 wdtp(0)=wdtp(0)+wdtp(i)
14609 IF(mdme(idc,1).GT.0) THEN
14610 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14611 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14612 wdte(i,0)=wdte(i,mdme(idc,1))
14613 wdte(0,0)=wdte(0,0)+wdte(i,0)
14614 ENDIF
14615 140 CONTINUE
14616
14617 ELSEIF(kfla.EQ.8) THEN
14618C...t' quark.
14619 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
14620 DO 150 i=1,mdcy(kc,3)
14621 idc=i+mdcy(kc,2)-1
14622 IF(mdme(idc,1).LT.0) GOTO 150
14623 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
14624 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
14625 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 150
14626 wid2=1d0
14627 IF(i.GE.4.AND.i.LE.7) THEN
14628C...t' -> W + q.
14629 wdtp(i)=fac*vckm(4,i-3)*
14630 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14631 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
14632 IF(kflr.GT.0) THEN
14633 wid2=wids(24,2)
14634 IF(i.EQ.7) wid2=wid2*wids(7,2)
14635 ELSE
14636 wid2=wids(24,3)
14637 IF(i.EQ.7) wid2=wid2*wids(7,3)
14638 ENDIF
14639 ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
14640C...t' -> H + q.
14641 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14642 & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
14643 IF(kflr.GT.0) THEN
14644 wid2=wids(37,2)
14645 IF(i.EQ.10) wid2=wid2*wids(7,2)
14646 ELSE
14647 wid2=wids(37,3)
14648 IF(i.EQ.10) wid2=wid2*wids(7,3)
14649 ENDIF
14650 ENDIF
14651 wdtp(0)=wdtp(0)+wdtp(i)
14652 IF(mdme(idc,1).GT.0) THEN
14653 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14654 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14655 wdte(i,0)=wdte(i,mdme(idc,1))
14656 wdte(0,0)=wdte(0,0)+wdte(i,0)
14657 ENDIF
14658 150 CONTINUE
14659
14660 ELSEIF(kfla.EQ.17) THEN
14661C...tau' lepton.
14662 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
14663 DO 160 i=1,mdcy(kc,3)
14664 idc=i+mdcy(kc,2)-1
14665 IF(mdme(idc,1).LT.0) GOTO 160
14666 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
14667 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
14668 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 160
14669 wid2=1d0
14670 IF(i.EQ.3) THEN
14671C...tau' -> W + nu'_tau.
14672 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14673 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
14674 IF(kflr.GT.0) THEN
14675 wid2=wids(24,3)
14676 wid2=wid2*wids(18,2)
14677 ELSE
14678 wid2=wids(24,2)
14679 wid2=wid2*wids(18,3)
14680 ENDIF
14681 ELSEIF(i.EQ.5) THEN
14682C...tau' -> H + nu'_tau.
14683 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14684 & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
14685 IF(kflr.GT.0) THEN
14686 wid2=wids(37,3)
14687 wid2=wid2*wids(18,2)
14688 ELSE
14689 wid2=wids(37,2)
14690 wid2=wid2*wids(18,3)
14691 ENDIF
14692 ENDIF
14693 wdtp(0)=wdtp(0)+wdtp(i)
14694 IF(mdme(idc,1).GT.0) THEN
14695 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14696 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14697 wdte(i,0)=wdte(i,mdme(idc,1))
14698 wdte(0,0)=wdte(0,0)+wdte(i,0)
14699 ENDIF
14700 160 CONTINUE
14701
14702 ELSEIF(kfla.EQ.18) THEN
14703C...nu'_tau neutrino.
14704 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
14705 DO 170 i=1,mdcy(kc,3)
14706 idc=i+mdcy(kc,2)-1
14707 IF(mdme(idc,1).LT.0) GOTO 170
14708 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
14709 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
14710 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 170
14711 wid2=1d0
14712 IF(i.EQ.2) THEN
14713C...nu'_tau -> W + tau'.
14714 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14715 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
14716 IF(kflr.GT.0) THEN
14717 wid2=wids(24,2)
14718 wid2=wid2*wids(17,2)
14719 ELSE
14720 wid2=wids(24,3)
14721 wid2=wid2*wids(17,3)
14722 ENDIF
14723 ELSEIF(i.EQ.3) THEN
14724C...nu'_tau -> H + tau'.
14725 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
14726 & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
14727 IF(kflr.GT.0) THEN
14728 wid2=wids(37,2)
14729 wid2=wid2*wids(17,2)
14730 ELSE
14731 wid2=wids(37,3)
14732 wid2=wid2*wids(17,3)
14733 ENDIF
14734 ENDIF
14735 wdtp(0)=wdtp(0)+wdtp(i)
14736 IF(mdme(idc,1).GT.0) THEN
14737 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14738 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14739 wdte(i,0)=wdte(i,mdme(idc,1))
14740 wdte(0,0)=wdte(0,0)+wdte(i,0)
14741 ENDIF
14742 170 CONTINUE
14743
14744 ELSEIF(kfla.EQ.21) THEN
14745C...QCD:
14746C***Note that widths are not given in dimensional quantities here.
14747 DO 180 i=1,mdcy(kc,3)
14748 idc=i+mdcy(kc,2)-1
14749 IF(mdme(idc,1).LT.0) GOTO 180
14750 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
14751 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
14752 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 180
14753 wid2=1d0
14754 IF(i.LE.8) THEN
14755C...QCD -> q + qbar
14756 wdtp(i)=(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
14757 IF(i.EQ.6) wid2=wids(6,1)
14758 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
14759 ENDIF
14760 wdtp(0)=wdtp(0)+wdtp(i)
14761 IF(mdme(idc,1).GT.0) THEN
14762 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14763 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14764 wdte(i,0)=wdte(i,mdme(idc,1))
14765 wdte(0,0)=wdte(0,0)+wdte(i,0)
14766 ENDIF
14767 180 CONTINUE
14768
14769 ELSEIF(kfla.EQ.22) THEN
14770C...QED photon.
14771C***Note that widths are not given in dimensional quantities here.
14772 DO 190 i=1,mdcy(kc,3)
14773 idc=i+mdcy(kc,2)-1
14774 IF(mdme(idc,1).LT.0) GOTO 190
14775 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
14776 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
14777 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 190
14778 wid2=1d0
14779 IF(i.LE.8) THEN
14780C...QED -> q + qbar.
14781 ef=kchg(i,1)/3d0
14782 fcof=3d0*radc
14783 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
14784 wdtp(i)=fcof*ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
14785 IF(i.EQ.6) wid2=wids(6,1)
14786 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
14787 ELSEIF(i.LE.12) THEN
14788C...QED -> l+ + l-.
14789 ef=kchg(9+2*(i-8),1)/3d0
14790 wdtp(i)=ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
14791 IF(i.EQ.12) wid2=wids(17,1)
14792 ENDIF
14793 wdtp(0)=wdtp(0)+wdtp(i)
14794 IF(mdme(idc,1).GT.0) THEN
14795 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14796 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14797 wdte(i,0)=wdte(i,mdme(idc,1))
14798 wdte(0,0)=wdte(0,0)+wdte(i,0)
14799 ENDIF
14800 190 CONTINUE
14801
14802 ELSEIF(kfla.EQ.23) THEN
14803C...Z0:
14804 icase=1
14805 xwc=1d0/(16d0*xw*xw1)
14806 fac=(aem*xwc/3d0)*shr
14807 200 CONTINUE
14808 IF(mint(61).GE.1.AND.icase.EQ.2) THEN
14809 vint(111)=0d0
14810 vint(112)=0d0
14811 vint(114)=0d0
14812 ENDIF
14813 IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
14814 kfi=iabs(mint(15))
14815 IF(kfi.GT.20) kfi=iabs(mint(16))
14816 ei=kchg(kfi,1)/3d0
14817 ai=sign(1d0,ei)
14818 vi=ai-4d0*ei*xwv
14819 sqmz=pmas(23,1)**2
14820 hz=shr*wdtp(0)
14821 IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=1d0
14822 IF(mstp(43).EQ.3) vint(112)=
14823 & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
14824 IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
14825 & xwc**2*sh**2/((sh-sqmz)**2+hz**2)
14826 ENDIF
14827 DO 210 i=1,mdcy(kc,3)
14828 idc=i+mdcy(kc,2)-1
14829 IF(mdme(idc,1).LT.0) GOTO 210
14830 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
14831 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
14832 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 210
14833 wid2=1d0
14834 IF(i.LE.8) THEN
14835C...Z0 -> q + qbar
14836 ef=kchg(i,1)/3d0
14837 af=sign(1d0,ef+0.1d0)
14838 vf=af-4d0*ef*xwv
14839 fcof=3d0*radc
14840 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
14841 IF(i.EQ.6) wid2=wids(6,1)
14842 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
14843 ELSEIF(i.LE.16) THEN
14844C...Z0 -> l+ + l-, nu + nubar
14845 ef=kchg(i+2,1)/3d0
14846 af=sign(1d0,ef+0.1d0)
14847 vf=af-4d0*ef*xwv
14848 fcof=1d0
14849 IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
14850 ENDIF
14851 be34=sqrt(max(0d0,1d0-4d0*rm1))
14852 IF(icase.EQ.1) THEN
14853 wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
14854 & be34
14855 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
14856 wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
14857 & ef*vf+(vi**2+ai**2)*vint(114)*vf**2)*(1d0+2d0*rm1)+
14858 & (vi**2+ai**2)*vint(114)*af**2*(1d0-4d0*rm1))*be34
14859 ELSEIF(mint(61).EQ.2.AND.icase.EQ.2) THEN
14860 fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
14861 fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
14862 fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
14863 ENDIF
14864 IF(icase.EQ.1) wdtp(0)=wdtp(0)+wdtp(i)
14865 IF(mdme(idc,1).GT.0) THEN
14866 IF((icase.EQ.1.AND.mint(61).NE.1).OR.
14867 & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
14868 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14869 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
14870 & wdte(i,mdme(idc,1))
14871 wdte(i,0)=wdte(i,mdme(idc,1))
14872 wdte(0,0)=wdte(0,0)+wdte(i,0)
14873 ENDIF
14874 IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
14875 IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=
14876 & vint(111)+fggf*wid2
14877 IF(mstp(43).EQ.3) vint(112)=vint(112)+fgzf*wid2
14878 IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
14879 & vint(114)+fzzf*wid2
14880 ENDIF
14881 ENDIF
14882 210 CONTINUE
14883 IF(mint(61).GE.1) icase=3-icase
14884 IF(icase.EQ.2) GOTO 200
14885
14886 ELSEIF(kfla.EQ.24) THEN
14887C...W+/-:
14888 fac=(aem/(24d0*xw))*shr
14889 DO 220 i=1,mdcy(kc,3)
14890 idc=i+mdcy(kc,2)-1
14891 IF(mdme(idc,1).LT.0) GOTO 220
14892 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
14893 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
14894 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 220
14895 wid2=1d0
14896 IF(i.LE.16) THEN
14897C...W+/- -> q + qbar'
14898 fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
14899 IF(kflr.GT.0) THEN
14900 IF(mod(i,4).EQ.3) wid2=wids(6,2)
14901 IF(mod(i,4).EQ.0) wid2=wids(8,2)
14902 IF(i.GE.13) wid2=wid2*wids(7,3)
14903 ELSE
14904 IF(mod(i,4).EQ.3) wid2=wids(6,3)
14905 IF(mod(i,4).EQ.0) wid2=wids(8,3)
14906 IF(i.GE.13) wid2=wid2*wids(7,2)
14907 ENDIF
14908 ELSEIF(i.LE.20) THEN
14909C...W+/- -> l+/- + nu
14910 fcof=1d0
14911 IF(kflr.GT.0) THEN
14912 IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
14913 ELSE
14914 IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
14915 ENDIF
14916 ENDIF
14917 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
14918 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
14919 wdtp(0)=wdtp(0)+wdtp(i)
14920 IF(mdme(idc,1).GT.0) THEN
14921 wdte(i,mdme(idc,1))=wdtp(i)*wid2
14922 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
14923 wdte(i,0)=wdte(i,mdme(idc,1))
14924 wdte(0,0)=wdte(0,0)+wdte(i,0)
14925 ENDIF
14926 220 CONTINUE
14927
14928 ELSEIF(kfla.EQ.25.OR.kfla.EQ.35.OR.kfla.EQ.36) THEN
14929C...h0 (or H0, or A0):
14930 IF(mstp(49).EQ.0) THEN
14931 fac=(aem/(8d0*xw))*(sh/pmas(24,1)**2)*shr
14932 ELSE
14933 fac=(aem/(8d0*xw))*(pmas(kfhigg,1)/pmas(24,1))**2*shr
14934 ENDIF
14935 DO 260 i=1,mdcy(kfhigg,3)
14936 idc=i+mdcy(kfhigg,2)-1
14937 IF(mdme(idc,1).LT.0) GOTO 260
14938 kfc1=pycomp(kfdp(idc,1))
14939 kfc2=pycomp(kfdp(idc,2))
14940 rm1=pmas(kfc1,1)**2/sh
14941 rm2=pmas(kfc2,1)**2/sh
14942 IF(i.NE.16.AND.i.NE.17.AND.sqrt(rm1)+sqrt(rm2).GT.1d0)
14943 & GOTO 260
14944 wid2=1d0
14945
14946 IF(i.LE.8) THEN
14947C...h0 -> q + qbar
14948 wdtp(i)=fac*3d0*(pymrun(kfdp(idc,1),sh)**2/sh)*
14949 & sqrt(max(0d0,1d0-4d0*rm1))*radc
14950C...A0 behaves like beta, ho and H0 like beta**3.
14951 IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
14952 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
14953 IF(mod(i,2).EQ.1) wdtp(i)=wdtp(i)*paru(151+10*ihigg)**2
14954 IF(mod(i,2).EQ.0) wdtp(i)=wdtp(i)*paru(152+10*ihigg)**2
14955 ENDIF
14956 IF(i.EQ.6) wid2=wids(6,1)
14957 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
14958
14959 ELSEIF(i.LE.12) THEN
14960C...h0 -> l+ + l-
14961 wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))
14962C...A0 behaves like beta, ho and H0 like beta**3.
14963 IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
14964 IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
14965 & paru(153+10*ihigg)**2
14966 IF(i.EQ.12) wid2=wids(17,1)
14967
14968 ELSEIF(i.EQ.13) THEN
14969C...h0 -> g + g; quark loop contribution only
14970 etare=0d0
14971 etaim=0d0
14972 DO 230 j=1,2*mstp(1)
14973 eps=(2d0*pmas(j,1))**2/sh
14974C...Loop integral; function of eps=4m^2/shat; different for A0.
14975 IF(eps.LE.1d0) THEN
14976 IF(eps.GT.1d-4) THEN
14977 root=sqrt(1d0-eps)
14978 rln=log((1d0+root)/(1d0-root))
14979 ELSE
14980 rln=log(4d0/eps-2d0)
14981 ENDIF
14982 phire=-0.25d0*(rln**2-paru(1)**2)
14983 phiim=0.5d0*paru(1)*rln
14984 ELSE
14985 phire=(asin(1d0/sqrt(eps)))**2
14986 phiim=0d0
14987 ENDIF
14988 IF(ihigg.LE.2) THEN
14989 etarej=-0.5d0*eps*(1d0+(1d0-eps)*phire)
14990 etaimj=-0.5d0*eps*(1d0-eps)*phiim
14991 ELSE
14992 etarej=-0.5d0*eps*phire
14993 etaimj=-0.5d0*eps*phiim
14994 ENDIF
14995C...Couplings (=1 for standard model Higgs).
14996 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
14997 IF(mod(j,2).EQ.1) THEN
14998 etarej=etarej*paru(151+10*ihigg)
14999 etaimj=etaimj*paru(151+10*ihigg)
15000 ELSE
15001 etarej=etarej*paru(152+10*ihigg)
15002 etaimj=etaimj*paru(152+10*ihigg)
15003 ENDIF
15004 ENDIF
15005 etare=etare+etarej
15006 etaim=etaim+etaimj
15007 230 CONTINUE
15008 eta2=etare**2+etaim**2
15009 wdtp(i)=fac*(as/paru(1))**2*eta2
15010
15011 ELSEIF(i.EQ.14) THEN
15012C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
15013 etare=0d0
15014 etaim=0d0
15015 jmax=3*mstp(1)+1
15016 IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
15017 DO 240 j=1,jmax
15018 IF(j.LE.2*mstp(1)) THEN
15019 ej=kchg(j,1)/3d0
15020 eps=(2d0*pmas(j,1))**2/sh
15021 ELSEIF(j.LE.3*mstp(1)) THEN
15022 jl=2*(j-2*mstp(1))-1
15023 ej=kchg(10+jl,1)/3d0
15024 eps=(2d0*pmas(10+jl,1))**2/sh
15025 ELSEIF(j.EQ.3*mstp(1)+1) THEN
15026 eps=(2d0*pmas(24,1))**2/sh
15027 ELSE
15028 eps=(2d0*pmas(37,1))**2/sh
15029 ENDIF
15030C...Loop integral; function of eps=4m^2/shat.
15031 IF(eps.LE.1d0) THEN
15032 IF(eps.GT.1d-4) THEN
15033 root=sqrt(1d0-eps)
15034 rln=log((1d0+root)/(1d0-root))
15035 ELSE
15036 rln=log(4d0/eps-2d0)
15037 ENDIF
15038 phire=-0.25d0*(rln**2-paru(1)**2)
15039 phiim=0.5d0*paru(1)*rln
15040 ELSE
15041 phire=(asin(1d0/sqrt(eps)))**2
15042 phiim=0d0
15043 ENDIF
15044 IF(j.LE.3*mstp(1)) THEN
15045C...Fermion loops: loop integral different for A0; charges.
15046 IF(ihigg.LE.2) THEN
15047 phipre=-0.5d0*eps*(1d0+(1d0-eps)*phire)
15048 phipim=-0.5d0*eps*(1d0-eps)*phiim
15049 ELSE
15050 phipre=-0.5d0*eps*phire
15051 phipim=-0.5d0*eps*phiim
15052 ENDIF
15053 IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
15054 ejc=3d0*ej**2
15055 ejh=paru(151+10*ihigg)
15056 ELSEIF(j.LE.2*mstp(1)) THEN
15057 ejc=3d0*ej**2
15058 ejh=paru(152+10*ihigg)
15059 ELSE
15060 ejc=ej**2
15061 ejh=paru(153+10*ihigg)
15062 ENDIF
15063 IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
15064 etarej=ejc*ejh*phipre
15065 etaimj=ejc*ejh*phipim
15066 ELSEIF(j.EQ.3*mstp(1)+1) THEN
15067C...W loops: loop integral and charges.
15068 etarej=0.5d0+0.75d0*eps*(1d0+(2d0-eps)*phire)
15069 etaimj=0.75d0*eps*(2d0-eps)*phiim
15070 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
15071 etarej=etarej*paru(155+10*ihigg)
15072 etaimj=etaimj*paru(155+10*ihigg)
15073 ENDIF
15074 ELSE
15075C...Charged H loops: loop integral and charges.
15076 fachhh=(pmas(24,1)/pmas(37,1))**2*
15077 & paru(158+10*ihigg+2*(ihigg/3))
15078 etarej=eps*(1d0-eps*phire)*fachhh
15079 etaimj=-eps**2*phiim*fachhh
15080 ENDIF
15081 etare=etare+etarej
15082 etaim=etaim+etaimj
15083 240 CONTINUE
15084 eta2=etare**2+etaim**2
15085 wdtp(i)=fac*(aem/paru(1))**2*0.5d0*eta2
15086
15087 ELSEIF(i.EQ.15) THEN
15088C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
15089 etare=0d0
15090 etaim=0d0
15091 jmax=3*mstp(1)+1
15092 IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
15093 DO 250 j=1,jmax
15094 IF(j.LE.2*mstp(1)) THEN
15095 ej=kchg(j,1)/3d0
15096 aj=sign(1d0,ej+0.1d0)
15097 vj=aj-4d0*ej*xwv
15098 eps=(2d0*pmas(j,1))**2/sh
15099 epsp=(2d0*pmas(j,1)/pmas(23,1))**2
15100 ELSEIF(j.LE.3*mstp(1)) THEN
15101 jl=2*(j-2*mstp(1))-1
15102 ej=kchg(10+jl,1)/3d0
15103 aj=sign(1d0,ej+0.1d0)
15104 vj=aj-4d0*ej*xwv
15105 eps=(2d0*pmas(10+jl,1))**2/sh
15106 epsp=(2d0*pmas(10+jl,1)/pmas(23,1))**2
15107 ELSE
15108 eps=(2d0*pmas(24,1))**2/sh
15109 epsp=(2d0*pmas(24,1)/pmas(23,1))**2
15110 ENDIF
15111C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
15112 IF(eps.LE.1d0) THEN
15113 root=sqrt(1d0-eps)
15114 IF(eps.GT.1d-4) THEN
15115 rln=log((1d0+root)/(1d0-root))
15116 ELSE
15117 rln=log(4d0/eps-2d0)
15118 ENDIF
15119 phire=-0.25d0*(rln**2-paru(1)**2)
15120 phiim=0.5d0*paru(1)*rln
15121 psire=0.5d0*root*rln
15122 psiim=-0.5d0*root*paru(1)
15123 ELSE
15124 phire=(asin(1d0/sqrt(eps)))**2
15125 phiim=0d0
15126 psire=sqrt(eps-1d0)*asin(1d0/sqrt(eps))
15127 psiim=0d0
15128 ENDIF
15129 IF(epsp.LE.1d0) THEN
15130 root=sqrt(1d0-epsp)
15131 IF(epsp.GT.1d-4) THEN
15132 rln=log((1d0+root)/(1d0-root))
15133 ELSE
15134 rln=log(4d0/epsp-2d0)
15135 ENDIF
15136 phirep=-0.25d0*(rln**2-paru(1)**2)
15137 phiimp=0.5d0*paru(1)*rln
15138 psirep=0.5d0*root*rln
15139 psiimp=-0.5d0*root*paru(1)
15140 ELSE
15141 phirep=(asin(1d0/sqrt(epsp)))**2
15142 phiimp=0d0
15143 psirep=sqrt(epsp-1d0)*asin(1d0/sqrt(epsp))
15144 psiimp=0d0
15145 ENDIF
15146 fxyre=eps*epsp/(8d0*(eps-epsp))*(1d0+eps*epsp/(eps-epsp)*
15147 & (phire-phirep)+2d0*eps/(eps-epsp)*(psire-psirep))
15148 fxyim=eps**2*epsp/(8d0*(eps-epsp)**2)*
15149 & (epsp*(phiim-phiimp)+2d0*(psiim-psiimp))
15150 f1re=-eps*epsp/(2d0*(eps-epsp))*(phire-phirep)
15151 f1im=-eps*epsp/(2d0*(eps-epsp))*(phiim-phiimp)
15152 IF(j.LE.3*mstp(1)) THEN
15153C...Fermion loops: loop integral different for A0; charges.
15154 IF(ihigg.EQ.3) fxyre=0d0
15155 IF(ihigg.EQ.3) fxyim=0d0
15156 IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
15157 ejc=-3d0*ej*vj
15158 ejh=paru(151+10*ihigg)
15159 ELSEIF(j.LE.2*mstp(1)) THEN
15160 ejc=-3d0*ej*vj
15161 ejh=paru(152+10*ihigg)
15162 ELSE
15163 ejc=-ej*vj
15164 ejh=paru(153+10*ihigg)
15165 ENDIF
15166 IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
15167 etarej=ejc*ejh*(fxyre-0.25d0*f1re)
15168 etaimj=ejc*ejh*(fxyim-0.25d0*f1im)
15169 ELSEIF(j.EQ.3*mstp(1)+1) THEN
15170C...W loops: loop integral and charges.
15171 heps=(1d0+2d0/eps)*xw/xw1-(5d0+2d0/eps)
15172 etarej=-xw1*((3d0-xw/xw1)*f1re+heps*fxyre)
15173 etaimj=-xw1*((3d0-xw/xw1)*f1im+heps*fxyim)
15174 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
15175 etarej=etarej*paru(155+10*ihigg)
15176 etaimj=etaimj*paru(155+10*ihigg)
15177 ENDIF
15178 ELSE
15179C...Charged H loops: loop integral and charges.
15180 fachhh=(pmas(24,1)/pmas(37,1))**2*(1d0-2d0*xw)*
15181 & paru(158+10*ihigg+2*(ihigg/3))
15182 etarej=fachhh*fxyre
15183 etaimj=fachhh*fxyim
15184 ENDIF
15185 etare=etare+etarej
15186 etaim=etaim+etaimj
15187 250 CONTINUE
15188 eta2=(etare**2+etaim**2)/(xw*xw1)
15189 wdtp(i)=fac*(aem/paru(1))**2*(1d0-pmas(23,1)**2/sh)**3*eta2
15190 wid2=wids(23,2)
15191
15192 ELSEIF(i.LE.17) THEN
15193C...h0 -> Z0 + Z0, W+ + W-
15194 pm1=pmas(iabs(kfdp(idc,1)),1)
15195 pg1=pmas(iabs(kfdp(idc,1)),2)
15196 IF(mint(62).GE.1) THEN
15197 IF(mstp(42).EQ.0.OR.(4d0*(pm1+10d0*pg1)**2.LT.sh.AND.
15198 & ckin(46).LT.ckin(45).AND.ckin(48).LT.ckin(47).AND.
15199 & max(ckin(45),ckin(47)).LT.pm1-10d0*pg1)) THEN
15200 mofsv(ihigg,i-15)=0
15201 widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
15202 & 1d0-4d0*rm1))
15203 wid2=1d0
15204 ELSE
15205 mofsv(ihigg,i-15)=1
15206 rmas=sqrt(max(0d0,sh))
15207 CALL pyofsh(1,kfla,kfdp(idc,1),kfdp(idc,2),rmas,widw,
15208 & wid2)
15209 widwsv(ihigg,i-15)=widw
15210 wid2sv(ihigg,i-15)=wid2
15211 ENDIF
15212 ELSE
15213 IF(mofsv(ihigg,i-15).EQ.0) THEN
15214 widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
15215 & 1d0-4d0*rm1))
15216 wid2=1d0
15217 ELSE
15218 widw=widwsv(ihigg,i-15)
15219 wid2=wid2sv(ihigg,i-15)
15220 ENDIF
15221 ENDIF
15222 wdtp(i)=fac*widw/(2d0*(18-i))
15223 IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
15224 & paru(138+i+10*ihigg)**2
15225 wid2=wid2*wids(7+i,1)
15226
15227 ELSEIF(i.EQ.18.AND.kfla.EQ.35) THEN
15228C***H0 -> Z0 + h0 (not yet implemented).
15229
15230 ELSEIF(i.EQ.19.AND.kfla.EQ.35) THEN
15231C...H0 -> h0 + h0.
15232 wdtp(i)=fac*paru(176)**2*0.25d0*pmas(23,1)**4/sh**2*
15233 & sqrt(max(0d0,1d0-4d0*rm1))
15234 wid2=wids(25,2)**2
15235
15236 ELSEIF(i.EQ.20.AND.kfla.EQ.35) THEN
15237C...H0 -> A0 + A0.
15238 wdtp(i)=fac*paru(177)**2*0.25d0*pmas(23,1)**4/sh**2*
15239 & sqrt(max(0d0,1d0-4d0*rm1))
15240 wid2=wids(36,2)**2
15241
15242 ELSEIF(i.EQ.18.AND.kfla.EQ.36) THEN
15243C...A0 -> Z0 + h0.
15244 wdtp(i)=fac*paru(186)**2*0.5d0*sqrt(max(0d0,
15245 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15246 wid2=wids(23,2)*wids(25,2)
15247
15248CMRENNA++
15249 ELSE
15250C...Add in SUSY decays (two-body) by rescaling by phase space factor.
15251 rm10=rm1*sh/pmr**2
15252 rm20=rm2*sh/pmr**2
15253 wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
15254 wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
15255 IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
15256 wfac=0d0
15257 ELSE
15258 wfac=wfac/wfac0
15259 ENDIF
15260 wdtp(i)=pmas(kfla,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
15261CMRENNA--
15262 IF(kfc2.EQ.kfc1) THEN
15263 wid2=wids(kfc1,1)
15264 ELSE
15265 ksgn1=2
15266 IF(kfdp(idc,1).LT.0) ksgn1=3
15267 ksgn2=2
15268 IF(kfdp(idc,2).LT.0) ksgn2=3
15269 wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
15270 ENDIF
15271 ENDIF
15272 wdtp(0)=wdtp(0)+wdtp(i)
15273 IF(mdme(idc,1).GT.0) THEN
15274 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15275 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15276 wdte(i,0)=wdte(i,mdme(idc,1))
15277 wdte(0,0)=wdte(0,0)+wdte(i,0)
15278 ENDIF
15279 260 CONTINUE
15280
15281 ELSEIF(kfla.EQ.32) THEN
15282C...Z'0:
15283 icase=1
15284 xwc=1d0/(16d0*xw*xw1)
15285 fac=(aem*xwc/3d0)*shr
15286 vint(117)=0d0
15287 270 CONTINUE
15288 IF(mint(61).GE.1.AND.icase.EQ.2) THEN
15289 vint(111)=0d0
15290 vint(112)=0d0
15291 vint(113)=0d0
15292 vint(114)=0d0
15293 vint(115)=0d0
15294 vint(116)=0d0
15295 ENDIF
15296 IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
15297 kfai=iabs(mint(15))
15298 ei=kchg(kfai,1)/3d0
15299 ai=sign(1d0,ei+0.1d0)
15300 vi=ai-4d0*ei*xwv
15301 kfaic=1
15302 IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
15303 IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
15304 IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
15305 IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
15306 vpi=paru(119+2*kfaic)
15307 api=paru(120+2*kfaic)
15308 ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
15309 vpi=parj(178+2*kfaic)
15310 api=parj(179+2*kfaic)
15311 ELSE
15312 vpi=parj(186+2*kfaic)
15313 api=parj(187+2*kfaic)
15314 ENDIF
15315 sqmz=pmas(23,1)**2
15316 hz=shr*vint(117)
15317 sqmzp=pmas(32,1)**2
15318 hzp=shr*wdtp(0)
15319 IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
15320 & mstp(44).EQ.7) vint(111)=1d0
15321 IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=
15322 & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
15323 IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=
15324 & 2d0*xwc*sh*(sh-sqmzp)/((sh-sqmzp)**2+hzp**2)
15325 IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
15326 & mstp(44).EQ.7) vint(114)=xwc**2*sh**2/((sh-sqmz)**2+hz**2)
15327 IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=
15328 & 2d0*xwc**2*sh**2*((sh-sqmz)*(sh-sqmzp)+hz*hzp)/
15329 & (((sh-sqmz)**2+hz**2)*((sh-sqmzp)**2+hzp**2))
15330 IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
15331 & mstp(44).EQ.7) vint(116)=xwc**2*sh**2/((sh-sqmzp)**2+hzp**2)
15332 ENDIF
15333 DO 280 i=1,mdcy(kc,3)
15334 idc=i+mdcy(kc,2)-1
15335 IF(mdme(idc,1).LT.0) GOTO 280
15336 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15337 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15338 IF(sqrt(rm1)+sqrt(rm2).GT.1d0.OR.mdme(idc,1).LT.0) GOTO 280
15339 wid2=1d0
15340 IF(i.LE.16) THEN
15341 IF(i.LE.8) THEN
15342C...Z'0 -> q + qbar
15343 ef=kchg(i,1)/3d0
15344 af=sign(1d0,ef+0.1d0)
15345 vf=af-4d0*ef*xwv
15346 IF(i.LE.2) THEN
15347 vpf=paru(123-2*mod(i,2))
15348 apf=paru(124-2*mod(i,2))
15349 ELSEIF(i.LE.4) THEN
15350 vpf=parj(182-2*mod(i,2))
15351 apf=parj(183-2*mod(i,2))
15352 ELSE
15353 vpf=parj(190-2*mod(i,2))
15354 apf=parj(191-2*mod(i,2))
15355 ENDIF
15356 fcof=3d0*radc
15357 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
15358 & pyhfth(sh,sh*rm1,1d0)
15359 IF(i.EQ.6) wid2=wids(6,1)
15360 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
15361 ELSEIF(i.LE.16) THEN
15362C...Z'0 -> l+ + l-, nu + nubar
15363 ef=kchg(i+2,1)/3d0
15364 af=sign(1d0,ef+0.1d0)
15365 vf=af-4d0*ef*xwv
15366 IF(i.LE.10) THEN
15367 vpf=paru(127-2*mod(i,2))
15368 apf=paru(128-2*mod(i,2))
15369 ELSEIF(i.LE.12) THEN
15370 vpf=parj(186-2*mod(i,2))
15371 apf=parj(187-2*mod(i,2))
15372 ELSE
15373 vpf=parj(194-2*mod(i,2))
15374 apf=parj(195-2*mod(i,2))
15375 ENDIF
15376 fcof=1d0
15377 IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
15378 ENDIF
15379 be34=sqrt(max(0d0,1d0-4d0*rm1))
15380 IF(icase.EQ.1) THEN
15381 wdtpz=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
15382 wdtp(i)=fac*fcof*(vpf**2*(1d0+2d0*rm1)+
15383 & apf**2*(1d0-4d0*rm1))*be34
15384 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
15385 wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
15386 & ef*vf+ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
15387 & vf**2+(vi*vpi+ai*api)*vint(115)*vf*vpf+(vpi**2+api**2)*
15388 & vint(116)*vpf**2)*(1d0+2d0*rm1)+((vi**2+ai**2)*vint(114)*
15389 & af**2+(vi*vpi+ai*api)*vint(115)*af*apf+(vpi**2+api**2)*
15390 & vint(116)*apf**2)*(1d0-4d0*rm1))*be34
15391 ELSEIF(mint(61).EQ.2) THEN
15392 fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
15393 fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
15394 fgzpf=fcof*ef*vpf*(1d0+2d0*rm1)*be34
15395 fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
15396 fzzpf=fcof*(vf*vpf*(1d0+2d0*rm1)+af*apf*(1d0-4d0*rm1))*
15397 & be34
15398 fzpzpf=fcof*(vpf**2*(1d0+2d0*rm1)+apf**2*(1d0-4d0*rm1))*
15399 & be34
15400 ENDIF
15401 ELSEIF(i.EQ.17) THEN
15402C...Z'0 -> W+ + W-
15403 wdtpzp=paru(129)**2*xw1**2*
15404 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
15405 & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
15406 IF(icase.EQ.1) THEN
15407 wdtpz=0d0
15408 wdtp(i)=fac*wdtpzp
15409 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
15410 wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
15411 ELSEIF(mint(61).EQ.2) THEN
15412 fggf=0d0
15413 fgzf=0d0
15414 fgzpf=0d0
15415 fzzf=0d0
15416 fzzpf=0d0
15417 fzpzpf=wdtpzp
15418 ENDIF
15419 wid2=wids(24,1)
15420 ELSEIF(i.EQ.18) THEN
15421C...Z'0 -> H+ + H-
15422 czc=2d0*(1d0-2d0*xw)
15423 be34c=(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
15424 IF(icase.EQ.1) THEN
15425 wdtpz=0.25d0*paru(142)**2*czc**2*be34c
15426 wdtp(i)=fac*0.25d0*paru(143)**2*czc**2*be34c
15427 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
15428 wdtp(i)=fac*0.25d0*(ei**2*vint(111)+paru(142)*ei*vi*
15429 & vint(112)*czc+paru(143)*ei*vpi*vint(113)*czc+paru(142)**2*
15430 & (vi**2+ai**2)*vint(114)*czc**2+paru(142)*paru(143)*
15431 & (vi*vpi+ai*api)*vint(115)*czc**2+paru(143)**2*
15432 & (vpi**2+api**2)*vint(116)*czc**2)*be34c
15433 ELSEIF(mint(61).EQ.2) THEN
15434 fggf=0.25d0*be34c
15435 fgzf=0.25d0*paru(142)*czc*be34c
15436 fgzpf=0.25d0*paru(143)*czc*be34c
15437 fzzf=0.25d0*paru(142)**2*czc**2*be34c
15438 fzzpf=0.25d0*paru(142)*paru(143)*czc**2*be34c
15439 fzpzpf=0.25d0*paru(143)**2*czc**2*be34c
15440 ENDIF
15441 wid2=wids(37,1)
15442 ELSEIF(i.EQ.19) THEN
15443C...Z'0 -> Z0 + gamma.
15444 ELSEIF(i.EQ.20) THEN
15445C...Z'0 -> Z0 + h0
15446 flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15447 wdtpzp=paru(145)**2*4d0*abs(1d0-2d0*xw)*
15448 & (3d0*rm1+0.25d0*flam**2)*flam
15449 IF(icase.EQ.1) THEN
15450 wdtpz=0d0
15451 wdtp(i)=fac*wdtpzp
15452 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
15453 wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
15454 ELSEIF(mint(61).EQ.2) THEN
15455 fggf=0d0
15456 fgzf=0d0
15457 fgzpf=0d0
15458 fzzf=0d0
15459 fzzpf=0d0
15460 fzpzpf=wdtpzp
15461 ENDIF
15462 wid2=wids(23,2)*wids(25,2)
15463 ELSEIF(i.EQ.21.OR.i.EQ.22) THEN
15464C...Z' -> h0 + A0 or H0 + A0.
15465 be34c=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15466 IF(i.EQ.21) THEN
15467 czah=paru(186)
15468 czpah=paru(188)
15469 ELSE
15470 czah=paru(187)
15471 czpah=paru(189)
15472 ENDIF
15473 IF(icase.EQ.1) THEN
15474 wdtpz=czah**2*be34c
15475 wdtp(i)=fac*czpah**2*be34c
15476 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
15477 wdtp(i)=fac*(czah**2*(vi**2+ai**2)*vint(114)+czah*czpah*
15478 & (vi*vpi+ai*api)*vint(115)+czpah**2*(vpi**2+api**2)*
15479 & vint(116))*be34c
15480 ELSEIF(mint(61).EQ.2) THEN
15481 fggf=0d0
15482 fgzf=0d0
15483 fgzpf=0d0
15484 fzzf=czah**2*be34c
15485 fzzpf=czah*czpah*be34c
15486 fzpzpf=czpah**2*be34c
15487 ENDIF
15488 IF(i.EQ.21) wid2=wids(25,2)*wids(36,2)
15489 IF(i.EQ.22) wid2=wids(35,2)*wids(36,2)
15490 ENDIF
15491 IF(icase.EQ.1) THEN
15492 vint(117)=vint(117)+fac*wdtpz
15493 wdtp(0)=wdtp(0)+wdtp(i)
15494 ENDIF
15495 IF(mdme(idc,1).GT.0) THEN
15496 IF((icase.EQ.1.AND.mint(61).NE.1).OR.
15497 & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
15498 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15499 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
15500 & wdte(i,mdme(idc,1))
15501 wdte(i,0)=wdte(i,mdme(idc,1))
15502 wdte(0,0)=wdte(0,0)+wdte(i,0)
15503 ENDIF
15504 IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
15505 IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
15506 & mstp(44).EQ.7) vint(111)=vint(111)+fggf*wid2
15507 IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=vint(112)+
15508 & fgzf*wid2
15509 IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=vint(113)+
15510 & fgzpf*wid2
15511 IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
15512 & mstp(44).EQ.7) vint(114)=vint(114)+fzzf*wid2
15513 IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=vint(115)+
15514 & fzzpf*wid2
15515 IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
15516 & mstp(44).EQ.7) vint(116)=vint(116)+fzpzpf*wid2
15517 ENDIF
15518 ENDIF
15519 280 CONTINUE
15520 IF(mint(61).GE.1) icase=3-icase
15521 IF(icase.EQ.2) GOTO 270
15522
15523 ELSEIF(kfla.EQ.34) THEN
15524C...W'+/-:
15525 fac=(aem/(24d0*xw))*shr
15526 DO 290 i=1,mdcy(kc,3)
15527 idc=i+mdcy(kc,2)-1
15528 IF(mdme(idc,1).LT.0) GOTO 290
15529 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15530 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15531 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 290
15532 wid2=1d0
15533 IF(i.LE.20) THEN
15534 IF(i.LE.16) THEN
15535C...W'+/- -> q + qbar'
15536 fcof=3d0*radc*(paru(131)**2+paru(132)**2)*
15537 & vckm((i-1)/4+1,mod(i-1,4)+1)
15538 IF(kflr.GT.0) THEN
15539 IF(mod(i,4).EQ.3) wid2=wids(6,2)
15540 IF(mod(i,4).EQ.0) wid2=wids(8,2)
15541 IF(i.GE.13) wid2=wid2*wids(7,3)
15542 ELSE
15543 IF(mod(i,4).EQ.3) wid2=wids(6,3)
15544 IF(mod(i,4).EQ.0) wid2=wids(8,3)
15545 IF(i.GE.13) wid2=wid2*wids(7,2)
15546 ENDIF
15547 ELSEIF(i.LE.20) THEN
15548C...W'+/- -> l+/- + nu
15549 fcof=paru(133)**2+paru(134)**2
15550 IF(kflr.GT.0) THEN
15551 IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
15552 ELSE
15553 IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
15554 ENDIF
15555 ENDIF
15556 wdtp(i)=fac*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*
15557 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15558 ELSEIF(i.EQ.21) THEN
15559C...W'+/- -> W+/- + Z0
15560 wdtp(i)=fac*paru(135)**2*0.5d0*xw1*(rm1/rm2)*
15561 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
15562 & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
15563 IF(kflr.GT.0) wid2=wids(24,2)*wids(23,2)
15564 IF(kflr.LT.0) wid2=wids(24,3)*wids(23,2)
15565 ELSEIF(i.EQ.23) THEN
15566C...W'+/- -> W+/- + h0
15567 flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15568 wdtp(i)=fac*paru(146)**2*2d0*(3d0*rm1+0.25d0*flam**2)*flam
15569 IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
15570 IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
15571 ENDIF
15572 wdtp(0)=wdtp(0)+wdtp(i)
15573 IF(mdme(idc,1).GT.0) THEN
15574 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15575 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15576 wdte(i,0)=wdte(i,mdme(idc,1))
15577 wdte(0,0)=wdte(0,0)+wdte(i,0)
15578 ENDIF
15579 290 CONTINUE
15580
15581 ELSEIF(kfla.EQ.37) THEN
15582C...H+/-:
15583 fac=(aem/(8d0*xw))*(sh/pmas(24,1)**2)*shr
15584 DO 300 i=1,mdcy(kc,3)
15585 idc=i+mdcy(kc,2)-1
15586 IF(mdme(idc,1).LT.0) GOTO 300
15587 kfc1=pycomp(kfdp(idc,1))
15588 kfc2=pycomp(kfdp(idc,2))
15589 rm1=pmas(kfc1,1)**2/sh
15590 rm2=pmas(kfc2,1)**2/sh
15591 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 300
15592 wid2=1d0
15593 IF(i.LE.4) THEN
15594C...H+/- -> q + qbar'
15595 rm1r=pymrun(kfdp(idc,1),sh)**2/sh
15596 rm2r=pymrun(kfdp(idc,2),sh)**2/sh
15597 wdtp(i)=fac*3d0*radc*max(0d0,(rm1r*paru(141)**2+
15598 & rm2r/paru(141)**2)*(1d0-rm1r-rm2r)-4d0*rm1r*rm2r)*
15599 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15600 IF(kflr.GT.0) THEN
15601 IF(i.EQ.3) wid2=wids(6,2)
15602 IF(i.EQ.4) wid2=wids(7,3)*wids(8,2)
15603 ELSE
15604 IF(i.EQ.3) wid2=wids(6,3)
15605 IF(i.EQ.4) wid2=wids(7,2)*wids(8,3)
15606 ENDIF
15607 ELSEIF(i.LE.8) THEN
15608C...H+/- -> l+/- + nu
15609 wdtp(i)=fac*((rm1*paru(141)**2+rm2/paru(141)**2)*
15610 & (1d0-rm1-rm2)-4d0*rm1*rm2)*
15611 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15612 IF(kflr.GT.0) THEN
15613 IF(i.EQ.8) wid2=wids(17,3)*wids(18,2)
15614 ELSE
15615 IF(i.EQ.8) wid2=wids(17,2)*wids(18,3)
15616 ENDIF
15617 ELSEIF(i.EQ.9) THEN
15618C...H+/- -> W+/- + h0.
15619 wdtp(i)=fac*paru(195)**2*0.5d0*sqrt(max(0d0,
15620 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15621 IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
15622 IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
15623
15624CMRENNA++
15625 ELSE
15626C...Add in SUSY decays (two-body) by rescaling by phase space factor.
15627 rm10=rm1*sh/pmr**2
15628 rm20=rm2*sh/pmr**2
15629 wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
15630 wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
15631 IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
15632 wfac=0d0
15633 ELSE
15634 wfac=wfac/wfac0
15635 ENDIF
15636 wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
15637CMRENNA--
15638 ksgn1=2
15639 IF(kfls*kfdp(idc,1).LT.0.AND.kchg(kfc1,3).EQ.1) ksgn1=3
15640 ksgn2=2
15641 IF(kfls*kfdp(idc,2).LT.0.AND.kchg(kfc2,3).EQ.1) ksgn2=3
15642 wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
15643 ENDIF
15644 wdtp(0)=wdtp(0)+wdtp(i)
15645 IF(mdme(idc,1).GT.0) THEN
15646 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15647 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15648 wdte(i,0)=wdte(i,mdme(idc,1))
15649 wdte(0,0)=wdte(0,0)+wdte(i,0)
15650 ENDIF
15651 300 CONTINUE
15652
15653 ELSEIF(kfla.EQ.38) THEN
15654C...Techni-eta.
15655 fac=(sh/parp(46)**2)*shr
15656 DO 310 i=1,mdcy(kc,3)
15657 idc=i+mdcy(kc,2)-1
15658 IF(mdme(idc,1).LT.0) GOTO 310
15659 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15660 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15661 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 310
15662 wid2=1d0
15663 IF(i.LE.2) THEN
15664 wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))/(4d0*paru(1))
15665 IF(i.EQ.2) wid2=wids(6,1)
15666 ELSE
15667 wdtp(i)=fac*5d0*as**2/(96d0*paru(1)**3)
15668 ENDIF
15669 wdtp(0)=wdtp(0)+wdtp(i)
15670 IF(mdme(idc,1).GT.0) THEN
15671 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15672 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15673 wdte(i,0)=wdte(i,mdme(idc,1))
15674 wdte(0,0)=wdte(0,0)+wdte(i,0)
15675 ENDIF
15676 310 CONTINUE
15677
15678 ELSEIF(kfla.EQ.39) THEN
15679C...LQ (leptoquark).
15680 fac=(aem/4d0)*paru(151)*shr
15681 DO 320 i=1,mdcy(kc,3)
15682 idc=i+mdcy(kc,2)-1
15683 IF(mdme(idc,1).LT.0) GOTO 320
15684 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15685 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15686 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 320
15687 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15688 wid2=1d0
15689 ilqq=kfdp(idc,1)*isign(1,kflr)
15690 IF(ilqq.GE.6) wid2=wids(ilqq,2)
15691 IF(ilqq.LE.-6) wid2=wids(-ilqq,3)
15692 ilql=kfdp(idc,2)*isign(1,kflr)
15693 IF(ilql.GE.17) wid2=wid2*wids(ilql,2)
15694 IF(ilql.LE.-17) wid2=wid2*wids(-ilql,3)
15695 wdtp(0)=wdtp(0)+wdtp(i)
15696 IF(mdme(idc,1).GT.0) THEN
15697 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15698 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15699 wdte(i,0)=wdte(i,mdme(idc,1))
15700 wdte(0,0)=wdte(0,0)+wdte(i,0)
15701 ENDIF
15702 320 CONTINUE
15703
15704 ELSEIF(kfla.EQ.40) THEN
15705C...R:
15706 fac=(aem/(12d0*xw))*shr
15707 DO 330 i=1,mdcy(kc,3)
15708 idc=i+mdcy(kc,2)-1
15709 IF(mdme(idc,1).LT.0) GOTO 330
15710 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15711 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15712 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 330
15713 wid2=1d0
15714 IF(i.LE.6) THEN
15715C...R -> q + qbar'
15716 fcof=3d0*radc
15717 ELSEIF(i.LE.9) THEN
15718C...R -> l+ + l'-
15719 fcof=1d0
15720 ENDIF
15721 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
15722 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15723 IF(kflr.GT.0) THEN
15724 IF(i.EQ.4) wid2=wids(6,3)
15725 IF(i.EQ.5) wid2=wids(7,3)
15726 IF(i.EQ.6) wid2=wids(6,2)*wids(8,3)
15727 IF(i.EQ.9) wid2=wids(17,3)
15728 ELSE
15729 IF(i.EQ.4) wid2=wids(6,2)
15730 IF(i.EQ.5) wid2=wids(7,2)
15731 IF(i.EQ.6) wid2=wids(6,3)*wids(8,2)
15732 IF(i.EQ.9) wid2=wids(17,2)
15733 ENDIF
15734 wdtp(0)=wdtp(0)+wdtp(i)
15735 IF(mdme(idc,1).GT.0) THEN
15736 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15737 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15738 wdte(i,0)=wdte(i,mdme(idc,1))
15739 wdte(0,0)=wdte(0,0)+wdte(i,0)
15740 ENDIF
15741 330 CONTINUE
15742
15743 ELSEIF(kfla.EQ.51.OR.kfla.EQ.53) THEN
15744C...Techni-pi0 and techni-pi0':
15745 fac=(1d0/(32d0*paru(1)*parp(142)**2))*shr
15746 DO 340 i=1,mdcy(kc,3)
15747 idc=i+mdcy(kc,2)-1
15748 IF(mdme(idc,1).LT.0) GOTO 340
15749 pm1=pmas(pycomp(kfdp(idc,1)),1)
15750 pm2=pmas(pycomp(kfdp(idc,2)),1)
15751 rm1=pm1**2/sh
15752 rm2=pm2**2/sh
15753 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 340
15754 wid2=1d0
15755C...pi_tech -> g + g
15756 IF(i.EQ.8) THEN
15757 facp=(as/(4d0*paru(1))*parp(144)/parp(142))**2
15758 & /(8d0*paru(1))*sh*shr
15759 IF(kfla.EQ.51) THEN
15760 facp=facp*parp(149)
15761 ELSE
15762 facp=facp*parp(150)
15763 ENDIF
15764 wdtp(i)=facp
15765 ELSE
15766C...pi_tech -> f + fbar.
15767 fcof=1d0
15768 ika=iabs(kfdp(idc,1))
15769 IF(ika.LT.10) fcof=3d0*radc
15770 hm1=pm1
15771 hm2=pm2
15772 IF(ika.GE.4.AND.ika.LE.6) THEN
15773 fcof=fcof*parp(141+ika)**2
15774 hm1=pymrun(kfdp(idc,1),sh)
15775 hm2=pymrun(kfdp(idc,2),sh)
15776 ELSEIF(ika.EQ.15) THEN
15777 fcof=fcof*parp(148)**2
15778 ENDIF
15779 wdtp(i)=fac*fcof*(hm1+hm2)**2*
15780 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15781 ENDIF
15782 wdtp(0)=wdtp(0)+wdtp(i)
15783 IF(mdme(idc,1).GT.0) THEN
15784 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15785 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15786 wdte(i,0)=wdte(i,mdme(idc,1))
15787 wdte(0,0)=wdte(0,0)+wdte(i,0)
15788 ENDIF
15789 340 CONTINUE
15790
15791 ELSEIF(kfla.EQ.52) THEN
15792C...pi+_tech
15793 fac=(1d0/(32d0*paru(1)*parp(142)**2))*shr
15794 DO 350 i=1,mdcy(kc,3)
15795 idc=i+mdcy(kc,2)-1
15796 IF(mdme(idc,1).LT.0) GOTO 350
15797 pm1=pmas(pycomp(kfdp(idc,1)),1)
15798 pm2=pmas(pycomp(kfdp(idc,2)),1)
15799 pm3=0d0
15800 IF(i.EQ.3) pm3=pmas(pycomp(kfdp(idc,3)),1)
15801 rm1=pm1**2/sh
15802 rm2=pm2**2/sh
15803 rm3=pm3**2/sh
15804 IF(sqrt(rm1)+sqrt(rm2)+sqrt(rm3).GT.1d0) GOTO 350
15805 wid2=1d0
15806C...pi_tech -> f + f'.
15807 fcof=1d0
15808 IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc
15809C...pi_tech+ -> W b b~
15810 IF(i.EQ.3.AND.shr.LT.pmas(6,1)+pmas(5,1)) THEN
15811 fcof=3d0*radc
15812 xmt2=pmas(6,1)**2/sh
15813 facp=fac/(4d0*paru(1))*fcof*xmt2*parp(147)**2
15814 kfc3=pycomp(kfdp(idc,3))
15815 check = sqrt(rm1)+sqrt(rm2)+sqrt(rm3)
15816 check = sqrt(rm1)
15817 t0 = (1d0-check**2)*
15818 & (xmt2*(6.*xmt2**2+3.*xmt2*rm1-4.*rm1**2)-
15819 & (5.*xmt2**2+2.*xmt2*rm1-8.*rm1**2))/(4.*xmt2**2)
15820 t1 = (1d0-xmt2)*(rm1-xmt2)*((xmt2**2+xmt2*rm1+4.*rm1**2)
15821 & -3.*xmt2**2*(xmt2+rm1))/(2.0*xmt2**3)
15822 t3 = rm1**2/xmt2**3*(3.0*xmt2-4.0*rm1+4.0*xmt2*rm1)
15823 wdtp(i)=facp*(t0 + t1*log((xmt2-check**2)/(xmt2-1d0))
15824 & +t3*log(check))
15825 IF(kflr.GT.0) THEN
15826 wid2=wids(24,2)
15827 ELSE
15828 wid2=wids(24,3)
15829 ENDIF
15830 ELSE
15831 fcof=1d0
15832 ika=iabs(kfdp(idc,1))
15833 IF(ika.LT.10) fcof=3d0*radc
15834 hm1=pm1
15835 hm2=pm2
15836 IF(i.GE.1.AND.i.LE.3) THEN
15837 fcof=fcof*parp(144+i)**2
15838 hm1=pymrun(kfdp(idc,1),sh)
15839 hm2=pymrun(kfdp(idc,2),sh)
15840 ELSEIF(i.EQ.6) THEN
15841 fcof=fcof*parp(148)**2
15842 ENDIF
15843 wdtp(i)=fac*fcof*(hm1+hm2)**2*
15844 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
15845 ENDIF
15846 wdtp(0)=wdtp(0)+wdtp(i)
15847 IF(mdme(idc,1).GT.0) THEN
15848 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15849 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15850 wdte(i,0)=wdte(i,mdme(idc,1))
15851 wdte(0,0)=wdte(0,0)+wdte(i,0)
15852 ENDIF
15853 350 CONTINUE
15854
15855 ELSEIF(kfla.EQ.54) THEN
15856C...Techni-rho0:
15857 alprht=2.91d0*(3d0/parp(144))
15858 fac=(alprht/12d0)*shr
15859 facf=(1d0/6d0)*(aem**2/alprht)*shr
15860 sqmz=pmas(23,1)**2
15861 sqmw=pmas(24,1)**2
15862 shp=sh
15863 CALL pywidx(23,shp,wdtpp,wdtep)
15864 gmmz=shr*wdtpp(0)
15865 xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
15866 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
15867 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
15868 DO 360 i=1,mdcy(kc,3)
15869 idc=i+mdcy(kc,2)-1
15870 IF(mdme(idc,1).LT.0) GOTO 360
15871 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15872 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15873 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 360
15874 wid2=1d0
15875 IF(i.EQ.1) THEN
15876C...rho_tech0 -> W+ + W-.
15877 wdtp(i)=fac*parp(141)**4*
15878 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15879 wid2=wids(24,1)
15880 ELSEIF(i.EQ.2) THEN
15881C...rho_tech0 -> W+ + pi_tech-.
15882 wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
15883 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
15884 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
15885 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
15886 & (1d0-parp(141)**2)/4d0/xw/24d0/parj(173)**2*shr**3
15887 wid2=wids(24,2)*wids(52,3)
15888 ELSEIF(i.EQ.3) THEN
15889C...rho_tech0 -> pi_tech+ + W-.
15890 wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
15891 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
15892 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
15893 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
15894 & (1d0-parp(141)**2)/4d0/xw/24d0/parj(173)**2*shr**3
15895 wid2=wids(52,2)*wids(24,3)
15896 ELSEIF(i.EQ.4) THEN
15897C...rho_tech0 -> pi_tech+ + pi_tech-.
15898 wdtp(i)=fac*(1d0-parp(141)**2)**2*
15899 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15900 wid2=wids(52,1)
15901 ELSEIF(i.EQ.5) THEN
15902C...rho_tech0 -> gamma + pi_tech0
15903 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
15904 & (2d0*parp(143)-1d0)**2*(1d0-parp(141)**2)/24d0/parj(172)**2*
15905 & shr**3
15906 wid2=wids(51,2)
15907 ELSEIF(i.EQ.6) THEN
15908C...rho_tech0 -> gamma + pi_tech0'
15909 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
15910 & (1d0-parj(174)**2)/24d0/parj(172)**2*shr**3
15911 wid2=wids(53,2)
15912 ELSEIF(i.EQ.7) THEN
15913C...rho_tech0 -> Z0 + pi_tech0
15914 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
15915 & (2d0*parp(143)-1d0)**2*(1d0-parp(141)**2)/24d0/parj(172)**2*
15916 & xw/xw1*shr**3
15917 wid2=wids(23,2)*wids(51,2)
15918 ELSEIF(i.EQ.8) THEN
15919C...rho_tech0 -> Z0 + pi_tech0'
15920 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
15921 & (1d0-parj(174)**2)/24d0/parj(172)**2*(1d0-2d0*xw)**2/4d0/
15922 & xw/xw1*shr**3
15923 wid2=wids(23,2)*wids(53,2)
15924 ELSE
15925C...rho_tech0 -> f + fbar.
15926 wid2=1d0
15927 IF(i.LE.16) THEN
15928 ia=i-8
15929 fcof=3d0*radc
15930 IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
15931 ELSE
15932 ia=i-6
15933 fcof=1d0
15934 IF(ia.GE.17) wid2=wids(ia,1)
15935 ENDIF
15936 ei=kchg(ia,1)/3d0
15937 ai=sign(1d0,ei+0.1d0)
15938 vi=ai-4d0*ei*xwv
15939 vali=0.5d0*(vi+ai)
15940 vari=0.5d0*(vi-ai)
15941 wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
15942 & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
15943 & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
15944 & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
15945 ENDIF
15946 wdtp(0)=wdtp(0)+wdtp(i)
15947 IF(mdme(idc,1).GT.0) THEN
15948 wdte(i,mdme(idc,1))=wdtp(i)*wid2
15949 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
15950 wdte(i,0)=wdte(i,mdme(idc,1))
15951 wdte(0,0)=wdte(0,0)+wdte(i,0)
15952 ENDIF
15953 360 CONTINUE
15954
15955 ELSEIF(kfla.EQ.55) THEN
15956C...Techni-rho+/-:
15957 alprht=2.91d0*(3d0/parp(144))
15958 fac=(alprht/12d0)*shr
15959 sqmz=pmas(23,1)**2
15960 sqmw=pmas(24,1)**2
15961 shp=sh
15962 CALL pywidx(24,shp,wdtpp,wdtep)
15963 gmmw=shr*wdtpp(0)
15964 facf=(1d0/12d0)*(aem**2/alprht)*shr*
15965 & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
15966 DO 370 i=1,mdcy(kc,3)
15967 idc=i+mdcy(kc,2)-1
15968 IF(mdme(idc,1).LT.0) GOTO 370
15969 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
15970 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
15971 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 370
15972 wid2=1d0
15973 IF(i.EQ.1) THEN
15974C...rho_tech+ -> W+ + Z0.
15975 wdtp(i)=fac*parp(141)**4*
15976 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
15977 IF(kflr.GT.0) THEN
15978 wid2=wids(24,2)*wids(23,2)
15979 ELSE
15980 wid2=wids(24,3)*wids(23,2)
15981 ENDIF
15982 ELSEIF(i.EQ.2) THEN
15983C...rho_tech+ -> W+ + pi_tech0.
15984 wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
15985 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
15986 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
15987 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
15988 & (1d0-parp(141)**2)/4d0/xw/24d0/parj(173)**2*shr**3
15989 IF(kflr.GT.0) THEN
15990 wid2=wids(24,2)*wids(51,2)
15991 ELSE
15992 wid2=wids(24,3)*wids(51,2)
15993 ENDIF
15994 ELSEIF(i.EQ.3) THEN
15995C...rho_tech+ -> pi_tech+ + Z0.
15996 wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
15997 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
15998 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
15999 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmz/sh)*
16000 & (1d0-parp(141)**2)/4d0/xw/xw1/24d0/parj(173)**2*shr**3+
16001 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16002 & (2d0*parp(143)-1d0)**2*(1d0-parp(141)**2)/24d0/parj(172)**2*
16003 & shr**3*xw/xw1
16004 IF(kflr.GT.0) THEN
16005 wid2=wids(52,2)*wids(23,2)
16006 ELSE
16007 wid2=wids(52,3)*wids(23,2)
16008 ENDIF
16009 ELSEIF(i.EQ.4) THEN
16010C...rho_tech+ -> pi_tech+ + pi_tech0.
16011 wdtp(i)=fac*(1d0-parp(141)**2)**2*
16012 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
16013 IF(kflr.GT.0) THEN
16014 wid2=wids(52,2)*wids(51,2)
16015 ELSE
16016 wid2=wids(52,3)*wids(51,2)
16017 ENDIF
16018 ELSEIF(i.EQ.5) THEN
16019C...rho_tech+ -> pi_tech+ + gamma
16020 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16021 & (2d0*parp(143)-1d0)**2*(1d0-parp(141)**2)/24d0/parj(172)**2*
16022 & shr**3
16023 IF(kflr.GT.0) THEN
16024 wid2=wids(52,2)
16025 ELSE
16026 wid2=wids(52,3)
16027 ENDIF
16028 ELSEIF(i.EQ.6) THEN
16029C...rho_tech+ -> W+ + pi_tech0'
16030 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16031 & (1d0-parj(174)**2)/4d0/xw/24d0/parj(172)**2*shr**3
16032 IF(kflr.GT.0) THEN
16033 wid2=wids(24,2)*wids(53,2)
16034 ELSE
16035 wid2=wids(24,3)*wids(53,2)
16036 ENDIF
16037 ELSE
16038C...rho_tech+ -> f + fbar'.
16039 ia=i-6
16040 wid2=1d0
16041 IF(ia.LE.16) THEN
16042 fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
16043 IF(kflr.GT.0) THEN
16044 IF(mod(ia,4).EQ.3) wid2=wids(6,2)
16045 IF(mod(ia,4).EQ.0) wid2=wids(8,2)
16046 IF(ia.GE.13) wid2=wid2*wids(7,3)
16047 ELSE
16048 IF(mod(ia,4).EQ.3) wid2=wids(6,3)
16049 IF(mod(ia,4).EQ.0) wid2=wids(8,3)
16050 IF(ia.GE.13) wid2=wid2*wids(7,2)
16051 ENDIF
16052 ELSE
16053 fcof=1d0
16054 IF(kflr.GT.0) THEN
16055 IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
16056 ELSE
16057 IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
16058 ENDIF
16059 ENDIF
16060 wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
16061 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
16062 ENDIF
16063 wdtp(0)=wdtp(0)+wdtp(i)
16064 IF(mdme(idc,1).GT.0) THEN
16065 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16066 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16067 wdte(i,0)=wdte(i,mdme(idc,1))
16068 wdte(0,0)=wdte(0,0)+wdte(i,0)
16069 ENDIF
16070 370 CONTINUE
16071
16072 ELSEIF(kfla.EQ.56) THEN
16073C...Techni-omega:
16074 alprht=2.91d0*(3d0/parp(144))
16075 fac=(alprht/12d0)*shr
16076 facf=(1d0/6d0)*(aem**2/alprht)*shr*(2d0*parp(143)-1d0)**2
16077 sqmz=pmas(23,1)**2
16078 shp=sh
16079 CALL pywidx(23,shp,wdtpp,wdtep)
16080 gmmz=shr*wdtpp(0)
16081 bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
16082 bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
16083 DO 380 i=1,mdcy(kc,3)
16084 idc=i+mdcy(kc,2)-1
16085 IF(mdme(idc,1).LT.0) GOTO 380
16086 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
16087 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
16088 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 380
16089 wid2=1d0
16090 IF(i.EQ.1) THEN
16091C...omega_tech0 -> gamma + pi_tech0.
16092 wdtp(i)=aem/24d0/parj(172)**2*(1d0-parp(141)**2)*
16093 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*shr**3
16094 wid2=wids(51,2)
16095 ELSEIF(i.EQ.2) THEN
16096C...omega_tech0 -> Z0 + pi_tech0
16097 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16098 & (1d0-parp(141)**2)/24d0/parj(172)**2*(1d0-2d0*xw)**2/4d0/
16099 & xw/xw1*shr**3
16100 wid2=wids(23,2)*wids(51,2)
16101 ELSEIF(i.EQ.3) THEN
16102C...omega_tech0 -> gamma + pi_tech0'
16103 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16104 & (2d0*parp(143)-1d0)**2*(1d0-parj(174)**2)/24d0/parj(172)**2*
16105 & shr**3
16106 wid2=wids(53,2)
16107 ELSEIF(i.EQ.4) THEN
16108C...omega_tech0 -> Z0 + pi_tech0'
16109 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16110 & (2d0*parp(143)-1d0)**2*(1d0-parj(174)**2)/24d0/parj(172)**2*
16111 & xw/xw1*shr**3
16112 wid2=wids(23,2)*wids(51,2)
16113 ELSEIF(i.EQ.5) THEN
16114C...omega_tech0 -> W+ + pi_tech-
16115 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16116 & (1d0-parp(141)**2)/4d0/xw/24d0/parj(172)**2*shr**3+
16117 & fac*parp(141)**2*(1d0-parp(141)**2)*parj(175)**2*
16118 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
16119 wid2=wids(24,2)*wids(52,3)
16120 ELSEIF(i.EQ.6) THEN
16121C...omega_tech0 -> pi_tech+ + W-
16122 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
16123 & (1d0-parp(141)**2)/4d0/xw/24d0/parj(172)**2*shr**3+
16124 & fac*parp(141)**2*(1d0-parp(141)**2)*parj(175)**2*
16125 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
16126 wid2=wids(24,3)*wids(52,2)
16127 ELSEIF(i.EQ.7) THEN
16128C...omega_tech0 -> W+ + W-.
16129 wdtp(i)=fac*parp(141)**4*parj(175)**2*
16130 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
16131 wid2=wids(24,1)
16132 ELSEIF(i.EQ.8) THEN
16133C...omega_tech0 -> pi_tech+ + pi_tech-.
16134 wdtp(i)=fac*(1d0-parp(141)**2)**2*parj(175)**2*
16135 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
16136 wid2=wids(52,1)
16137 ELSE
16138C...omega_tech0 -> f + fbar.
16139 wid2=1d0
16140 IF(i.LE.14) THEN
16141 ia=i-8
16142 fcof=3d0*radc
16143 IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
16144 ELSE
16145 ia=i-6
16146 fcof=1d0
16147 IF(ia.GE.17) wid2=wids(ia,1)
16148 ENDIF
16149 ei=kchg(ia,1)/3d0
16150 ai=sign(1d0,ei+0.1d0)
16151 vi=ai-4d0*ei*xwv
16152 vali=0.5d0*(vi+ai)
16153 vari=0.5d0*(vi-ai)
16154 wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
16155 & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
16156 & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
16157 & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
16158 ENDIF
16159 wdtp(0)=wdtp(0)+wdtp(i)
16160 IF(mdme(idc,1).GT.0) THEN
16161 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16162 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16163 wdte(i,0)=wdte(i,mdme(idc,1))
16164 wdte(0,0)=wdte(0,0)+wdte(i,0)
16165 ENDIF
16166 380 CONTINUE
16167
16168 ELSEIF(kfla.EQ.61) THEN
16169C...H_L++/--:
16170 fac=(1d0/(8d0*paru(1)))*shr
16171 DO 372 i=1,mdcy(kc,3)
16172 idc=i+mdcy(kc,2)-1
16173 IF(mdme(idc,1).LT.0) GOTO 372
16174 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
16175 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
16176 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 372
16177 wid2=1d0
16178 IF(i.LE.6) THEN
16179C...H_L++/-- -> l+/- + l'+/-
16180 fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
16181 & (iabs(kfdp(idc,2))-9)/2)**2
16182C***Should be factor 4 below ???
16183 IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
16184 ELSEIF(i.EQ.7) THEN
16185C...H_L++/-- -> W_L+/- + W_L+/-
16186 fcof=0.5d0*parp(190)**4*parp(192)**2/pmas(24,1)**2*
16187 & (3d0*rm1+0.25d0/rm1-1d0)
16188 wid2=wids(24,4+(1-kfls)/2)
16189 ENDIF
16190 wdtp(i)=fac*fcof*
16191 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
16192 wdtp(0)=wdtp(0)+wdtp(i)
16193 IF(mdme(idc,1).GT.0) THEN
16194 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16195 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16196 wdte(i,0)=wdte(i,mdme(idc,1))
16197 wdte(0,0)=wdte(0,0)+wdte(i,0)
16198 ENDIF
16199 372 CONTINUE
16200
16201 ELSEIF(kfla.EQ.62) THEN
16202C...H_R++/--:
16203 fac=(1d0/(8d0*paru(1)))*shr
16204 DO 373 i=1,mdcy(kc,3)
16205 idc=i+mdcy(kc,2)-1
16206 IF(mdme(idc,1).LT.0) GOTO 373
16207 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
16208 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
16209 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 373
16210 wid2=1d0
16211 IF(i.LE.6) THEN
16212C...H_R++/-- -> l+/- + l'+/-
16213 fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
16214 & (iabs(kfdp(idc,2))-9)/2)**2
16215 IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
16216 ELSEIF(i.EQ.7) THEN
16217C...H_R++/-- -> W_R+/- + W_R+/-
16218 fcof=parp(191)**2*(3d0*rm1+0.25d0/rm1-1d0)
16219 wid2=wids(63,4+(1-kfls)/2)
16220 ENDIF
16221 wdtp(i)=fac*fcof*
16222 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
16223 wdtp(0)=wdtp(0)+wdtp(i)
16224 IF(mdme(idc,1).GT.0) THEN
16225 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16226 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16227 wdte(i,0)=wdte(i,mdme(idc,1))
16228 wdte(0,0)=wdte(0,0)+wdte(i,0)
16229 ENDIF
16230 373 CONTINUE
16231
16232 ELSEIF(kfla.EQ.63) THEN
16233C...W_R+/-:
16234 fac=(aem/(24d0*xw))*shr
16235 DO 374 i=1,mdcy(kc,3)
16236 idc=i+mdcy(kc,2)-1
16237 IF(mdme(idc,1).LT.0) GOTO 374
16238 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
16239 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
16240 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 374
16241 wid2=1d0
16242 IF(i.LE.9) THEN
16243C...W_R+/- -> q + qbar'
16244 fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
16245 IF(kflr.GT.0) THEN
16246 IF(mod(i,3).EQ.0) wid2=wids(6,2)
16247 ELSE
16248 IF(mod(i,3).EQ.0) wid2=wids(6,3)
16249 ENDIF
16250 ELSEIF(i.LE.12) THEN
16251C...W_R+/- -> l+/- + nu_R
16252 fcof=1d0
16253 ENDIF
16254 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
16255 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
16256 wdtp(0)=wdtp(0)+wdtp(i)
16257 IF(mdme(idc,1).GT.0) THEN
16258 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16259 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16260 wdte(i,0)=wdte(i,mdme(idc,1))
16261 wdte(0,0)=wdte(0,0)+wdte(i,0)
16262 ENDIF
16263 374 CONTINUE
16264
16265 ELSEIF(kfla.EQ.kexcit+1) THEN
16266C...d* excited quark.
16267 fac=(sh/paru(155)**2)*shr
16268 DO 390 i=1,mdcy(kc,3)
16269 idc=i+mdcy(kc,2)-1
16270 IF(mdme(idc,1).LT.0) GOTO 390
16271 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
16272 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
16273 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 390
16274 wid2=1d0
16275 IF(i.EQ.1) THEN
16276C...d* -> g + d.
16277 wdtp(i)=fac*as*paru(159)**2/3d0
16278 wid2=1d0
16279 ELSEIF(i.EQ.2) THEN
16280C...d* -> gamma + d.
16281 qf=-paru(157)/2d0+paru(158)/6d0
16282 wdtp(i)=fac*aem*qf**2/4d0
16283 wid2=1d0
16284 ELSEIF(i.EQ.3) THEN
16285C...d* -> Z0 + d.
16286 qf=-paru(157)*xw1/2d0-paru(158)*xw/6d0
16287 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
16288 & (1d0-rm1)**2*(2d0+rm1)
16289 wid2=wids(23,2)
16290 ELSEIF(i.EQ.4) THEN
16291C...d* -> W- + u.
16292 wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
16293 & (1d0-rm1)**2*(2d0+rm1)
16294 IF(kflr.GT.0) wid2=wids(24,3)
16295 IF(kflr.LT.0) wid2=wids(24,2)
16296 ENDIF
16297 wdtp(0)=wdtp(0)+wdtp(i)
16298 IF(mdme(idc,1).GT.0) THEN
16299 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16300 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16301 wdte(i,0)=wdte(i,mdme(idc,1))
16302 wdte(0,0)=wdte(0,0)+wdte(i,0)
16303 ENDIF
16304 390 CONTINUE
16305
16306 ELSEIF(kfla.EQ.kexcit+2) THEN
16307C...u* excited quark.
16308 fac=(sh/paru(155)**2)*shr
16309 DO 400 i=1,mdcy(kc,3)
16310 idc=i+mdcy(kc,2)-1
16311 IF(mdme(idc,1).LT.0) GOTO 400
16312 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
16313 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
16314 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 400
16315 wid2=1d0
16316 IF(i.EQ.1) THEN
16317C...u* -> g + u.
16318 wdtp(i)=fac*as*paru(159)**2/3d0
16319 wid2=1d0
16320 ELSEIF(i.EQ.2) THEN
16321C...u* -> gamma + u.
16322 qf=paru(157)/2d0+paru(158)/6d0
16323 wdtp(i)=fac*aem*qf**2/4d0
16324 wid2=1d0
16325 ELSEIF(i.EQ.3) THEN
16326C...u* -> Z0 + u.
16327 qf=paru(157)*xw1/2d0-paru(158)*xw/6d0
16328 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
16329 & (1d0-rm1)**2*(2d0+rm1)
16330 wid2=wids(23,2)
16331 ELSEIF(i.EQ.4) THEN
16332C...u* -> W+ + d.
16333 wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
16334 & (1d0-rm1)**2*(2d0+rm1)
16335 IF(kflr.GT.0) wid2=wids(24,2)
16336 IF(kflr.LT.0) wid2=wids(24,3)
16337 ENDIF
16338 wdtp(0)=wdtp(0)+wdtp(i)
16339 IF(mdme(idc,1).GT.0) THEN
16340 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16341 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16342 wdte(i,0)=wdte(i,mdme(idc,1))
16343 wdte(0,0)=wdte(0,0)+wdte(i,0)
16344 ENDIF
16345 400 CONTINUE
16346
16347 ELSEIF(kfla.EQ.kexcit+11) THEN
16348C...e* excited lepton.
16349 fac=(sh/paru(155)**2)*shr
16350 DO 410 i=1,mdcy(kc,3)
16351 idc=i+mdcy(kc,2)-1
16352 IF(mdme(idc,1).LT.0) GOTO 410
16353 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
16354 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
16355 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 410
16356 wid2=1d0
16357 IF(i.EQ.1) THEN
16358C...e* -> gamma + e.
16359 qf=-paru(157)/2d0-paru(158)/2d0
16360 wdtp(i)=fac*aem*qf**2/4d0
16361 wid2=1d0
16362 ELSEIF(i.EQ.2) THEN
16363C...e* -> Z0 + e.
16364 qf=-paru(157)*xw1/2d0+paru(158)*xw/2d0
16365 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
16366 & (1d0-rm1)**2*(2d0+rm1)
16367 wid2=wids(23,2)
16368 ELSEIF(i.EQ.3) THEN
16369C...e* -> W- + nu.
16370 wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
16371 & (1d0-rm1)**2*(2d0+rm1)
16372 IF(kflr.GT.0) wid2=wids(24,3)
16373 IF(kflr.LT.0) wid2=wids(24,2)
16374 ENDIF
16375 wdtp(0)=wdtp(0)+wdtp(i)
16376 IF(mdme(idc,1).GT.0) THEN
16377 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16378 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16379 wdte(i,0)=wdte(i,mdme(idc,1))
16380 wdte(0,0)=wdte(0,0)+wdte(i,0)
16381 ENDIF
16382 410 CONTINUE
16383
16384 ELSEIF(kfla.EQ.kexcit+12) THEN
16385C...nu*_e excited neutrino.
16386 fac=(sh/paru(155)**2)*shr
16387 DO 420 i=1,mdcy(kc,3)
16388 idc=i+mdcy(kc,2)-1
16389 IF(mdme(idc,1).LT.0) GOTO 420
16390 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
16391 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
16392 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 420
16393 wid2=1d0
16394 IF(i.EQ.1) THEN
16395C...nu*_e -> Z0 + nu*_e.
16396 qf=paru(157)*xw1/2d0+paru(158)*xw/2d0
16397 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
16398 & (1d0-rm1)**2*(2d0+rm1)
16399 wid2=wids(23,2)
16400 ELSEIF(i.EQ.2) THEN
16401C...nu*_e -> W+ + e.
16402 wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
16403 & (1d0-rm1)**2*(2d0+rm1)
16404 IF(kflr.GT.0) wid2=wids(24,2)
16405 IF(kflr.LT.0) wid2=wids(24,3)
16406 ENDIF
16407 wdtp(0)=wdtp(0)+wdtp(i)
16408 IF(mdme(idc,1).GT.0) THEN
16409 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16410 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16411 wdte(i,0)=wdte(i,mdme(idc,1))
16412 wdte(0,0)=wdte(0,0)+wdte(i,0)
16413 ENDIF
16414 420 CONTINUE
16415
16416 ENDIF
16417 mint(61)=0
16418 mint(62)=0
16419 mint(63)=0
16420
16421 RETURN
16422 END
16423
16424C***********************************************************************
16425
16426C...PYWIDX
16427C...Calculates full and partial widths of resonances.
16428C....copy of PYWIDT, used for techniparticle widths
16429
16430 SUBROUTINE pywidx(KFLR,SH,WDTP,WDTE)
16431
16432C...Double precision and integer declarations.
16433 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16434 IMPLICIT INTEGER(I-N)
16435 INTEGER PYK,PYCHGE,PYCOMP
16436C...Parameter statement to help give large particle numbers.
16437 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
16438C...Commonblocks.
16439 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16440 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
16441 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
16442 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
16443 common/pypars/mstp(200),parp(200),msti(200),pari(200)
16444 common/pyint1/mint(400),vint(400)
16445 common/pyint4/mwid(500),wids(500,5)
16446 common/pymssm/imss(0:99),rmss(0:99)
16447 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
16448 &sfmix(16,4)
16449 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
16450 &/pyint4/,/pymssm/,/pyssmt/
16451C...Local arrays and saved variables.
16452 dimension wdtp(0:200),wdte(0:200,0:5),mofsv(3,2),widwsv(3,2),
16453 &wid2sv(3,2)
16454 SAVE mofsv,widwsv,wid2sv
16455 DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
16456
16457C...Compressed code and sign; mass.
16458 kfla=iabs(kflr)
16459 kfls=isign(1,kflr)
16460 kc=pycomp(kfla)
16461 shr=sqrt(sh)
16462 pmr=pmas(kc,1)
16463
16464C...Reset width information.
16465 DO 110 i=0,200
16466 wdtp(i)=0d0
16467 DO 100 j=0,5
16468 wdte(i,j)=0d0
16469 100 CONTINUE
16470 110 CONTINUE
16471
16472C...Common electroweak and strong constants.
16473 xw=paru(102)
16474 xwv=xw
16475 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
16476 xw1=1d0-xw
16477 aem=pyalem(sh)
16478 IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
16479 as=pyalps(sh)
16480 radc=1d0+as/paru(1)
16481
16482 IF(kfla.EQ.23) THEN
16483C...Z0:
16484 icase=1
16485 xwc=1d0/(16d0*xw*xw1)
16486 fac=(aem*xwc/3d0)*shr
16487 200 CONTINUE
16488 DO 210 i=1,mdcy(kc,3)
16489 idc=i+mdcy(kc,2)-1
16490 IF(mdme(idc,1).LT.0) GOTO 210
16491 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
16492 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
16493 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 210
16494 wid2=1d0
16495 IF(i.LE.8) THEN
16496C...Z0 -> q + qbar
16497 ef=kchg(i,1)/3d0
16498 af=sign(1d0,ef+0.1d0)
16499 vf=af-4d0*ef*xwv
16500 fcof=3d0*radc
16501 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
16502 IF(i.EQ.6) wid2=wids(6,1)
16503 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
16504 ELSEIF(i.LE.16) THEN
16505C...Z0 -> l+ + l-, nu + nubar
16506 ef=kchg(i+2,1)/3d0
16507 af=sign(1d0,ef+0.1d0)
16508 vf=af-4d0*ef*xwv
16509 fcof=1d0
16510 IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
16511 ENDIF
16512 be34=sqrt(max(0d0,1d0-4d0*rm1))
16513 wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
16514 & be34
16515 wdtp(0)=wdtp(0)+wdtp(i)
16516 IF(mdme(idc,1).GT.0) THEN
16517 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16518 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
16519 & wdte(i,mdme(idc,1))
16520 wdte(i,0)=wdte(i,mdme(idc,1))
16521 wdte(0,0)=wdte(0,0)+wdte(i,0)
16522 ENDIF
16523 210 CONTINUE
16524
16525
16526 ELSEIF(kfla.EQ.24) THEN
16527C...W+/-:
16528 fac=(aem/(24d0*xw))*shr
16529 DO 220 i=1,mdcy(kc,3)
16530 idc=i+mdcy(kc,2)-1
16531 IF(mdme(idc,1).LT.0) GOTO 220
16532 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
16533 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
16534 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 220
16535 wid2=1d0
16536 IF(i.LE.16) THEN
16537C...W+/- -> q + qbar'
16538 fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
16539 IF(kflr.GT.0) THEN
16540 IF(mod(i,4).EQ.3) wid2=wids(6,2)
16541 IF(mod(i,4).EQ.0) wid2=wids(8,2)
16542 IF(i.GE.13) wid2=wid2*wids(7,3)
16543 ELSE
16544 IF(mod(i,4).EQ.3) wid2=wids(6,3)
16545 IF(mod(i,4).EQ.0) wid2=wids(8,3)
16546 IF(i.GE.13) wid2=wid2*wids(7,2)
16547 ENDIF
16548 ELSEIF(i.LE.20) THEN
16549C...W+/- -> l+/- + nu
16550 fcof=1d0
16551 IF(kflr.GT.0) THEN
16552 IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
16553 ELSE
16554 IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
16555 ENDIF
16556 ENDIF
16557 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
16558 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
16559 wdtp(0)=wdtp(0)+wdtp(i)
16560 IF(mdme(idc,1).GT.0) THEN
16561 wdte(i,mdme(idc,1))=wdtp(i)*wid2
16562 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
16563 wdte(i,0)=wdte(i,mdme(idc,1))
16564 wdte(0,0)=wdte(0,0)+wdte(i,0)
16565 ENDIF
16566 220 CONTINUE
16567 ENDIF
16568
16569 RETURN
16570 END
16571
16572C***********************************************************************
16573
16574C...PYOFSH
16575C...Calculates partial width and differential cross-section maxima
16576C...of channels/processes not allowed on mass-shell, and selects
16577C...masses in such channels/processes.
16578
16579 SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
16580
16581C...Double precision and integer declarations.
16582 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16583 IMPLICIT INTEGER(I-N)
16584 INTEGER PYK,PYCHGE,PYCOMP
16585C...Commonblocks.
16586 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16587 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
16588 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
16589 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
16590 common/pypars/mstp(200),parp(200),msti(200),pari(200)
16591 common/pyint1/mint(400),vint(400)
16592 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
16593 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
16594 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
16595 &/pyint2/,/pyint5/
16596C...Local arrays.
16597 dimension kfd(2),mbw(2),pmd(2),pgd(2),pmg(2),pml(2),pmu(2),
16598 &pmh(2),atl(2),atu(2),ath(2),rmg(2),inx1(100),xpt1(100),
16599 &fpt1(100),inx2(100),xpt2(100),fpt2(100),wdtp(0:200),
16600 &wdte(0:200,0:5)
16601
16602C...Find if particles equal, maximum mass, matrix elements, etc.
16603 mint(51)=0
16604 isub=mint(1)
16605 kfd(1)=iabs(kfd1)
16606 kfd(2)=iabs(kfd2)
16607 meql=0
16608 IF(kfd(1).EQ.kfd(2)) meql=1
16609 mlm=0
16610 IF(mofsh.GE.2.AND.meql.EQ.1) mlm=int(1.5d0+pyr(0))
16611 IF(mofsh.LE.2.OR.mofsh.EQ.5) THEN
16612 noff=44
16613 pmmx=pmmo
16614 ELSE
16615 noff=40
16616 pmmx=vint(1)
16617 IF(ckin(2).GT.ckin(1)) pmmx=min(ckin(2),vint(1))
16618 ENDIF
16619 mmed=0
16620 IF((kfmo.EQ.25.OR.kfmo.EQ.35.OR.kfmo.EQ.36).AND.meql.EQ.1.AND.
16621 &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=1
16622 IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(1).EQ.23.OR.
16623 &kfd(1).EQ.24).AND.(kfd(2).EQ.23.OR.kfd(2).EQ.24)) mmed=2
16624 IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(2).EQ.25.OR.
16625 &kfd(2).EQ.35.OR.kfd(2).EQ.36)) mmed=3
16626 loop=1
16627
16628C...Find where Breit-Wigners are required, else select discrete masses.
16629 100 DO 110 i=1,2
16630 kfca=pycomp(kfd(i))
16631 IF(kfca.GT.0) THEN
16632 pmd(i)=pmas(kfca,1)
16633 pgd(i)=pmas(kfca,2)
16634 ELSE
16635 pmd(i)=0d0
16636 pgd(i)=0d0
16637 ENDIF
16638 IF(mstp(42).LE.0.OR.pgd(i).LT.parp(41)) THEN
16639 mbw(i)=0
16640 pmg(i)=pmd(i)
16641 rmg(i)=(pmg(i)/pmmx)**2
16642 ELSE
16643 mbw(i)=1
16644 ENDIF
16645 110 CONTINUE
16646
16647C...Find allowed mass range and Breit-Wigner parameters.
16648 DO 120 i=1,2
16649 IF(mofsh.EQ.1.AND.loop.EQ.1.AND.mbw(i).EQ.1) THEN
16650 pml(i)=parp(42)
16651 pmu(i)=pmmx-parp(42)
16652 IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
16653 IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
16654 ELSEIF(mbw(i).EQ.1.AND.mofsh.NE.5) THEN
16655 ilm=i
16656 IF(mlm.EQ.2) ilm=3-i
16657 pml(i)=max(ckin(noff+2*ilm-1),parp(42))
16658 IF(mbw(3-i).EQ.0) THEN
16659 pmu(i)=pmmx-pmd(3-i)
16660 ELSE
16661 pmu(i)=pmmx-max(ckin(noff+5-2*ilm),parp(42))
16662 ENDIF
16663 IF(ckin(noff+2*ilm).GT.ckin(noff+2*ilm-1)) pmu(i)=
16664 & min(pmu(i),ckin(noff+2*ilm))
16665 IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
16666 IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
16667 IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
16668 IF(mbw(i).EQ.1) THEN
16669 atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
16670 atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
16671 IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
16672 & pgd(i)))
16673 ENDIF
16674 ELSEIF(mbw(i).EQ.1.AND.mofsh.EQ.5) THEN
16675 ilm=i
16676 IF(mlm.EQ.2) ilm=3-i
16677 pml(i)=max(ckin(48+i),parp(42))
16678 pmu(i)=pmmx-max(ckin(51-i),parp(42))
16679 IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
16680 IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
16681 IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
16682 IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
16683 IF(mbw(i).EQ.1) THEN
16684 atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
16685 atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
16686 IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
16687 & pgd(i)))
16688 ENDIF
16689 ENDIF
16690 120 CONTINUE
16691 IF(mbw(1).LT.0.OR.mbw(2).LT.0.OR.(mbw(1).EQ.0.AND.mbw(2).EQ.0))
16692 &THEN
16693 CALL pyerrm(3,'(PYOFSH:) no allowed decay product masses')
16694 mint(51)=1
16695 RETURN
16696 ENDIF
16697
16698C...Calculation of partial width of resonance.
16699 IF(mofsh.EQ.1) THEN
16700
16701C..If only one integration, pick that to be the inner.
16702 IF(mbw(1).EQ.0) THEN
16703 pm2=pmd(1)
16704 pmd(1)=pmd(2)
16705 pgd(1)=pgd(2)
16706 pml(1)=pml(2)
16707 pmu(1)=pmu(2)
16708 ELSEIF(mbw(2).EQ.0) THEN
16709 pm2=pmd(2)
16710 ENDIF
16711
16712C...Start outer loop of integration.
16713 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
16714 atl2=atan((pml(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
16715 atu2=atan((pmu(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
16716 npt2=1
16717 xpt2(1)=1d0
16718 inx2(1)=0
16719 fmax2=0d0
16720 ENDIF
16721 130 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
16722 pm2s=pmd(2)**2+pmd(2)*pgd(2)*tan(atl2+xpt2(npt2)*(atu2-atl2))
16723 pm2=min(pmu(2),max(pml(2),sqrt(max(0d0,pm2s))))
16724 ENDIF
16725 rm2=(pm2/pmmx)**2
16726
16727C...Start inner loop of integration.
16728 pml1=pml(1)
16729 pmu1=min(pmu(1),pmmx-pm2)
16730 IF(meql.EQ.1) pmu1=min(pmu1,pm2)
16731 atl1=atan((pml1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
16732 atu1=atan((pmu1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
16733 IF(pml1+parj(64).GE.pmu1.OR.atl1+1d-7.GE.atu1) THEN
16734 func2=0d0
16735 GOTO 180
16736 ENDIF
16737 npt1=1
16738 xpt1(1)=1d0
16739 inx1(1)=0
16740 fmax1=0d0
16741 140 pm1s=pmd(1)**2+pmd(1)*pgd(1)*tan(atl1+xpt1(npt1)*(atu1-atl1))
16742 pm1=min(pmu1,max(pml1,sqrt(max(0d0,pm1s))))
16743 rm1=(pm1/pmmx)**2
16744
16745C...Evaluate function value - inner loop.
16746 func1=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
16747 IF(mmed.EQ.1) func1=func1*((1d0-rm1-rm2)**2+8d0*rm1*rm2)
16748 IF(mmed.EQ.2) func1=func1**3*(1d0+10d0*rm1+10d0*rm2+rm1**2+
16749 & rm2**2+10d0*rm1*rm2)
16750 IF(func1.GT.fmax1) fmax1=func1
16751 fpt1(npt1)=func1
16752
16753C...Go to next position in inner loop.
16754 IF(npt1.EQ.1) THEN
16755 npt1=npt1+1
16756 xpt1(npt1)=0d0
16757 inx1(npt1)=1
16758 GOTO 140
16759 ELSEIF(npt1.LE.8) THEN
16760 npt1=npt1+1
16761 IF(npt1.LE.4.OR.npt1.EQ.6) ish1=1
16762 ish1=ish1+1
16763 xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
16764 inx1(npt1)=inx1(ish1)
16765 inx1(ish1)=npt1
16766 GOTO 140
16767 ELSEIF(npt1.LT.100) THEN
16768 isn1=ish1
16769 150 ish1=ish1+1
16770 IF(ish1.GT.npt1) ish1=2
16771 IF(ish1.EQ.isn1) GOTO 160
16772 dfpt1=abs(fpt1(ish1)-fpt1(inx1(ish1)))
16773 IF(dfpt1.LT.parp(43)*fmax1) GOTO 150
16774 npt1=npt1+1
16775 xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
16776 inx1(npt1)=inx1(ish1)
16777 inx1(ish1)=npt1
16778 GOTO 140
16779 ENDIF
16780
16781C...Calculate integral over inner loop.
16782 160 fsum1=0d0
16783 DO 170 ipt1=2,npt1
16784 fsum1=fsum1+0.5d0*(fpt1(ipt1)+fpt1(inx1(ipt1)))*
16785 & (xpt1(inx1(ipt1))-xpt1(ipt1))
16786 170 CONTINUE
16787 func2=fsum1*(atu1-atl1)/paru(1)
16788 180 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
16789 IF(func2.GT.fmax2) fmax2=func2
16790 fpt2(npt2)=func2
16791
16792C...Go to next position in outer loop.
16793 IF(npt2.EQ.1) THEN
16794 npt2=npt2+1
16795 xpt2(npt2)=0d0
16796 inx2(npt2)=1
16797 GOTO 130
16798 ELSEIF(npt2.LE.8) THEN
16799 npt2=npt2+1
16800 IF(npt2.LE.4.OR.npt2.EQ.6) ish2=1
16801 ish2=ish2+1
16802 xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
16803 inx2(npt2)=inx2(ish2)
16804 inx2(ish2)=npt2
16805 GOTO 130
16806 ELSEIF(npt2.LT.100) THEN
16807 isn2=ish2
16808 190 ish2=ish2+1
16809 IF(ish2.GT.npt2) ish2=2
16810 IF(ish2.EQ.isn2) GOTO 200
16811 dfpt2=abs(fpt2(ish2)-fpt2(inx2(ish2)))
16812 IF(dfpt2.LT.parp(43)*fmax2) GOTO 190
16813 npt2=npt2+1
16814 xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
16815 inx2(npt2)=inx2(ish2)
16816 inx2(ish2)=npt2
16817 GOTO 130
16818 ENDIF
16819
16820C...Calculate integral over outer loop.
16821 200 fsum2=0d0
16822 DO 210 ipt2=2,npt2
16823 fsum2=fsum2+0.5d0*(fpt2(ipt2)+fpt2(inx2(ipt2)))*
16824 & (xpt2(inx2(ipt2))-xpt2(ipt2))
16825 210 CONTINUE
16826 fsum2=fsum2*(atu2-atl2)/paru(1)
16827 IF(meql.EQ.1) fsum2=2d0*fsum2
16828 ELSE
16829 fsum2=func2
16830 ENDIF
16831
16832C...Save result; second integration for user-selected mass range.
16833 IF(loop.EQ.1) widw=fsum2
16834 wid2=fsum2
16835 IF(loop.EQ.1.AND.(ckin(46).GE.ckin(45).OR.ckin(48).GE.ckin(47)
16836 & .OR.max(ckin(45),ckin(47)).GE.1.01d0*parp(42))) THEN
16837 loop=2
16838 GOTO 100
16839 ENDIF
16840 ret1=widw
16841 ret2=wid2/widw
16842
16843C...Select two decay product masses of a resonance.
16844 ELSEIF(mofsh.EQ.2.OR.mofsh.EQ.5) THEN
16845 220 DO 230 i=1,2
16846 IF(mbw(i).EQ.0) GOTO 230
16847 pmbw=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*
16848 & (atu(i)-atl(i)))
16849 pmg(i)=min(pmu(i),max(pml(i),sqrt(max(0d0,pmbw))))
16850 rmg(i)=(pmg(i)/pmmx)**2
16851 230 CONTINUE
16852 IF((meql.EQ.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
16853 & pmg(1)+pmg(2)+parj(64).GT.pmmx) GOTO 220
16854
16855C...Weight with matrix element (if none known, use beta factor).
16856 flam=sqrt(max(0d0,(1d0-rmg(1)-rmg(2))**2-4d0*rmg(1)*rmg(2)))
16857 IF(mmed.EQ.1) THEN
16858 wtbe=flam*((1d0-rmg(1)-rmg(2))**2+8d0*rmg(1)*rmg(2))
16859 ELSEIF(mmed.EQ.2) THEN
16860 wtbe=flam**3*(1d0+10d0*rmg(1)+10d0*rmg(2)+rmg(1)**2+
16861 & rmg(2)**2+10d0*rmg(1)*rmg(2))
16862 ELSEIF(mmed.EQ.3) THEN
16863 wtbe=flam*(rmg(1)+flam**2/12d0)
16864 ELSE
16865 wtbe=flam
16866 ENDIF
16867 IF(wtbe.LT.pyr(0)) GOTO 220
16868 ret1=pmg(1)
16869 ret2=pmg(2)
16870
16871C...Find suitable set of masses for initialization of 2 -> 2 processes.
16872 ELSEIF(mofsh.EQ.3) THEN
16873 IF(mbw(1).NE.0.AND.mbw(2).EQ.0) THEN
16874 pmg(1)=min(pmd(1),0.5d0*(pml(1)+pmu(1)))
16875 pmg(2)=pmd(2)
16876 ELSEIF(mbw(2).NE.0.AND.mbw(1).EQ.0) THEN
16877 pmg(1)=pmd(1)
16878 pmg(2)=min(pmd(2),0.5d0*(pml(2)+pmu(2)))
16879 ELSE
16880 idiv=-1
16881 240 idiv=idiv+1
16882 pmg(1)=min(pmd(1),0.1d0*(idiv*pml(1)+(10-idiv)*pmu(1)))
16883 pmg(2)=min(pmd(2),0.1d0*(idiv*pml(2)+(10-idiv)*pmu(2)))
16884 IF(idiv.LE.9.AND.pmg(1)+pmg(2).GT.0.9d0*pmmx) GOTO 240
16885 ENDIF
16886 ret1=pmg(1)
16887 ret2=pmg(2)
16888
16889C...Evaluate importance of excluded tails of Breit-Wigners.
16890 IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
16891 & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
16892 IF(meql.LE.1) THEN
16893 vint(80)=1d0
16894 DO 250 i=1,2
16895 IF(mbw(i).NE.0) vint(80)=vint(80)*1.25d0*(atu(i)-atl(i))/
16896 & paru(1)
16897 250 CONTINUE
16898 ELSE
16899 vint(80)=(1.25d0/paru(1))**2*max((atu(1)-atl(1))*
16900 & (ath(2)-atl(2)),(ath(1)-atl(1))*(atu(2)-atl(2)))
16901 ENDIF
16902 IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.30.OR.isub.EQ.35).AND.
16903 & mstp(43).NE.2) vint(80)=2d0*vint(80)
16904 IF(isub.EQ.22.AND.mstp(43).NE.2) vint(80)=4d0*vint(80)
16905 IF(meql.GE.1) vint(80)=2d0*vint(80)
16906
16907C...Pick one particle to be the lighter (if improves efficiency).
16908 ELSEIF(mofsh.EQ.4) THEN
16909 IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
16910 & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
16911 260 IF(meql.EQ.2) mlm=int(1.5d0+pyr(0))
16912
16913C...Select two masses according to Breit-Wigner + flat in s + 1/s.
16914 DO 270 i=1,2
16915 IF(mbw(i).EQ.0) GOTO 270
16916 pmv=pmu(i)
16917 IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
16918 atv=atu(i)
16919 IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
16920 rbr=pyr(0)
16921 IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
16922 & isub.EQ.35).AND.mstp(43).NE.2) rbr=2d0*rbr
16923 IF(rbr.LT.0.8d0) THEN
16924 pmsr=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*(atv-atl(i)))
16925 pmg(i)=min(pmv,max(pml(i),sqrt(max(0d0,pmsr))))
16926 ELSEIF(rbr.LT.0.9d0) THEN
16927 pmg(i)=sqrt(max(0d0,pml(i)**2+pyr(0)*(pmv**2-pml(i)**2)))
16928 ELSEIF(rbr.LT.1.5d0) THEN
16929 pmg(i)=pml(i)*(pmv/pml(i))**pyr(0)
16930 ELSE
16931 pmg(i)=sqrt(max(0d0,pml(i)**2*pmv**2/(pml(i)**2+pyr(0)*
16932 & (pmv**2-pml(i)**2))))
16933 ENDIF
16934 270 CONTINUE
16935 IF((meql.GE.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
16936 & pmg(1)+pmg(2)+parj(64).GT.pmmx) THEN
16937 IF(mint(48).EQ.1) THEN
16938 ngen(0,1)=ngen(0,1)+1
16939 ngen(mint(1),1)=ngen(mint(1),1)+1
16940 GOTO 260
16941 ELSE
16942 mint(51)=1
16943 RETURN
16944 ENDIF
16945 ENDIF
16946 ret1=pmg(1)
16947 ret2=pmg(2)
16948
16949C...Give weight for selected mass distribution.
16950 vint(80)=1d0
16951 DO 280 i=1,2
16952 IF(mbw(i).EQ.0) GOTO 280
16953 pmv=pmu(i)
16954 IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
16955 atv=atu(i)
16956 IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
16957 f0=pmd(i)*pgd(i)/((pmg(i)**2-pmd(i)**2)**2+
16958 & (pmd(i)*pgd(i))**2)/paru(1)
16959 f1=1d0
16960 f2=1d0/pmg(i)**2
16961 f3=1d0/pmg(i)**4
16962 fi0=(atv-atl(i))/paru(1)
16963 fi1=pmv**2-pml(i)**2
16964 fi2=2d0*log(pmv/pml(i))
16965 fi3=1d0/pml(i)**2-1d0/pmv**2
16966 IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
16967 & isub.EQ.35).AND.mstp(43).NE.2) THEN
16968 vint(80)=vint(80)*20d0/(8d0+(fi0/f0)*(f1/fi1+6d0*f2/fi2+
16969 & 5d0*f3/fi3))
16970 ELSE
16971 vint(80)=vint(80)*10d0/(8d0+(fi0/f0)*(f1/fi1+f2/fi2))
16972 ENDIF
16973 vint(80)=vint(80)*fi0
16974 280 CONTINUE
16975 IF(meql.GE.1) vint(80)=2d0*vint(80)
16976 ENDIF
16977
16978 RETURN
16979 END
16980
16981C***********************************************************************
16982
16983C...PYRECO
16984C...Handles the possibility of colour reconnection in W+W- events,
16985C...Based on the main scenarios of the Sjostrand and Khoze study:
16986C...I, II, II', intermediate and instantaneous; plus one model
16987C...along the lines of the Gustafson and Hakkinen: GH.
16988C...Note: also handles Z0 Z0 and W-W+ events, but notation below
16989C...is as if first resonance is W+ and second W-.
16990
16991 SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)
16992
16993C...Double precision and integer declarations.
16994 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16995 IMPLICIT INTEGER(I-N)
16996 INTEGER PYK,PYCHGE,PYCOMP
16997C...Parameter value; number of points in MC integration.
16998 parameter(npt=100)
16999C...Commonblocks.
17000 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
17001 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
17002 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
17003 common/pypars/mstp(200),parp(200),msti(200),pari(200)
17004 common/pyint1/mint(400),vint(400)
17005 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
17006C...Local arrays.
17007 dimension nbeg(2),nend(2),inp(50),inm(50),beww(3),xp(3),xm(3),
17008 &v1(3),v2(3),betp(50,4),dirp(50,3),betm(50,4),dirm(50,3),
17009 &xd(4),xb(4),iap(npt),iam(npt),wta(npt),v1p(3),v2p(3),v1m(3),
17010 &v2m(3),q(4,3),xpp(3),xmm(3),ipc(20),imc(20),tc(0:20),tpc(20),
17011 &tmc(20),ijoin(100)
17012
17013C...Functions to give four-product and to do determinants.
17014 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)
17015 deter(i,j,l)=q(i,1)*q(j,2)*q(l,3)-q(i,1)*q(l,2)*q(j,3)+
17016 &q(j,1)*q(l,2)*q(i,3)-q(j,1)*q(i,2)*q(l,3)+
17017 &q(l,1)*q(i,2)*q(j,3)-q(l,1)*q(j,2)*q(i,3)
17018
17019C...Only allow fraction of recoupling for GH, intermediate and
17020C...instantaneous.
17021 IF(mstp(115).EQ.5.OR.mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
17022 IF(pyr(0).GT.parp(120)) RETURN
17023 ENDIF
17024 isub=mint(1)
17025
17026C...Common part for scenarios I, II, II', and GH.
17027 IF(mstp(115).EQ.1.OR.mstp(115).EQ.2.OR.mstp(115).EQ.3.OR.
17028 &mstp(115).EQ.5) THEN
17029
17030C...Read out frequently-used parameters.
17031 pi=paru(1)
17032 hbar=paru(3)
17033 pmw=pmas(24,1)
17034 IF(isub.EQ.22) pmw=pmas(23,1)
17035 pgw=pmas(24,2)
17036 IF(isub.EQ.22) pgw=pmas(23,2)
17037 tfrag=parp(115)
17038 rhad=parp(116)
17039 fact=parp(117)
17040 blowr=parp(118)
17041 blowt=parp(119)
17042
17043C...Find range of decay products of the W's.
17044C...Background: the W's are stored in IW1 and IW2.
17045C...Their direct decay products in NSD1+1 through NSD1+4.
17046C...Products after shower (if any) in NSD1+5 through NAFT1
17047C...for first W and in NAFT1+1 through N for the second.
17048 IF(naft1.GT.nsd1+4) THEN
17049 nbeg(1)=nsd1+5
17050 nend(1)=naft1
17051 ELSE
17052 nbeg(1)=nsd1+1
17053 nend(1)=nsd1+2
17054 ENDIF
17055 IF(n.GT.naft1) THEN
17056 nbeg(2)=naft1+1
17057 nend(2)=n
17058 ELSE
17059 nbeg(2)=nsd1+3
17060 nend(2)=nsd1+4
17061 ENDIF
17062
17063C...Rearrange parton shower products along strings.
17064 nold=n
17065 CALL pyprep(nsd1+1)
17066
17067C...Find partons pointing back to W+ and W-; store them with quark
17068C...end of string first.
17069 nnp=0
17070 nnm=0
17071 isgp=0
17072 isgm=0
17073 DO 120 i=nold+1,n
17074 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 120
17075 IF(iabs(k(i,2)).GE.22) GOTO 120
17076 IF(k(i,3).GE.nbeg(1).AND.k(i,3).LE.nend(1)) THEN
17077 IF(isgp.EQ.0) isgp=isign(1,k(i,2))
17078 nnp=nnp+1
17079 IF(isgp.EQ.1) THEN
17080 inp(nnp)=i
17081 ELSE
17082 DO 100 i1=nnp,2,-1
17083 inp(i1)=inp(i1-1)
17084 100 CONTINUE
17085 inp(1)=i
17086 ENDIF
17087 IF(k(i,1).EQ.1) isgp=0
17088 ELSEIF(k(i,3).GE.nbeg(2).AND.k(i,3).LE.nend(2)) THEN
17089 IF(isgm.EQ.0) isgm=isign(1,k(i,2))
17090 nnm=nnm+1
17091 IF(isgm.EQ.1) THEN
17092 inm(nnm)=i
17093 ELSE
17094 DO 110 i1=nnm,2,-1
17095 inm(i1)=inm(i1-1)
17096 110 CONTINUE
17097 inm(1)=i
17098 ENDIF
17099 IF(k(i,1).EQ.1) isgm=0
17100 ENDIF
17101 120 CONTINUE
17102
17103C...Boost to W+W- rest frame (not strictly needed).
17104 DO 130 j=1,3
17105 beww(j)=(p(iw1,j)+p(iw2,j))/(p(iw1,4)+p(iw2,4))
17106 130 CONTINUE
17107 CALL pyrobo(iw1,iw1,0d0,0d0,-beww(1),-beww(2),-beww(3))
17108 CALL pyrobo(iw2,iw2,0d0,0d0,-beww(1),-beww(2),-beww(3))
17109 CALL pyrobo(nold+1,n,0d0,0d0,-beww(1),-beww(2),-beww(3))
17110
17111C...Select decay vertices of W+ and W-.
17112 tp=hbar*(-log(pyr(0)))*p(iw1,4)/
17113 & sqrt((p(iw1,5)**2-pmw**2)**2+(p(iw1,5)**2*pgw/pmw)**2)
17114 tm=hbar*(-log(pyr(0)))*p(iw2,4)/
17115 & sqrt((p(iw2,5)**2-pmw**2)**2+(p(iw2,5)**2*pgw/pmw)**2)
17116 gtmax=max(tp,tm)
17117 DO 140 j=1,3
17118 xp(j)=tp*p(iw1,j)/p(iw1,4)
17119 xm(j)=tm*p(iw2,j)/p(iw2,4)
17120 140 CONTINUE
17121
17122C...Begin scenario I specifics.
17123 IF(mstp(115).EQ.1) THEN
17124
17125C...Reconstruct velocity and direction of W+ string pieces.
17126 DO 170 iip=1,nnp-1
17127 IF(k(inp(iip),2).LT.0) GOTO 170
17128 i1=inp(iip)
17129 i2=inp(iip+1)
17130 p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
17131 p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
17132 DO 150 j=1,3
17133 v1(j)=p(i1,j)/p1a
17134 v2(j)=p(i2,j)/p2a
17135 betp(iip,j)=0.5d0*(v1(j)+v2(j))
17136 dirp(iip,j)=v1(j)-v2(j)
17137 150 CONTINUE
17138 betp(iip,4)=1d0/sqrt(1d0-betp(iip,1)**2-betp(iip,2)**2-
17139 & betp(iip,3)**2)
17140 dirl=sqrt(dirp(iip,1)**2+dirp(iip,2)**2+dirp(iip,3)**2)
17141 DO 160 j=1,3
17142 dirp(iip,j)=dirp(iip,j)/dirl
17143 160 CONTINUE
17144 170 CONTINUE
17145
17146C...Reconstruct velocity and direction of W- string pieces.
17147 DO 200 iim=1,nnm-1
17148 IF(k(inm(iim),2).LT.0) GOTO 200
17149 i1=inm(iim)
17150 i2=inm(iim+1)
17151 p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
17152 p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
17153 DO 180 j=1,3
17154 v1(j)=p(i1,j)/p1a
17155 v2(j)=p(i2,j)/p2a
17156 betm(iim,j)=0.5d0*(v1(j)+v2(j))
17157 dirm(iim,j)=v1(j)-v2(j)
17158 180 CONTINUE
17159 betm(iim,4)=1d0/sqrt(1d0-betm(iim,1)**2-betm(iim,2)**2-
17160 & betm(iim,3)**2)
17161 dirl=sqrt(dirm(iim,1)**2+dirm(iim,2)**2+dirm(iim,3)**2)
17162 DO 190 j=1,3
17163 dirm(iim,j)=dirm(iim,j)/dirl
17164 190 CONTINUE
17165 200 CONTINUE
17166
17167C...Loop over number of space-time points.
17168 nacc=0
17169 sum=0d0
17170 DO 250 ipt=1,npt
17171
17172C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
17173 r=sqrt(-log(pyr(0)))
17174 phi=2d0*pi*pyr(0)
17175 x=blowr*rhad*r*cos(phi)
17176 y=blowr*rhad*r*sin(phi)
17177 r=sqrt(-log(pyr(0)))
17178 phi=2d0*pi*pyr(0)
17179 z=blowr*rhad*r*cos(phi)
17180 t=gtmax+blowt*sqrt(0.5d0)*tfrag*r*abs(sin(phi))
17181
17182C...Reject impossible points. Weight for sample distribution.
17183 IF(t**2-x**2-y**2-z**2.LT.0d0) GOTO 250
17184 wtsmp=exp(-(x**2+y**2+z**2)/(blowr*rhad)**2)*
17185 & exp(-2d0*(t-gtmax)**2/(blowt*tfrag)**2)
17186
17187C...Loop over W+ string pieces and find one with largest weight.
17188 imaxp=0
17189 wtmaxp=1d-10
17190 xd(1)=x-xp(1)
17191 xd(2)=y-xp(2)
17192 xd(3)=z-xp(3)
17193 xd(4)=t-tp
17194 DO 220 iip=1,nnp-1
17195 IF(k(inp(iip),2).LT.0) GOTO 220
17196 bed=betp(iip,1)*xd(1)+betp(iip,2)*xd(2)+betp(iip,3)*xd(3)
17197 bedg=betp(iip,4)*(betp(iip,4)*bed/(1d0+betp(iip,4))-xd(4))
17198 DO 210 j=1,3
17199 xb(j)=xd(j)+bedg*betp(iip,j)
17200 210 CONTINUE
17201 xb(4)=betp(iip,4)*(xd(4)-bed)
17202 sr2=xb(1)**2+xb(2)**2+xb(3)**2
17203 sz2=(dirp(iip,1)*xb(1)+dirp(iip,2)*xb(2)+
17204 & dirp(iip,3)*xb(3))**2
17205 wtp=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
17206 & tfrag**2)
17207 IF(xb(4)-sqrt(sr2).LT.0d0) wtp=0d0
17208 IF(wtp.GT.wtmaxp) THEN
17209 imaxp=iip
17210 wtmaxp=wtp
17211 ENDIF
17212 220 CONTINUE
17213
17214C...Loop over W- string pieces and find one with largest weight.
17215 imaxm=0
17216 wtmaxm=1d-10
17217 xd(1)=x-xm(1)
17218 xd(2)=y-xm(2)
17219 xd(3)=z-xm(3)
17220 xd(4)=t-tm
17221 DO 240 iim=1,nnm-1
17222 IF(k(inm(iim),2).LT.0) GOTO 240
17223 bed=betm(iim,1)*xd(1)+betm(iim,2)*xd(2)+betm(iim,3)*xd(3)
17224 bedg=betm(iim,4)*(betm(iim,4)*bed/(1d0+betm(iim,4))-xd(4))
17225 DO 230 j=1,3
17226 xb(j)=xd(j)+bedg*betm(iim,j)
17227 230 CONTINUE
17228 xb(4)=betm(iim,4)*(xd(4)-bed)
17229 sr2=xb(1)**2+xb(2)**2+xb(3)**2
17230 sz2=(dirm(iim,1)*xb(1)+dirm(iim,2)*xb(2)+
17231 & dirm(iim,3)*xb(3))**2
17232 wtm=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
17233 & tfrag**2)
17234 IF(xb(4)-sqrt(sr2).LT.0d0) wtm=0d0
17235 IF(wtm.GT.wtmaxm) THEN
17236 imaxm=iim
17237 wtmaxm=wtm
17238 ENDIF
17239 240 CONTINUE
17240
17241C...Result of integration.
17242 wt=0d0
17243 IF(imaxp.NE.0.AND.imaxm.NE.0) THEN
17244 wt=wtmaxp*wtmaxm/wtsmp
17245 sum=sum+wt
17246 nacc=nacc+1
17247 iap(nacc)=imaxp
17248 iam(nacc)=imaxm
17249 wta(nacc)=wt
17250 ENDIF
17251 250 CONTINUE
17252 res=blowr**3*blowt*sum/npt
17253
17254C...Decide whether to reconnect and, if so, where.
17255 iacc=0
17256 prec=1d0-exp(-fact*res)
17257 IF(prec.GT.pyr(0)) THEN
17258 rsum=pyr(0)*sum
17259 DO 260 ia=1,nacc
17260 iacc=ia
17261 rsum=rsum-wta(ia)
17262 IF(rsum.LE.0d0) GOTO 270
17263 260 CONTINUE
17264 270 iip=iap(iacc)
17265 iim=iam(iacc)
17266 ENDIF
17267
17268C...Begin scenario II and II' specifics.
17269 ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN
17270
17271C...Loop through all string pieces, one from W+ and one from W-.
17272 ncross=0
17273 tc(0)=0d0
17274 DO 340 iip=1,nnp-1
17275 IF(k(inp(iip),2).LT.0) GOTO 340
17276 i1p=inp(iip)
17277 i2p=inp(iip+1)
17278 DO 330 iim=1,nnm-1
17279 IF(k(inm(iim),2).LT.0) GOTO 330
17280 i1m=inm(iim)
17281 i2m=inm(iim+1)
17282
17283C...Find endpoint velocity vectors.
17284 DO 280 j=1,3
17285 v1p(j)=p(i1p,j)/p(i1p,4)
17286 v2p(j)=p(i2p,j)/p(i2p,4)
17287 v1m(j)=p(i1m,j)/p(i1m,4)
17288 v2m(j)=p(i2m,j)/p(i2m,4)
17289 280 CONTINUE
17290
17291C...Define q matrix and find t.
17292 DO 290 j=1,3
17293 q(1,j)=v2p(j)-v1p(j)
17294 q(2,j)=-(v2m(j)-v1m(j))
17295 q(3,j)=xp(j)-xm(j)-tp*v1p(j)+tm*v1m(j)
17296 q(4,j)=v1p(j)-v1m(j)
17297 290 CONTINUE
17298 t=-deter(1,2,3)/deter(1,2,4)
17299
17300C...Find alpha and beta; i.e. coordinates of crossing point.
17301 s11=q(1,1)*(t-tp)
17302 s12=q(2,1)*(t-tm)
17303 s13=q(3,1)+q(4,1)*t
17304 s21=q(1,2)*(t-tp)
17305 s22=q(2,2)*(t-tm)
17306 s23=q(3,2)+q(4,2)*t
17307 den=s11*s22-s12*s21
17308 alp=(s12*s23-s22*s13)/den
17309 bet=(s21*s13-s11*s23)/den
17310
17311C...Check if solution acceptable.
17312 iansw=1
17313 IF(t.LT.gtmax) iansw=0
17314 IF(alp.LT.0d0.OR.alp.GT.1d0) iansw=0
17315 IF(bet.LT.0d0.OR.bet.GT.1d0) iansw=0
17316
17317C...Find point of crossing and check that not inconsistent.
17318 DO 300 j=1,3
17319 xpp(j)=xp(j)+(v1p(j)+alp*(v2p(j)-v1p(j)))*(t-tp)
17320 xmm(j)=xm(j)+(v1m(j)+bet*(v2m(j)-v1m(j)))*(t-tm)
17321 300 CONTINUE
17322 d2pm=(xpp(1)-xmm(1))**2+(xpp(2)-xmm(2))**2+
17323 & (xpp(3)-xmm(3))**2
17324 d2p=xpp(1)**2+xpp(2)**2+xpp(3)**2
17325 d2m=xmm(1)**2+xmm(2)**2+xmm(3)**2
17326 IF(d2pm.GT.1d-4*(d2p+d2m)) iansw=-1
17327
17328C...Find string eigentimes at crossing.
17329 IF(iansw.EQ.1) THEN
17330 taup=sqrt(max(0d0,(t-tp)**2-(xpp(1)-xp(1))**2-
17331 & (xpp(2)-xp(2))**2-(xpp(3)-xp(3))**2))
17332 taum=sqrt(max(0d0,(t-tm)**2-(xmm(1)-xm(1))**2-
17333 & (xmm(2)-xm(2))**2-(xmm(3)-xm(3))**2))
17334 ELSE
17335 taup=0d0
17336 taum=0d0
17337 ENDIF
17338
17339C...Order crossings by time. End loop over crossings.
17340 IF(iansw.EQ.1.AND.ncross.LT.20) THEN
17341 ncross=ncross+1
17342 DO 310 i1=ncross,1,-1
17343 IF(t.GT.tc(i1-1).OR.i1.EQ.1) THEN
17344 ipc(i1)=iip
17345 imc(i1)=iim
17346 tc(i1)=t
17347 tpc(i1)=taup
17348 tmc(i1)=taum
17349 GOTO 320
17350 ELSE
17351 ipc(i1)=ipc(i1-1)
17352 imc(i1)=imc(i1-1)
17353 tc(i1)=tc(i1-1)
17354 tpc(i1)=tpc(i1-1)
17355 tmc(i1)=tmc(i1-1)
17356 ENDIF
17357 310 CONTINUE
17358 320 CONTINUE
17359 ENDIF
17360 330 CONTINUE
17361 340 CONTINUE
17362
17363C...Loop over crossings; find first (if any) acceptable one.
17364 iacc=0
17365 IF(ncross.GE.1) THEN
17366 DO 350 ic=1,ncross
17367 pnfrag=exp(-(tpc(ic)**2+tmc(ic)**2)/tfrag**2)
17368 IF(pnfrag.GT.pyr(0)) THEN
17369C...Scenario II: only compare with fragmentation time.
17370 IF(mstp(115).EQ.2) THEN
17371 iacc=ic
17372 iip=ipc(iacc)
17373 iim=imc(iacc)
17374 GOTO 360
17375C...Scenario II': also require that string length decreases.
17376 ELSE
17377 iip=ipc(ic)
17378 iim=imc(ic)
17379 i1p=inp(iip)
17380 i2p=inp(iip+1)
17381 i1m=inm(iim)
17382 i2m=inm(iim+1)
17383 elold=four(i1p,i2p)*four(i1m,i2m)
17384 elnew=four(i1p,i2m)*four(i1m,i2p)
17385 IF(elnew.LT.elold) THEN
17386 iacc=ic
17387 iip=ipc(iacc)
17388 iim=imc(iacc)
17389 GOTO 360
17390 ENDIF
17391 ENDIF
17392 ENDIF
17393 350 CONTINUE
17394 360 CONTINUE
17395 ENDIF
17396
17397C...Begin scenario GH specifics.
17398 ELSEIF(mstp(115).EQ.5) THEN
17399
17400C...Loop through all string pieces, one from W+ and one from W-.
17401 iacc=0
17402 elmin=1d0
17403 DO 380 iip=1,nnp-1
17404 IF(k(inp(iip),2).LT.0) GOTO 380
17405 i1p=inp(iip)
17406 i2p=inp(iip+1)
17407 DO 370 iim=1,nnm-1
17408 IF(k(inm(iim),2).LT.0) GOTO 370
17409 i1m=inm(iim)
17410 i2m=inm(iim+1)
17411
17412C...Look for largest decrease of (exponent of) Lambda measure.
17413 elold=four(i1p,i2p)*four(i1m,i2m)
17414 elnew=four(i1p,i2m)*four(i1m,i2p)
17415 eldif=elnew/max(1d-10,elold)
17416 IF(eldif.LT.elmin) THEN
17417 iacc=iip+iim
17418 elmin=eldif
17419 ipc(1)=iip
17420 imc(1)=iim
17421 ENDIF
17422 370 CONTINUE
17423 380 CONTINUE
17424 iip=ipc(1)
17425 iim=imc(1)
17426 ENDIF
17427
17428C...Common for scenarios I, II, II' and GH: reconnect strings.
17429 IF(iacc.NE.0) THEN
17430 mint(32)=1
17431 njoin=0
17432 DO 390 is=1,nnp+nnm
17433 njoin=njoin+1
17434 IF(is.LE.iip) THEN
17435 i=inp(is)
17436 ELSEIF(is.LE.iip+nnm-iim) THEN
17437 i=inm(is-iip+iim)
17438 ELSEIF(is.LE.iip+nnm) THEN
17439 i=inm(is-iip-nnm+iim)
17440 ELSE
17441 i=inp(is-nnm)
17442 ENDIF
17443 ijoin(njoin)=i
17444 IF(k(i,2).LT.0) THEN
17445 CALL pyjoin(njoin,ijoin)
17446 njoin=0
17447 ENDIF
17448 390 CONTINUE
17449
17450C...Restore original event record if no reconnection.
17451 ELSE
17452 DO 400 i=nsd1+1,nold
17453 IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
17454 k(i,4)=mod(k(i,4),mstu(5)**2)
17455 k(i,5)=mod(k(i,5),mstu(5)**2)
17456 ENDIF
17457 400 CONTINUE
17458 DO 410 i=nold+1,n
17459 k(k(i,3),1)=3
17460 410 CONTINUE
17461 n=nold
17462 ENDIF
17463
17464C...Boost back system.
17465 CALL pyrobo(iw1,iw1,0d0,0d0,beww(1),beww(2),beww(3))
17466 CALL pyrobo(iw2,iw2,0d0,0d0,beww(1),beww(2),beww(3))
17467 IF(n.GT.nold) CALL pyrobo(nold+1,n,0d0,0d0,
17468 & beww(1),beww(2),beww(3))
17469
17470C...Common part for intermediate and instantaneous scenarios.
17471 ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
17472 mint(32)=1
17473
17474C...Remove old shower products and reset showering ones.
17475 n=nsd1+4
17476 DO 420 i=nsd1+1,nsd1+4
17477 k(i,1)=3
17478 k(i,4)=mod(k(i,4),mstu(5)**2)
17479 k(i,5)=mod(k(i,5),mstu(5)**2)
17480 420 CONTINUE
17481
17482C...Identify quark-antiquark pairs.
17483 iq1=nsd1+1
17484 iq2=nsd1+2
17485 iq3=nsd1+3
17486 IF(k(iq1,2)*k(iq3,2).LT.0) iq3=nsd1+4
17487 iq4=2*nsd1+7-iq3
17488
17489C...Reconnect strings.
17490 ijoin(1)=iq1
17491 ijoin(2)=iq4
17492 CALL pyjoin(2,ijoin)
17493 ijoin(1)=iq3
17494 ijoin(2)=iq2
17495 CALL pyjoin(2,ijoin)
17496
17497C...Do new parton showers in intermediate scenario.
17498 IF(mstp(71).GE.1.AND.mstp(115).EQ.11) THEN
17499 mstj50=mstj(50)
17500 mstj(50)=0
17501 CALL pyshow(iq1,iq2,p(iw1,5))
17502 CALL pyshow(iq3,iq4,p(iw2,5))
17503 mstj(50)=mstj50
17504
17505C...Do new parton showers in instantaneous scenario.
17506 ELSEIF(mstp(71).GE.1.AND.mstp(115).EQ.12) THEN
17507 ppm2=(p(iq1,4)+p(iq4,4))**2-(p(iq1,1)+p(iq4,1))**2-
17508 & (p(iq1,2)+p(iq4,2))**2-(p(iq1,3)+p(iq4,3))**2
17509 ppm=sqrt(max(0d0,ppm2))
17510 CALL pyshow(iq1,iq4,ppm)
17511 ppm2=(p(iq3,4)+p(iq2,4))**2-(p(iq3,1)+p(iq2,1))**2-
17512 & (p(iq3,2)+p(iq2,2))**2-(p(iq3,3)+p(iq2,3))**2
17513 ppm=sqrt(max(0d0,ppm2))
17514 CALL pyshow(iq3,iq2,ppm)
17515 ENDIF
17516 ENDIF
17517
17518 RETURN
17519 END
17520
17521C***********************************************************************
17522
17523C...PYKLIM
17524C...Checks generated variables against pre-set kinematical limits;
17525C...also calculates limits on variables used in generation.
17526
17527 SUBROUTINE pyklim(ILIM)
17528
17529C...Double precision and integer declarations.
17530 IMPLICIT DOUBLE PRECISION(a-h, o-z)
17531 IMPLICIT INTEGER(I-N)
17532 INTEGER PYK,PYCHGE,PYCOMP
17533C...Commonblocks.
17534 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
17535 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
17536 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
17537 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
17538 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
17539 common/pypars/mstp(200),parp(200),msti(200),pari(200)
17540 common/pyint1/mint(400),vint(400)
17541 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
17542 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
17543 &/pyint1/,/pyint2/
17544
17545C...Common kinematical expressions.
17546 mint(51)=0
17547 isub=mint(1)
17548 istsb=iset(isub)
17549 IF(isub.EQ.96) GOTO 100
17550 sqm3=vint(63)
17551 sqm4=vint(64)
17552 IF(ilim.NE.0) THEN
17553 IF(abs(sqm3).LT.1d-4.AND.abs(sqm4).LT.1d-4) THEN
17554 ckin09=max(ckin(9),ckin(13))
17555 ckin10=min(ckin(10),ckin(14))
17556 ckin11=max(ckin(11),ckin(15))
17557 ckin12=min(ckin(12),ckin(16))
17558 ELSE
17559 ckin09=max(ckin(9),min(0d0,ckin(13)))
17560 ckin10=min(ckin(10),max(0d0,ckin(14)))
17561 ckin11=max(ckin(11),min(0d0,ckin(15)))
17562 ckin12=min(ckin(12),max(0d0,ckin(16)))
17563 ENDIF
17564 ENDIF
17565 IF(ilim.NE.1) THEN
17566 tau=vint(21)
17567 rm3=sqm3/(tau*vint(2))
17568 rm4=sqm4/(tau*vint(2))
17569 be34=sqrt(max(1d-20,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
17570 ENDIF
17571 pthmin=ckin(3)
17572 IF(min(sqm3,sqm4).LT.ckin(6)**2.AND.istsb.NE.1.AND.istsb.NE.3)
17573 &pthmin=max(ckin(3),ckin(5))
17574
17575 IF(ilim.EQ.0) THEN
17576C...Check generated values of tau, y*, cos(theta-hat), and tau' against
17577C...pre-set kinematical limits.
17578 yst=vint(22)
17579 cth=vint(23)
17580 taup=vint(26)
17581 taue=tau
17582 IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
17583 x1=sqrt(taue)*exp(yst)
17584 x2=sqrt(taue)*exp(-yst)
17585 xf=x1-x2
17586 IF(mint(47).NE.1) THEN
17587 IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1
17588 IF(ckin(2).GE.0d0.AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1
17589 IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1
17590 IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1
17591 ENDIF
17592 IF(mint(45).NE.1) THEN
17593 IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1
17594 ENDIF
17595 IF(mint(46).NE.1) THEN
17596 IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1
17597 ENDIF
17598 IF(mint(45).EQ.2) THEN
17599 IF(x1.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
17600 ENDIF
17601 IF(mint(46).EQ.2) THEN
17602 IF(x2.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
17603 ENDIF
17604 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
17605 pth=0.5d0*be34*sqrt(tau*vint(2)*max(0d0,1d0-cth**2))
17606 expy3=max(1d-20,(1d0+rm3-rm4+be34*cth)/
17607 & max(1d-20,(1d0+rm3-rm4-be34*cth)))
17608 expy4=max(1d-20,(1d0-rm3+rm4-be34*cth)/
17609 & max(1d-20,(1d0-rm3+rm4+be34*cth)))
17610 y3=yst+0.5d0*log(expy3)
17611 y4=yst+0.5d0*log(expy4)
17612 ylarge=max(y3,y4)
17613 ysmall=min(y3,y4)
17614 etalar=20d0
17615 etasma=-20d0
17616 sth=sqrt(max(0d0,1d0-cth**2))
17617 exsq3=sqrt(max(1d-20,((1d0+rm3-rm4)*cosh(yst)+be34*sinh(yst)*
17618 & cth)**2-4d0*rm3))
17619 exsq4=sqrt(max(1d-20,((1d0-rm3+rm4)*cosh(yst)-be34*sinh(yst)*
17620 & cth)**2-4d0*rm4))
17621 IF(sth.GE.1d-10) THEN
17622 expet3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+exsq3)/
17623 & (be34*sth)
17624 expet4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+exsq4)/
17625 & (be34*sth)
17626 eta3=log(min(1d10,max(1d-10,expet3)))
17627 eta4=log(min(1d10,max(1d-10,expet4)))
17628 etalar=max(eta3,eta4)
17629 etasma=min(eta3,eta4)
17630 ENDIF
17631 cts3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/exsq3
17632 cts4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/exsq4
17633 ctslar=min(1d0,max(-1d0,cts3,cts4))
17634 ctssma=max(-1d0,min(1d0,cts3,cts4))
17635 sh=tau*vint(2)
17636 rpts=4d0*vint(71)**2/sh
17637 be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
17638 rm34=max(1d-20,2d0*rm3*rm4)
17639 IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
17640 & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
17641 rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
17642 tha=0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)
17643 uha=0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
17644 IF(pth.LT.pthmin) mint(51)=1
17645 IF(ckin(4).GE.0d0.AND.pth.GT.ckin(4)) mint(51)=1
17646 IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1
17647 IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1
17648 IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1
17649 IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1
17650 IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1
17651 IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1
17652 IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1
17653 IF(tha.LT.ckin(35)) mint(51)=1
17654 IF(ckin(36).GE.0d0.AND.tha.GT.ckin(36)) mint(51)=1
17655 IF(uha.LT.ckin(37)) mint(51)=1
17656 IF(ckin(38).GE.0d0.AND.uha.GT.ckin(38)) mint(51)=1
17657 ENDIF
17658 IF(istsb.GE.3.AND.istsb.LE.5) THEN
17659 IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1
17660 IF(ckin(32).GE.0d0.AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1
17661 ENDIF
17662
17663C...Additional cuts on W2 (approximately) in DIS.
17664 IF(isub.EQ.10.AND.mint(43).GE.2) THEN
17665 xbj=x2
17666 IF(iabs(mint(12)).LT.20) xbj=x1
17667 q2bj=tha
17668 w2bj=q2bj*(1d0-xbj)/xbj
17669 IF(w2bj.LT.ckin(39)) mint(51)=1
17670 IF(ckin(40).GT.0d0.AND.w2bj.GT.ckin(40)) mint(51)=1
17671 ENDIF
17672
17673 ELSEIF(ilim.EQ.1) THEN
17674C...Calculate limits on tau
17675C...0) due to definition
17676 taumn0=0d0
17677 taumx0=1d0
17678C...1) due to limits on subsystem mass
17679 taumn1=ckin(1)**2/vint(2)
17680 taumx1=1d0
17681 IF(ckin(2).GE.0d0) taumx1=ckin(2)**2/vint(2)
17682C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
17683 tm3=sqrt(sqm3+pthmin**2)
17684 tm4=sqrt(sqm4+pthmin**2)
17685 ydcosh=1d0
17686 IF(ckin09.GT.ckin12) ydcosh=cosh(ckin09-ckin12)
17687 taumn2=(tm3**2+2d0*tm3*tm4*ydcosh+tm4**2)/vint(2)
17688 taumx2=1d0
17689C...3) due to limits on pT-hat and cos(theta-hat)
17690 cth2mn=min(ckin(27)**2,ckin(28)**2)
17691 cth2mx=max(ckin(27)**2,ckin(28)**2)
17692 taumn3=0d0
17693 IF(ckin(27)*ckin(28).GT.0d0) taumn3=
17694 & (sqrt(sqm3+pthmin**2/(1d0-cth2mn))+
17695 & sqrt(sqm4+pthmin**2/(1d0-cth2mn)))**2/vint(2)
17696 taumx3=1d0
17697 IF(ckin(4).GE.0d0.AND.cth2mx.LT.1d0) taumx3=
17698 & (sqrt(sqm3+ckin(4)**2/(1d0-cth2mx))+
17699 & sqrt(sqm4+ckin(4)**2/(1d0-cth2mx)))**2/vint(2)
17700C...4) due to limits on x1 and x2
17701 taumn4=ckin(21)*ckin(23)
17702 taumx4=ckin(22)*ckin(24)
17703C...5) due to limits on xF
17704 taumn5=0d0
17705 taumx5=max(1d0-ckin(25),1d0+ckin(26))
17706C...6) due to limits on that and uhat
17707 taumn6=(sqm3+sqm4+ckin(35)+ckin(37))/vint(2)
17708 taumx6=1d0
17709 IF(ckin(36).GT.0d0.AND.ckin(38).GT.0d0) taumx6=
17710 & (sqm3+sqm4+ckin(36)+ckin(38))/vint(2)
17711
17712C...Net effect of all separate limits.
17713 vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5,taumn6)
17714 vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5,taumx6)
17715 IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
17716 vint(11)=1d0-1d-9
17717 vint(31)=1d0+1d-9
17718 ELSEIF(mint(47).EQ.5) THEN
17719 vint(31)=min(vint(31),1d0-2d-10)
17720 ELSEIF(mint(47).GE.6) THEN
17721 vint(31)=min(vint(31),1d0-1d-10)
17722 ENDIF
17723 IF(vint(31).LE.vint(11)) mint(51)=1
17724
17725 ELSEIF(ilim.EQ.2) THEN
17726C...Calculate limits on y*
17727 taue=tau
17728 IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
17729 taurt=sqrt(taue)
17730C...0) due to kinematics
17731 ystmn0=log(taurt)
17732 ystmx0=-ystmn0
17733C...1) due to explicit limits
17734 ystmn1=ckin(7)
17735 ystmx1=ckin(8)
17736C...2) due to limits on x1
17737 ystmn2=log(max(taue,ckin(21))/taurt)
17738 ystmx2=log(max(taue,ckin(22))/taurt)
17739C...3) due to limits on x2
17740 ystmn3=-log(max(taue,ckin(24))/taurt)
17741 ystmx3=-log(max(taue,ckin(23))/taurt)
17742C...4) due to limits on xF
17743 yepmn4=0.5d0*abs(ckin(25))/taurt
17744 ystmn4=sign(log(max(1d-20,sqrt(1d0+yepmn4**2)+yepmn4)),ckin(25))
17745 yepmx4=0.5d0*abs(ckin(26))/taurt
17746 ystmx4=sign(log(max(1d-20,sqrt(1d0+yepmx4**2)+yepmx4)),ckin(26))
17747C...5) due to simultaneous limits on y-large and y-small
17748 yepsmn=(rm3-rm4)*sinh(ckin09-ckin11)
17749 yepsmx=(rm3-rm4)*sinh(ckin10-ckin12)
17750 ydifmn=abs(log(max(1d-20,sqrt(1d0+yepsmn**2)-yepsmn)))
17751 ydifmx=abs(log(max(1d-20,sqrt(1d0+yepsmx**2)-yepsmx)))
17752 ystmn5=0.5d0*(ckin09+ckin11-ydifmn)
17753 ystmx5=0.5d0*(ckin10+ckin12+ydifmx)
17754C...6) due to simultaneous limits on cos(theta-hat) and y-large or
17755C... y-small
17756 cthlim=sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*taue*vint(2))))
17757 rzmn=be34*max(ckin(27),-cthlim)
17758 rzmx=be34*min(ckin(28),cthlim)
17759 yex3mx=(1d0+rm3-rm4+rzmx)/max(1d-10,1d0+rm3-rm4-rzmx)
17760 yex4mx=(1d0+rm4-rm3-rzmn)/max(1d-10,1d0+rm4-rm3+rzmn)
17761 yex3mn=max(1d-10,1d0+rm3-rm4+rzmn)/(1d0+rm3-rm4-rzmn)
17762 yex4mn=max(1d-10,1d0+rm4-rm3-rzmx)/(1d0+rm4-rm3+rzmx)
17763 ystmn6=ckin09-0.5d0*log(max(yex3mx,yex4mx))
17764 ystmx6=ckin12-0.5d0*log(min(yex3mn,yex4mn))
17765
17766C...Net effect of all separate limits.
17767 vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)
17768 vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)
17769 IF(mint(47).EQ.1) THEN
17770 vint(12)=-1d-9
17771 vint(32)=1d-9
17772 ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
17773 vint(12)=(1d0-1d-9)*ystmx0
17774 vint(32)=(1d0+1d-9)*ystmx0
17775 ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
17776 vint(12)=-(1d0+1d-9)*ystmx0
17777 vint(32)=-(1d0-1d-9)*ystmx0
17778 ELSEIF(mint(47).EQ.5) THEN
17779 ystee=log((1d0-1d-10)/taurt)
17780 vint(12)=max(vint(12),-ystee)
17781 vint(32)=min(vint(32),ystee)
17782 ENDIF
17783 IF(vint(32).LE.vint(12)) mint(51)=1
17784
17785 ELSEIF(ilim.EQ.3) THEN
17786C...Calculate limits on cos(theta-hat)
17787 yst=vint(22)
17788C...0) due to definition
17789 ctnmn0=-1d0
17790 ctnmx0=0d0
17791 ctpmn0=0d0
17792 ctpmx0=1d0
17793C...1) due to explicit limits
17794 ctnmn1=min(0d0,ckin(27))
17795 ctnmx1=min(0d0,ckin(28))
17796 ctpmn1=max(0d0,ckin(27))
17797 ctpmx1=max(0d0,ckin(28))
17798C...2) due to limits on pT-hat
17799 ctnmn2=-sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*tau*vint(2))))
17800 ctpmx2=-ctnmn2
17801 ctnmx2=0d0
17802 ctpmn2=0d0
17803 IF(ckin(4).GE.0d0) THEN
17804 ctnmx2=-sqrt(max(0d0,1d0-4d0*ckin(4)**2/
17805 & (be34**2*tau*vint(2))))
17806 ctpmn2=-ctnmx2
17807 ENDIF
17808C...3) due to limits on y-large and y-small
17809 ctnmn3=min(0d0,max((1d0+rm3-rm4)/be34*tanh(ckin11-yst),
17810 & -(1d0-rm3+rm4)/be34*tanh(ckin10-yst)))
17811 ctnmx3=min(0d0,(1d0+rm3-rm4)/be34*tanh(ckin12-yst),
17812 & -(1d0-rm3+rm4)/be34*tanh(ckin09-yst))
17813 ctpmn3=max(0d0,(1d0+rm3-rm4)/be34*tanh(ckin09-yst),
17814 & -(1d0-rm3+rm4)/be34*tanh(ckin12-yst))
17815 ctpmx3=max(0d0,min((1d0+rm3-rm4)/be34*tanh(ckin10-yst),
17816 & -(1d0-rm3+rm4)/be34*tanh(ckin11-yst)))
17817C...4) due to limits on that
17818 ctnmn4=-1d0
17819 ctnmx4=0d0
17820 ctpmn4=0d0
17821 ctpmx4=1d0
17822 sh=tau*vint(2)
17823 IF(ckin(35).GT.0d0) THEN
17824 ctlim=(1d0-rm3-rm4-2d0*ckin(35)/sh)/be34
17825 IF(ctlim.GT.0d0) THEN
17826 ctpmx4=ctlim
17827 ELSE
17828 ctpmx4=0d0
17829 ctnmx4=ctlim
17830 ENDIF
17831 ENDIF
17832 IF(ckin(36).GT.0d0) THEN
17833 ctlim=(1d0-rm3-rm4-2d0*ckin(36)/sh)/be34
17834 IF(ctlim.LT.0d0) THEN
17835 ctnmn4=ctlim
17836 ELSE
17837 ctnmn4=0d0
17838 ctpmn4=ctlim
17839 ENDIF
17840 ENDIF
17841C...5) due to limits on uhat
17842 ctnmn5=-1d0
17843 ctnmx5=0d0
17844 ctpmn5=0d0
17845 ctpmx5=1d0
17846 IF(ckin(37).GT.0d0) THEN
17847 ctlim=(2d0*ckin(37)/sh-(1d0-rm3-rm4))/be34
17848 IF(ctlim.LT.0d0) THEN
17849 ctnmn5=ctlim
17850 ELSE
17851 ctnmn5=0d0
17852 ctpmn5=ctlim
17853 ENDIF
17854 ENDIF
17855 IF(ckin(38).GT.0d0) THEN
17856 ctlim=(2d0*ckin(38)/sh-(1d0-rm3-rm4))/be34
17857 IF(ctlim.GT.0d0) THEN
17858 ctpmx5=ctlim
17859 ELSE
17860 ctpmx5=0d0
17861 ctnmx5=ctlim
17862 ENDIF
17863 ENDIF
17864
17865C...Net effect of all separate limits.
17866 vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3,ctnmn4,ctnmn5)
17867 vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3,ctnmx4,ctnmx5)
17868 vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3,ctpmn4,ctpmn5)
17869 vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3,ctpmx4,ctpmx5)
17870 IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1
17871
17872 ELSEIF(ilim.EQ.4) THEN
17873C...Calculate limits on tau'
17874C...0) due to kinematics
17875 tapmn0=tau
17876 IF(istsb.EQ.5.AND.kfpr(isub,2).GT.0) THEN
17877 pqrat=2d0*pmas(pycomp(kfpr(isub,2)),1)/vint(1)
17878 tapmn0=(sqrt(tau)+pqrat)**2
17879 ENDIF
17880 tapmx0=1d0
17881C...1) due to explicit limits
17882 tapmn1=ckin(31)**2/vint(2)
17883 tapmx1=1d0
17884 IF(ckin(32).GE.0d0) tapmx1=ckin(32)**2/vint(2)
17885
17886C...Net effect of all separate limits.
17887 vint(16)=max(tapmn0,tapmn1)
17888 vint(36)=min(tapmx0,tapmx1)
17889 IF(mint(47).EQ.1) THEN
17890 vint(16)=1d0-1d-9
17891 vint(36)=1d0+1d-9
17892 ELSEIF(mint(47).EQ.5) THEN
17893 vint(36)=min(vint(36),1d0-2d-10)
17894 ELSEIF(mint(47).EQ.6.OR.mint(47).EQ.7) THEN
17895 vint(36)=min(vint(36),1d0-1d-10)
17896 ENDIF
17897 IF(vint(36).LE.vint(16)) mint(51)=1
17898
17899 ENDIF
17900 RETURN
17901
17902C...Special case for low-pT and multiple interactions:
17903C...effective kinematical limits for tau, y*, cos(theta-hat).
17904 100 IF(ilim.EQ.0) THEN
17905 ELSEIF(ilim.EQ.1) THEN
17906 IF(mstp(82).LE.1) THEN
17907 vint(11)=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
17908 & vint(2)
17909 ELSE
17910 vint(11)=(parp(82)*(vint(1)/parp(89))**parp(90))**2/vint(2)
17911 ENDIF
17912 vint(31)=1d0
17913 ELSEIF(ilim.EQ.2) THEN
17914 vint(12)=0.5d0*log(vint(21))
17915 vint(32)=-vint(12)
17916 ELSEIF(ilim.EQ.3) THEN
17917 IF(mstp(82).LE.1) THEN
17918 st2eff=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
17919 & (vint(21)*vint(2))
17920 ELSE
17921 st2eff=0.01d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
17922 & (vint(21)*vint(2))
17923 ENDIF
17924 vint(13)=-sqrt(max(0d0,1d0-st2eff))
17925 vint(33)=0d0
17926 vint(14)=0d0
17927 vint(34)=-vint(13)
17928 ENDIF
17929
17930 RETURN
17931 END
17932
17933C*********************************************************************
17934
17935C...PYKMAP
17936C...Maps a uniform distribution into a distribution of a kinematical
17937C...variable according to one of the possibilities allowed. It is
17938C...assumed that kinematical limits have been set by a PYKLIM call.
17939
17940 SUBROUTINE pykmap(IVAR,MVAR,VVAR)
17941
17942C...Double precision and integer declarations.
17943 IMPLICIT DOUBLE PRECISION(a-h, o-z)
17944 IMPLICIT INTEGER(I-N)
17945 INTEGER PYK,PYCHGE,PYCOMP
17946C...Commonblocks.
17947 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
17948 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
17949 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
17950 common/pypars/mstp(200),parp(200),msti(200),pari(200)
17951 common/pyint1/mint(400),vint(400)
17952 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
17953 SAVE /pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,/pyint2/
17954
17955C...Convert VVAR to tau variable.
17956 isub=mint(1)
17957 istsb=iset(isub)
17958 IF(ivar.EQ.1) THEN
17959 taumin=vint(11)
17960 taumax=vint(31)
17961 IF(mvar.EQ.3.OR.mvar.EQ.4) THEN
17962 taure=vint(73)
17963 gamre=vint(74)
17964 ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN
17965 taure=vint(75)
17966 gamre=vint(76)
17967 ENDIF
17968 IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
17969 tau=1d0
17970 ELSEIF(mvar.EQ.1) THEN
17971 tau=taumin*(taumax/taumin)**vvar
17972 ELSEIF(mvar.EQ.2) THEN
17973 tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)
17974 ELSEIF(mvar.EQ.3.OR.mvar.EQ.5) THEN
17975 ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax
17976 tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)
17977 ELSEIF(mvar.EQ.4.OR.mvar.EQ.6) THEN
17978 aupp=atan((taumax-taure)/gamre)
17979 alow=atan((taumin-taure)/gamre)
17980 tau=taure+gamre*tan(alow+(aupp-alow)*vvar)
17981 ELSEIF(mint(47).EQ.5) THEN
17982 aupp=log(max(2d-10,1d0-taumax))
17983 alow=log(max(2d-10,1d0-taumin))
17984 tau=1d0-exp(aupp+vvar*(alow-aupp))
17985 ELSE
17986 aupp=log(max(1d-10,1d0-taumax))
17987 alow=log(max(1d-10,1d0-taumin))
17988 tau=1d0-exp(aupp+vvar*(alow-aupp))
17989 ENDIF
17990 vint(21)=min(taumax,max(taumin,tau))
17991
17992C...Convert VVAR to y* variable.
17993 ELSEIF(ivar.EQ.2) THEN
17994 ystmin=vint(12)
17995 ystmax=vint(32)
17996 taue=vint(21)
17997 IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
17998 IF(mint(47).EQ.1) THEN
17999 yst=0d0
18000 ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
18001 yst=-0.5d0*log(taue)
18002 ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
18003 yst=0.5d0*log(taue)
18004 ELSEIF(mvar.EQ.1) THEN
18005 yst=ystmin+(ystmax-ystmin)*sqrt(vvar)
18006 ELSEIF(mvar.EQ.2) THEN
18007 yst=ystmax-(ystmax-ystmin)*sqrt(1d0-vvar)
18008 ELSEIF(mvar.EQ.3) THEN
18009 aupp=atan(exp(ystmax))
18010 alow=atan(exp(ystmin))
18011 yst=log(tan(alow+(aupp-alow)*vvar))
18012 ELSEIF(mvar.EQ.4) THEN
18013 yst0=-0.5d0*log(taue)
18014 aupp=log(max(1d-10,exp(yst0-ystmin)-1d0))
18015 alow=log(max(1d-10,exp(yst0-ystmax)-1d0))
18016 yst=yst0-log(1d0+exp(alow+vvar*(aupp-alow)))
18017 ELSE
18018 yst0=-0.5d0*log(taue)
18019 aupp=log(max(1d-10,exp(yst0+ystmin)-1d0))
18020 alow=log(max(1d-10,exp(yst0+ystmax)-1d0))
18021 yst=log(1d0+exp(aupp+vvar*(alow-aupp)))-yst0
18022 ENDIF
18023 vint(22)=min(ystmax,max(ystmin,yst))
18024
18025C...Convert VVAR to cos(theta-hat) variable.
18026 ELSEIF(ivar.EQ.3) THEN
18027 rm34=max(1d-20,2d0*vint(63)*vint(64)/(vint(21)*vint(2))**2)
18028 rsqm=1d0+rm34
18029 IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
18030 & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
18031 ctnmin=vint(13)
18032 ctnmax=vint(33)
18033 ctpmin=vint(14)
18034 ctpmax=vint(34)
18035 IF(mvar.EQ.1) THEN
18036 aneg=ctnmax-ctnmin
18037 apos=ctpmax-ctpmin
18038 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
18039 vctn=vvar*(aneg+apos)/aneg
18040 cth=ctnmin+(ctnmax-ctnmin)*vctn
18041 ELSE
18042 vctp=(vvar*(aneg+apos)-aneg)/apos
18043 cth=ctpmin+(ctpmax-ctpmin)*vctp
18044 ENDIF
18045 ELSEIF(mvar.EQ.2) THEN
18046 rmnmin=max(rm34,rsqm-ctnmin)
18047 rmnmax=max(rm34,rsqm-ctnmax)
18048 rmpmin=max(rm34,rsqm-ctpmin)
18049 rmpmax=max(rm34,rsqm-ctpmax)
18050 aneg=log(rmnmin/rmnmax)
18051 apos=log(rmpmin/rmpmax)
18052 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
18053 vctn=vvar*(aneg+apos)/aneg
18054 cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn
18055 ELSE
18056 vctp=(vvar*(aneg+apos)-aneg)/apos
18057 cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp
18058 ENDIF
18059 ELSEIF(mvar.EQ.3) THEN
18060 rmnmin=max(rm34,rsqm+ctnmin)
18061 rmnmax=max(rm34,rsqm+ctnmax)
18062 rmpmin=max(rm34,rsqm+ctpmin)
18063 rmpmax=max(rm34,rsqm+ctpmax)
18064 aneg=log(rmnmax/rmnmin)
18065 apos=log(rmpmax/rmpmin)
18066 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
18067 vctn=vvar*(aneg+apos)/aneg
18068 cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm
18069 ELSE
18070 vctp=(vvar*(aneg+apos)-aneg)/apos
18071 cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm
18072 ENDIF
18073 ELSEIF(mvar.EQ.4) THEN
18074 rmnmin=max(rm34,rsqm-ctnmin)
18075 rmnmax=max(rm34,rsqm-ctnmax)
18076 rmpmin=max(rm34,rsqm-ctpmin)
18077 rmpmax=max(rm34,rsqm-ctpmax)
18078 aneg=1d0/rmnmax-1d0/rmnmin
18079 apos=1d0/rmpmax-1d0/rmpmin
18080 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
18081 vctn=vvar*(aneg+apos)/aneg
18082 cth=rsqm-1d0/(1d0/rmnmin+aneg*vctn)
18083 ELSE
18084 vctp=(vvar*(aneg+apos)-aneg)/apos
18085 cth=rsqm-1d0/(1d0/rmpmin+apos*vctp)
18086 ENDIF
18087 ELSEIF(mvar.EQ.5) THEN
18088 rmnmin=max(rm34,rsqm+ctnmin)
18089 rmnmax=max(rm34,rsqm+ctnmax)
18090 rmpmin=max(rm34,rsqm+ctpmin)
18091 rmpmax=max(rm34,rsqm+ctpmax)
18092 aneg=1d0/rmnmin-1d0/rmnmax
18093 apos=1d0/rmpmin-1d0/rmpmax
18094 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
18095 vctn=vvar*(aneg+apos)/aneg
18096 cth=1d0/(1d0/rmnmin-aneg*vctn)-rsqm
18097 ELSE
18098 vctp=(vvar*(aneg+apos)-aneg)/apos
18099 cth=1d0/(1d0/rmpmin-apos*vctp)-rsqm
18100 ENDIF
18101 ENDIF
18102 IF(cth.LT.0d0) cth=min(ctnmax,max(ctnmin,cth))
18103 IF(cth.GT.0d0) cth=min(ctpmax,max(ctpmin,cth))
18104 vint(23)=cth
18105
18106C...Convert VVAR to tau' variable.
18107 ELSEIF(ivar.EQ.4) THEN
18108 tau=vint(21)
18109 taupmn=vint(16)
18110 taupmx=vint(36)
18111 IF(mint(47).EQ.1) THEN
18112 taup=1d0
18113 ELSEIF(mvar.EQ.1) THEN
18114 taup=taupmn*(taupmx/taupmn)**vvar
18115 ELSEIF(mvar.EQ.2) THEN
18116 aupp=(1d0-tau/taupmx)**4
18117 alow=(1d0-tau/taupmn)**4
18118 taup=tau/max(1d-10,1d0-(alow+(aupp-alow)*vvar)**0.25d0)
18119 ELSEIF(mint(47).EQ.5) THEN
18120 aupp=log(max(2d-10,1d0-taupmx))
18121 alow=log(max(2d-10,1d0-taupmn))
18122 taup=1d0-exp(aupp+vvar*(alow-aupp))
18123 ELSE
18124 aupp=log(max(1d-10,1d0-taupmx))
18125 alow=log(max(1d-10,1d0-taupmn))
18126 taup=1d0-exp(aupp+vvar*(alow-aupp))
18127 ENDIF
18128 vint(26)=min(taupmx,max(taupmn,taup))
18129
18130C...Selection of extra variables needed in 2 -> 3 process:
18131C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
18132C...Since no options are available, the functions of PYKLIM
18133C...and PYKMAP are joint for these choices.
18134 ELSEIF(ivar.EQ.5) THEN
18135
18136C...Read out total energy and particle masses.
18137 mint(51)=0
18138 mptpk=1
18139 IF(isub.EQ.123.OR.isub.EQ.124.OR.isub.EQ.173.OR.isub.EQ.174
18140 & .OR.isub.EQ.178.OR.isub.EQ.179.OR.isub.EQ.351.OR.isub.EQ.352)
18141 & mptpk=2
18142 shp=vint(26)*vint(2)
18143 shpr=sqrt(shp)
18144 pm1=vint(201)
18145 pm2=vint(206)
18146 pm3=sqrt(vint(21))*vint(1)
18147 IF(pm1+pm2+pm3.GT.0.9999d0*shpr) THEN
18148 mint(51)=1
18149 RETURN
18150 ENDIF
18151 pmrs1=vint(204)**2
18152 pmrs2=vint(209)**2
18153
18154C...Specify coefficients of pT choice; upper and lower limits.
18155 IF(mptpk.EQ.1) THEN
18156 hwt1=0.4d0
18157 hwt2=0.4d0
18158 ELSE
18159 hwt1=0.05d0
18160 hwt2=0.05d0
18161 ENDIF
18162 hwt3=1d0-hwt1-hwt2
18163 ptsmx1=((shp-pm1**2-(pm2+pm3)**2)**2-(2d0*pm1*(pm2+pm3))**2)/
18164 & (4d0*shp)
18165 IF(ckin(52).GT.0d0) ptsmx1=min(ptsmx1,ckin(52)**2)
18166 ptsmn1=ckin(51)**2
18167 ptsmx2=((shp-pm2**2-(pm1+pm3)**2)**2-(2d0*pm2*(pm1+pm3))**2)/
18168 & (4d0*shp)
18169 IF(ckin(54).GT.0d0) ptsmx2=min(ptsmx2,ckin(54)**2)
18170 ptsmn2=ckin(53)**2
18171
18172C...Select transverse momenta according to
18173C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
18174 hmx=pmrs1+ptsmx1
18175 hmn=pmrs1+ptsmn1
18176 IF(hmx.LT.1.0001d0*hmn) THEN
18177 mint(51)=1
18178 RETURN
18179 ENDIF
18180 hde=ptsmx1-ptsmn1
18181 rpt=pyr(0)
18182 IF(rpt.LT.hwt1) THEN
18183 pts1=ptsmn1+pyr(0)*hde
18184 ELSEIF(rpt.LT.hwt1+hwt2) THEN
18185 pts1=max(ptsmn1,hmn*(hmx/hmn)**pyr(0)-pmrs1)
18186 ELSE
18187 pts1=max(ptsmn1,hmn*hmx/(hmn+pyr(0)*hde)-pmrs1)
18188 ENDIF
18189 wtpts1=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs1+pts1))+
18190 & hwt3*hmn*hmx/(pmrs1+pts1)**2)
18191 hmx=pmrs2+ptsmx2
18192 hmn=pmrs2+ptsmn2
18193 IF(hmx.LT.1.0001d0*hmn) THEN
18194 mint(51)=1
18195 RETURN
18196 ENDIF
18197 hde=ptsmx2-ptsmn2
18198 rpt=pyr(0)
18199 IF(rpt.LT.hwt1) THEN
18200 pts2=ptsmn2+pyr(0)*hde
18201 ELSEIF(rpt.LT.hwt1+hwt2) THEN
18202 pts2=max(ptsmn2,hmn*(hmx/hmn)**pyr(0)-pmrs2)
18203 ELSE
18204 pts2=max(ptsmn2,hmn*hmx/(hmn+pyr(0)*hde)-pmrs2)
18205 ENDIF
18206 wtpts2=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs2+pts2))+
18207 & hwt3*hmn*hmx/(pmrs2+pts2)**2)
18208
18209C...Select azimuthal angles and check pT choice.
18210 phi1=paru(2)*pyr(0)
18211 phi2=paru(2)*pyr(0)
18212 phir=phi2-phi1
18213 pts3=max(0d0,pts1+pts2+2d0*sqrt(pts1*pts2)*cos(phir))
18214 IF(pts3.LT.ckin(55)**2.OR.(ckin(56).GT.0d0.AND.pts3.GT.
18215 & ckin(56)**2)) THEN
18216 mint(51)=1
18217 RETURN
18218 ENDIF
18219
18220C...Calculate transverse masses and check phase space not closed.
18221 pms1=pm1**2+pts1
18222 pms2=pm2**2+pts2
18223 pms3=pm3**2+pts3
18224 pmt1=sqrt(pms1)
18225 pmt2=sqrt(pms2)
18226 pmt3=sqrt(pms3)
18227 pm12=(pmt1+pmt2)**2
18228 IF(pmt1+pmt2+pmt3.GT.0.9999d0*shpr) THEN
18229 mint(51)=1
18230 RETURN
18231 ENDIF
18232
18233C...Select rapidity for particle 3 and check phase space not closed.
18234 y3max=log((shp+pms3-pm12+sqrt(max(0d0,(shp-pms3-pm12)**2-
18235 & 4d0*pms3*pm12)))/(2d0*shpr*pmt3))
18236 IF(y3max.LT.1d-6) THEN
18237 mint(51)=1
18238 RETURN
18239 ENDIF
18240 y3=(2d0*pyr(0)-1d0)*0.999999d0*y3max
18241 pz3=pmt3*sinh(y3)
18242 pe3=pmt3*cosh(y3)
18243
18244C...Find momentum transfers in two mirror solutions (in 1-2 frame).
18245 pz12=-pz3
18246 pe12=shpr-pe3
18247 pms12=pe12**2-pz12**2
18248 sql12=sqrt(max(0d0,(pms12-pms1-pms2)**2-4d0*pms1*pms2))
18249 IF(sql12.LT.1d-6*shp) THEN
18250 mint(51)=1
18251 RETURN
18252 ENDIF
18253 pmm1=pms12+pms1-pms2
18254 pmm2=pms12+pms2-pms1
18255 tfac=-shpr/(2d0*pms12)
18256 t1p=tfac*(pe12-pz12)*(pmm1-sql12)
18257 t1n=tfac*(pe12-pz12)*(pmm1+sql12)
18258 t2p=tfac*(pe12+pz12)*(pmm2-sql12)
18259 t2n=tfac*(pe12+pz12)*(pmm2+sql12)
18260
18261C...Construct relative mirror weights and make choice.
18262 IF(mptpk.EQ.1.OR.isub.EQ.351.OR.isub.EQ.352) THEN
18263 wtpu=1d0
18264 wtnu=1d0
18265 ELSE
18266 wtpu=1d0/((t1p-pmrs1)*(t2p-pmrs2))**2
18267 wtnu=1d0/((t1n-pmrs1)*(t2n-pmrs2))**2
18268 ENDIF
18269 wtp=wtpu/(wtpu+wtnu)
18270 wtn=wtnu/(wtpu+wtnu)
18271 eps=1d0
18272 IF(wtn.GT.pyr(0)) eps=-1d0
18273
18274C...Store result of variable choice and associated weights.
18275 vint(202)=pts1
18276 vint(207)=pts2
18277 vint(203)=phi1
18278 vint(208)=phi2
18279 vint(205)=wtpts1
18280 vint(210)=wtpts2
18281 vint(211)=y3
18282 vint(212)=y3max
18283 vint(213)=eps
18284 IF(eps.GT.0d0) THEN
18285 vint(214)=1d0/wtp
18286 vint(215)=t1p
18287 vint(216)=t2p
18288 ELSE
18289 vint(214)=1d0/wtn
18290 vint(215)=t1n
18291 vint(216)=t2n
18292 ENDIF
18293 vint(217)=-0.5d0*tfac*(pe12-pz12)*(pmm2+eps*sql12)
18294 vint(218)=-0.5d0*tfac*(pe12+pz12)*(pmm1+eps*sql12)
18295 vint(219)=0.5d0*(pms12-pts3)
18296 vint(220)=sql12
18297 ENDIF
18298
18299 RETURN
18300 END
18301
18302C***********************************************************************
18303
18304C...PYSIGH
18305C...Differential matrix elements for all included subprocesses
18306C...Note that what is coded is (disregarding the COMFAC factor)
18307C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
18308C...when d(sigma-hat) is given in the zero-width limit, the delta
18309C...function in tau is replaced by a (modified) Breit-Wigner:
18310C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
18311C...where H_res = s-hat/m_res*Gamma_res(s-hat);
18312C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
18313C...i.e., dimensionless quantities
18314C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
18315C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
18316C...(2pi)^4 delta^4(P - sum p_i)
18317C...COMFAC contains the factor pi/s (or equivalent) and
18318C...the conversion factor from GeV^-2 to mb
18319
18320 SUBROUTINE pysigh(NCHN,SIGS)
18321
18322C...Double precision and integer declarations
18323 IMPLICIT DOUBLE PRECISION(a-h, o-z)
18324 IMPLICIT INTEGER(I-N)
18325 INTEGER PYK,PYCHGE,PYCOMP
18326C...Parameter statement to help give large particle numbers.
18327 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
18328C...Commonblocks
18329 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
18330 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
18331 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
18332 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
18333 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
18334 common/pypars/mstp(200),parp(200),msti(200),pari(200)
18335 common/pyint1/mint(400),vint(400)
18336 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
18337 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
18338 common/pyint4/mwid(500),wids(500,5)
18339 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
18340 common/pyint7/sigt(0:6,0:6,0:5)
18341 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
18342 &sfmix(16,4)
18343 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
18344 &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,
18345 &/pyssmt/
18346C...Local arrays and complex variables
18347 dimension x(2),xpq(-25:25),kfac(2,-40:40),wdtp(0:200),
18348 &wdte(0:200,0:5),hgz(6,3),hl3(3),hr3(3),hl4(3),hr4(3)
18349 COMPLEX A004,A204,A114,A00U,A20U,A11U
18350 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
18351 &COULCK,COULCP,COULCD,COULCR,COULCS
18352 REAL A00L,A11L,A20L,COULXX
18353 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME,
18354 &DAA,DZZ,DAZ
18355
18356C...Reset number of channels and cross-section
18357 nchn=0
18358 sigs=0d0
18359
18360C...Convert H or A process into equivalent h one
18361 isub=mint(1)
18362 isubsv=isub
18363 ihigg=1
18364 kfhigg=25
18365 IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
18366 &isub.LE.190)) THEN
18367 ihigg=2
18368 IF(mod(isub-1,10).GE.5) ihigg=3
18369 kfhigg=33+ihigg
18370 IF(isub.EQ.151.OR.isub.EQ.156) isub=3
18371 IF(isub.EQ.152.OR.isub.EQ.157) isub=102
18372 IF(isub.EQ.153.OR.isub.EQ.158) isub=103
18373 IF(isub.EQ.171.OR.isub.EQ.176) isub=24
18374 IF(isub.EQ.172.OR.isub.EQ.177) isub=26
18375 IF(isub.EQ.173.OR.isub.EQ.178) isub=123
18376 IF(isub.EQ.174.OR.isub.EQ.179) isub=124
18377 IF(isub.EQ.181.OR.isub.EQ.186) isub=121
18378 IF(isub.EQ.182.OR.isub.EQ.187) isub=122
18379 ENDIF
18380
18381CMRENNA++
18382C...Convert almost equivalent SUSY processes into each other
18383C...Extract differences in flavours and couplings
18384 IF(isub.GE.200.AND.isub.LE.301) THEN
18385
18386C...Sleptons and sneutrinos
18387 IF(isub.EQ.201.OR.isub.EQ.204.OR.isub.EQ.207) THEN
18388 kfid=mod(kfpr(isub,1),ksusy1)
18389 isub=201
18390 ilr=0
18391 ELSEIF(isub.EQ.202.OR.isub.EQ.205.OR.isub.EQ.208) THEN
18392 kfid=mod(kfpr(isub,1),ksusy1)
18393 isub=201
18394 ilr=1
18395 ELSEIF(isub.EQ.203.OR.isub.EQ.206.OR.isub.EQ.209) THEN
18396 kfid=mod(kfpr(isub,1),ksusy1)
18397 isub=203
18398 ELSEIF(isub.GE.210.AND.isub.LE.212) THEN
18399 IF(isub.EQ.210) THEN
18400 rkf=2.0d0
18401 ELSEIF(isub.EQ.211) THEN
18402 rkf=sfmix(15,1)**2
18403 ELSEIF(isub.EQ.212) THEN
18404 rkf=sfmix(15,2)**2
18405 ENDIF
18406 isub=210
18407 ELSEIF(isub.EQ.213.OR.isub.EQ.214) THEN
18408 IF(isub.EQ.213) THEN
18409 kfid=mod(kfpr(isub,1),ksusy1)
18410 rkf=2.0d0
18411 ELSEIF(isub.EQ.214) THEN
18412 kfid=16
18413 rkf=1.0d0
18414 ENDIF
18415 isub=213
18416
18417C...Neutralinos
18418 ELSEIF(isub.GE.216.AND.isub.LE.225) THEN
18419 IF(isub.EQ.216) THEN
18420 izid1=1
18421 izid2=1
18422 ELSEIF(isub.EQ.217) THEN
18423 izid1=2
18424 izid2=2
18425 ELSEIF(isub.EQ.218) THEN
18426 izid1=3
18427 izid2=3
18428 ELSEIF(isub.EQ.219) THEN
18429 izid1=4
18430 izid2=4
18431 ELSEIF(isub.EQ.220) THEN
18432 izid1=1
18433 izid2=2
18434 ELSEIF(isub.EQ.221) THEN
18435 izid1=1
18436 izid2=3
18437 ELSEIF(isub.EQ.222) THEN
18438 izid1=1
18439 izid2=4
18440 ELSEIF(isub.EQ.223) THEN
18441 izid1=2
18442 izid2=3
18443 ELSEIF(isub.EQ.224) THEN
18444 izid1=2
18445 izid2=4
18446 ELSEIF(isub.EQ.225) THEN
18447 izid1=3
18448 izid2=4
18449 ENDIF
18450 isub=216
18451
18452C...Charginos
18453 ELSEIF(isub.GE.226.AND.isub.LE.228) THEN
18454 IF(isub.EQ.226) THEN
18455 izid1=1
18456 izid2=1
18457 ELSEIF(isub.EQ.227) THEN
18458 izid1=2
18459 izid2=2
18460 ELSEIF(isub.EQ.228) THEN
18461 izid1=1
18462 izid2=2
18463 ENDIF
18464 isub=226
18465
18466C...Neutralino + chargino
18467 ELSEIF(isub.GE.229.AND.isub.LE.236) THEN
18468 IF(isub.EQ.229) THEN
18469 izid1=1
18470 izid2=1
18471 ELSEIF(isub.EQ.230) THEN
18472 izid1=1
18473 izid2=2
18474 ELSEIF(isub.EQ.231) THEN
18475 izid1=1
18476 izid2=3
18477 ELSEIF(isub.EQ.232) THEN
18478 izid1=1
18479 izid2=4
18480 ELSEIF(isub.EQ.233) THEN
18481 izid1=2
18482 izid2=1
18483 ELSEIF(isub.EQ.234) THEN
18484 izid1=2
18485 izid2=2
18486 ELSEIF(isub.EQ.235) THEN
18487 izid1=2
18488 izid2=3
18489 ELSEIF(isub.EQ.236) THEN
18490 izid1=2
18491 izid2=4
18492 ENDIF
18493 isub=229
18494
18495C...Gluino + neutralino
18496 ELSEIF(isub.GE.237.AND.isub.LE.240) THEN
18497 IF(isub.EQ.237) THEN
18498 izid=1
18499 ELSEIF(isub.EQ.238) THEN
18500 izid=2
18501 ELSEIF(isub.EQ.239) THEN
18502 izid=3
18503 ELSEIF(isub.EQ.240) THEN
18504 izid=4
18505 ENDIF
18506 isub=237
18507
18508C...Gluino + chargino
18509 ELSEIF(isub.GE.241.AND.isub.LE.242) THEN
18510 IF(isub.EQ.241) THEN
18511 izid=1
18512 ELSEIF(isub.EQ.242) THEN
18513 izid=2
18514 ENDIF
18515 isub=241
18516
18517C...Squark + neutralino
18518 ELSEIF(isub.GE.246.AND.isub.LE.253) THEN
18519 ilr=0
18520 IF(mod(isub,2).NE.0) ilr=1
18521 IF(isub.LE.247) THEN
18522 izid=1
18523 ELSEIF(isub.LE.249) THEN
18524 izid=2
18525 ELSEIF(isub.LE.251) THEN
18526 izid=3
18527 ELSEIF(isub.LE.253) THEN
18528 izid=4
18529 ENDIF
18530 isub=246
18531 rkf=5d0
18532
18533C...Squark + chargino
18534 ELSEIF(isub.GE.254.AND.isub.LE.257) THEN
18535 IF(isub.LE.255) THEN
18536 izid=1
18537 ELSEIF(isub.LE.257) THEN
18538 izid=2
18539 ENDIF
18540 IF(mod(isub,2).EQ.0) THEN
18541 ilr=0
18542 ELSE
18543 ilr=1
18544 ENDIF
18545 isub=254
18546 rkf=5d0
18547
18548C...Squark + gluino
18549 ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN
18550 isub=258
18551 rkf=4d0
18552
18553C...Stops
18554 ELSEIF(isub.EQ.261.OR.isub.EQ.262) THEN
18555 ilr=0
18556 IF(isub.EQ.262) ilr=1
18557 isub=261
18558 ELSEIF(isub.EQ.265) THEN
18559 isub=264
18560
18561C...Squarks
18562 ELSEIF(isub.GE.271.AND.isub.LE.280) THEN
18563 ilr=0
18564 IF(isub.LE.273) THEN
18565 IF(isub.EQ.273) ilr=1
18566 isub=271
18567 rkf=16d0
18568 ELSEIF(isub.LE.276) THEN
18569 IF(isub.EQ.276) ilr=1
18570 isub=274
18571 rkf=16d0
18572 ELSEIF(isub.LE.278) THEN
18573 IF(isub.EQ.278) ilr=1
18574 isub=277
18575 rkf=4d0
18576 ELSE
18577 IF(isub.EQ.280) ilr=1
18578 isub=279
18579 rkf=4d0
18580 ENDIF
18581C...Sbottoms
18582 ELSEIF(isub.GE.281.AND.isub.LE.296) THEN
18583 ilr=0
18584 IF(isub.LE.283) THEN
18585 IF(isub.EQ.283) ilr=1
18586 isub=271
18587 rkf=4d0
18588 ELSEIF(isub.LE.286) THEN
18589 IF(isub.EQ.286) ilr=1
18590 isub=274
18591 rkf=4d0
18592 ELSEIF(isub.LE.288) THEN
18593 IF(isub.EQ.288) ilr=1
18594 isub=277
18595 rkf=1d0
18596 ELSEIF(isub.LE.290) THEN
18597 IF(isub.EQ.290) ilr=1
18598 isub=279
18599 rkf=1d0
18600 ELSEIF(isub.LE.293) THEN
18601 IF(isub.EQ.293) ilr=1
18602 isub=271
18603 rkf=1d0
18604 ELSEIF(isub.EQ.296) THEN
18605 ilr=1
18606 isub=274
18607 rkf=1d0
18608C...Squark + gluino
18609 ELSEIF(isub.EQ.294.OR.isub.EQ.295) THEN
18610 isub=258
18611 rkf=1d0
18612 ENDIF
18613C...H+/- + H0
18614 ELSEIF(isub.EQ.297.OR.isub.EQ.298) THEN
18615 IF(isub.EQ.297) THEN
18616 rkf=.5d0*paru(195)**2
18617 ELSEIF(isub.EQ.298) THEN
18618 rkf=.5d0*(1d0-paru(195)**2)
18619 ENDIF
18620 isub=210
18621C...A0 + H0
18622 ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
18623 IF(isub.EQ.299) THEN
18624 rkf=paru(186)**2
18625 ELSEIF(isub.EQ.300) THEN
18626 rkf=paru(187)**2
18627 ENDIF
18628 isub=213
18629C...H+ + H-
18630 ELSEIF(isub.EQ.301) THEN
18631 kfid=37
18632 rkf=1d0
18633 isub=201
18634 ENDIF
18635 ELSEIF(isub.GE.361.AND.isub.LE.379) THEN
18636 sqtv=parj(172)**2
18637 sqta=parj(173)**2
18638 tanw=sqrt(paru(102)/(1d0-paru(102)))
18639 ct2w=(1d0-2d0*paru(102))/(2d0*paru(102)/tanw)
18640 csxi=cos(asin(parp(141)))
18641 csxip=cos(asin(parj(174)))
18642 qupd=2d0*parp(143)-1d0
18643C... rho_tech0 -> W_L W_L
18644 IF(isub.EQ.361) THEN
18645 kfa=24
18646 kfb=24
18647 cab2=parp(141)**4
18648C... rho_tech0 -> W_L pi_tech-
18649 ELSEIF(isub.EQ.362) THEN
18650 kfa=24
18651 kfb=52
18652 isub=361
18653 cab2=parp(141)**2*(1d0-parp(141)**2)
18654C... pi_tech pi_tech
18655 ELSEIF(isub.EQ.363) THEN
18656 kfa=52
18657 kfb=52
18658 isub=361
18659 cab2=(1d0-parp(141)**2)**2
18660C... rho_tech0/omega_tech -> gamma pi_tech
18661 ELSEIF(isub.EQ.364) THEN
18662 kfa=22
18663 kfb=51
18664 vogp=csxi
18665 vrgp=vogp*qupd
18666 aogp=0d0
18667 argp=0d0
18668C... gamma pi_tech'
18669 ELSEIF(isub.EQ.365) THEN
18670 kfa=22
18671 kfb=53
18672 isub=364
18673 vrgp=csxip
18674 vogp=vrgp*qupd
18675 aogp=0d0
18676 argp=0d0
18677C... Z pi_tech
18678 ELSEIF(isub.EQ.366) THEN
18679 kfa=23
18680 kfb=51
18681 isub=364
18682 vogp=csxi*ct2w
18683 vrgp=-qupd*csxi*tanw
18684 aogp=0d0
18685 argp=0d0
18686C... Z pi_tech'
18687 ELSEIF(isub.EQ.367) THEN
18688 kfa=23
18689 kfb=53
18690 isub=364
18691 vrgp=csxip*ct2w
18692 vogp=-qupd*csxip*tanw
18693 aogp=0d0
18694 argp=0d0
18695C... W_T pi_tech
18696 ELSEIF(isub.EQ.368) THEN
18697 kfa=24
18698 kfb=52
18699 isub=364
18700 vogp=csxi/(2d0*sqrt(paru(102)))
18701 vrgp=0d0
18702 aogp=0d0
18703 argp=-vogp
18704C... rho_tech+ -> W_L Z_L
18705 ELSEIF(isub.EQ.370) THEN
18706 kfa=24
18707 kfb=23
18708 cab2=parp(141)**4
18709C... W_L pi_tech0
18710 ELSEIF(isub.EQ.371) THEN
18711 kfa=24
18712 kfb=51
18713 isub=370
18714 cab2=parp(141)**2*(1d0-parp(141)**2)
18715C... Z_L pi_tech+
18716 ELSEIF(isub.EQ.372) THEN
18717 kfa=52
18718 kfb=23
18719 isub=370
18720 cab2=parp(141)**2*(1d0-parp(141)**2)
18721C... pi_tech+ pi_tech0
18722 ELSEIF(isub.EQ.373) THEN
18723 kfa=52
18724 kfb=51
18725 isub=370
18726 cab2=(1d0-parp(141)**2)**2
18727C... gamma pi_tech+
18728 ELSEIF(isub.EQ.374) THEN
18729 kfa=52
18730 kfb=22
18731 vrgp=qupd*csxi
18732 argp=0d0
18733C... Z_T pi_tech+
18734 ELSEIF(isub.EQ.375) THEN
18735 kfa=52
18736 kfb=23
18737 isub=374
18738 vrgp=-qupd*csxi*tanw
18739 argp=csxi/(2d0*sqrt(paru(102)*(1d0-paru(102))))
18740C... W_T pi_tech0
18741 ELSEIF(isub.EQ.376) THEN
18742 kfa=24
18743 kfb=51
18744 isub=374
18745 vrgp=0d0
18746 argp=-csxi/(2d0*sqrt(paru(102)))
18747C... W_T pi_tech0'
18748 ELSEIF(isub.EQ.377) THEN
18749 kfa=24
18750 kfb=53
18751 isub=374
18752 argp=0d0
18753 vrgp=csxip/(2d0*sqrt(paru(102)))
18754 ENDIF
18755 ENDIF
18756CMRENNA--
18757
18758C...Read kinematical variables and limits
18759 istsb=iset(isubsv)
18760 taumin=vint(11)
18761 ystmin=vint(12)
18762 ctnmin=vint(13)
18763 ctpmin=vint(14)
18764 taupmn=vint(16)
18765 tau=vint(21)
18766 yst=vint(22)
18767 cth=vint(23)
18768 xt2=vint(25)
18769 taup=vint(26)
18770 taumax=vint(31)
18771 ystmax=vint(32)
18772 ctnmax=vint(33)
18773 ctpmax=vint(34)
18774 taupmx=vint(36)
18775
18776C...Derive kinematical quantities
18777 taue=tau
18778 IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
18779 x(1)=sqrt(taue)*exp(yst)
18780 x(2)=sqrt(taue)*exp(-yst)
18781 IF(mint(45).EQ.2.AND.istsb.GE.1) THEN
18782 IF(x(1).GT.1d0-1d-7) RETURN
18783 ELSEIF(mint(45).EQ.3) THEN
18784 x(1)=min(1d0-1.1d-10,x(1))
18785 ENDIF
18786 IF(mint(46).EQ.2.AND.istsb.GE.1) THEN
18787 IF(x(2).GT.1d0-1d-7) RETURN
18788 ELSEIF(mint(46).EQ.3) THEN
18789 x(2)=min(1d0-1.1d-10,x(2))
18790 ENDIF
18791 sh=max(1d0,tau*vint(2))
18792 sqm3=vint(63)
18793 sqm4=vint(64)
18794 rm3=sqm3/sh
18795 rm4=sqm4/sh
18796 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18797 rpts=4d0*vint(71)**2/sh
18798 be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
18799 rm34=max(1d-20,2d0*rm3*rm4)
18800 rsqm=1d0+rm34
18801 IF(2d0*vint(71)**2/max(1d0,vint(21)*vint(2)).LT.0.0001d0)
18802 &rm34=max(rm34,2d0*vint(71)**2/max(1d0,vint(21)*vint(2)))
18803 rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
18804 IF(istsb.EQ.0) THEN
18805 th=vint(45)
18806 uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
18807 sqpth=max(vint(71)**2,0.25d0*sh*be34**2*vint(59)**2)
18808 ELSE
18809C...Kinematics with incoming masses tricky: now depends on how
18810C...subprocess has been set up w.r.t. order of incoming partons.
18811 rm1=0d0
18812 IF(mint(15).EQ.22.AND.vint(3).LT.0d0) rm1=-vint(3)**2/sh
18813 rm2=0d0
18814 IF(mint(16).EQ.22.AND.vint(4).LT.0d0) rm2=-vint(4)**2/sh
18815 IF(isub.EQ.35) THEN
18816 rm2=min(rm1,rm2)
18817 rm1=0d0
18818 ENDIF
18819 be12=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
18820 tucom=(1d0-rm1-rm2)*(1d0-rm3-rm4)
18821 th=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm4-2d0*rm2*rm3-
18822 & be12*be34*cth)
18823 uh=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm3-2d0*rm2*rm4+
18824 & be12*be34*cth)
18825 sqpth=max(vint(71)**2,0.25d0*sh*be34**2*(1d0-cth**2))
18826 ENDIF
18827 shr=sqrt(sh)
18828 sh2=sh**2
18829 th2=th**2
18830 uh2=uh**2
18831
18832C...Choice of Q2 scale: hard, parton distributions, parton showers
18833 IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
18834 q2=sh
18835 ELSEIF(istsb.EQ.8) THEN
18836 IF(mint(107).EQ.4) q2=vint(307)
18837 IF(mint(108).EQ.4) q2=vint(308)
18838 ELSEIF(mod(istsb,2).EQ.0.OR.istsb.EQ.9) THEN
18839 q2in1=0d0
18840 IF(mint(11).EQ.22.AND.vint(3).LT.0d0) q2in1=vint(3)**2
18841 q2in2=0d0
18842 IF(mint(12).EQ.22.AND.vint(4).LT.0d0) q2in2=vint(4)**2
18843 IF(mstp(32).EQ.1) THEN
18844 q2=2d0*sh*th*uh/(sh**2+th**2+uh**2)
18845 ELSEIF(mstp(32).EQ.2) THEN
18846 q2=sqpth+0.5d0*(sqm3+sqm4)
18847 ELSEIF(mstp(32).EQ.3) THEN
18848 q2=min(-th,-uh)
18849 ELSEIF(mstp(32).EQ.4) THEN
18850 q2=sh
18851 ELSEIF(mstp(32).EQ.5) THEN
18852 q2=-th
18853 ELSEIF(mstp(32).EQ.6) THEN
18854 xsf1=x(1)
18855 IF(istsb.EQ.9) xsf1=x(1)/vint(143)
18856 xsf2=x(2)
18857 IF(istsb.EQ.9) xsf2=x(2)/vint(144)
18858 q2=(1d0+xsf1*q2in1/sh+xsf2*q2in2/sh)*
18859 & (sqpth+0.5d0*(sqm3+sqm4))
18860 ELSEIF(mstp(32).EQ.7) THEN
18861 q2=(1d0+q2in1/sh+q2in2/sh)*(sqpth+0.5d0*(sqm3+sqm4))
18862 ELSEIF(mstp(32).EQ.8) THEN
18863 q2=sqpth+0.5d0*(q2in1+q2in2+sqm3+sqm4)
18864 ELSEIF(mstp(32).EQ.9) THEN
18865 q2=sqpth+q2in1+q2in2+sqm3+sqm4
18866 ELSEIF(mstp(32).EQ.10) THEN
18867 q2=vint(2)
18868 ENDIF
18869 IF(istsb.EQ.9) q2=sqpth
18870 IF(istsb.EQ.9.AND.mstp(82).GE.2) q2=q2+
18871 & (parp(82)*(vint(1)/parp(89))**parp(90))**2
18872 ENDIF
18873 q2sf=q2
18874 IF(istsb.GE.3.AND.istsb.LE.5) THEN
18875 q2sf=pmas(23,1)**2
18876 IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77.OR.isub.EQ.124.OR.
18877 & isub.EQ.351) q2sf=pmas(24,1)**2
18878 IF(isub.EQ.352) q2sf=pmas(63,1)**2
18879 IF(isub.EQ.121.OR.isub.EQ.122) THEN
18880 q2sf=pmas(pycomp(kfpr(isubsv,2)),1)**2
18881 IF(mstp(39).EQ.2) q2sf=q2sf+max(vint(202),vint(207))
18882 IF(mstp(39).EQ.3) q2sf=sh
18883 IF(mstp(39).EQ.4) q2sf=vint(26)*vint(2)
18884 IF(mstp(39).EQ.5) q2sf=pmas(kfhigg,1)**2
18885 ENDIF
18886 ENDIF
18887 q2ps=q2sf
18888 q2sf=q2sf*parp(34)
18889 IF(mstp(69).GE.1.AND.mint(47).EQ.5) q2sf=vint(2)
18890 IF(mstp(69).GE.2) q2sf=vint(2)
18891 IF(mstp(22).GE.1.AND.(isub.EQ.10.OR.isub.EQ.83).AND.
18892 &(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
18893 xbj=x(2)
18894 IF(mint(43).EQ.3) xbj=x(1)
18895 IF(mstp(22).EQ.1) THEN
18896 q2ps=-th
18897 ELSEIF(mstp(22).EQ.2) THEN
18898 q2ps=((1d0-xbj)/xbj)*(-th)
18899 ELSEIF(mstp(22).EQ.3) THEN
18900 q2ps=sqrt((1d0-xbj)/xbj)*(-th)
18901 ELSE
18902 q2ps=(1d0-xbj)*max(1d0,-log(xbj))*(-th)
18903 ENDIF
18904 ENDIF
18905 IF(mstp(68).EQ.1.AND.(isubsv.EQ.1.OR.isubsv.EQ.2.OR.
18906 &isubsv.EQ.141.OR.isubsv.EQ.142.OR.isubsv.EQ.144)) THEN
18907 q2ps=vint(2)
18908 ELSEIF(mstp(68).GE.2.AND.(isubsv.NE.11.AND.isubsv.NE.12.AND.
18909 &isubsv.NE.13.AND.isubsv.NE.28.AND.isubsv.NE.53.AND.
18910 &isubsv.NE.68)) THEN
18911 q2ps=vint(2)
18912 ENDIF
18913
18914C...Store derived kinematical quantities
18915 vint(41)=x(1)
18916 vint(42)=x(2)
18917 vint(44)=sh
18918 vint(43)=sqrt(sh)
18919 vint(45)=th
18920 vint(46)=uh
18921 IF(istsb.NE.8) vint(48)=sqpth
18922 IF(istsb.NE.8) vint(47)=sqrt(sqpth)
18923 vint(50)=taup*vint(2)
18924 vint(49)=sqrt(max(0d0,vint(50)))
18925 vint(52)=q2
18926 vint(51)=sqrt(q2)
18927 vint(54)=q2sf
18928 vint(53)=sqrt(q2sf)
18929 vint(56)=q2ps
18930 vint(55)=sqrt(q2ps)
18931
18932C...Calculate parton distributions
18933 IF(istsb.LE.0) GOTO 152
18934 IF(mint(47).GE.2) THEN
18935 DO 110 i=3-min(2,mint(45)),min(2,mint(46))
18936 xsf=x(i)
18937 IF(istsb.EQ.9) xsf=x(i)/vint(142+i)
18938 IF(isub.EQ.99) THEN
18939 xsf=vint(309-i)/(vint(2)+vint(307)+vint(308))
18940 q2sf=vint(309-i)
18941 ENDIF
18942 mint(105)=mint(102+i)
18943 mint(109)=mint(106+i)
18944 vint(120)=vint(2+i)
18945 IF(mstp(57).LE.1) THEN
18946 CALL pypdfu(mint(10+i),xsf,q2sf,xpq)
18947 ELSE
18948 CALL pypdfl(mint(10+i),xsf,q2sf,xpq)
18949 ENDIF
18950 DO 100 kfl=-25,25
18951 xsfx(i,kfl)=xpq(kfl)
18952 100 CONTINUE
18953 110 CONTINUE
18954 ENDIF
18955
18956C...Calculate alpha_em, alpha_strong and K-factor
18957 xw=paru(102)
18958 xwv=xw
18959 IF(mstp(8).GE.2.OR.(isub.GE.71.AND.isub.LE.77)) xw=
18960 &1d0-(pmas(24,1)/pmas(23,1))**2
18961 xw1=1d0-xw
18962 xwc=1d0/(16d0*xw*xw1)
18963 aem=pyalem(q2)
18964 IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
18965 IF(mstp(33).NE.3) as=pyalps(parp(34)*q2)
18966 fack=1d0
18967 faca=1d0
18968 IF(mstp(33).EQ.1) THEN
18969 fack=parp(31)
18970 ELSEIF(mstp(33).EQ.2) THEN
18971 fack=parp(31)
18972 faca=parp(32)/parp(31)
18973 ELSEIF(mstp(33).EQ.3) THEN
18974 q2as=parp(33)*q2
18975 IF(istsb.EQ.9.AND.mstp(82).GE.2) q2as=q2as+
18976 & paru(112)*parp(82)*(vint(1)/parp(89))**parp(90)
18977 as=pyalps(q2as)
18978 ENDIF
18979 vint(138)=1d0
18980 vint(57)=aem
18981 vint(58)=as
18982
18983C...Set flags for allowed reacting partons/leptons
18984 DO 140 i=1,2
18985 DO 120 j=-25,25
18986 kfac(i,j)=0
18987 120 CONTINUE
18988 IF(mint(44+i).EQ.1) THEN
18989 kfac(i,mint(10+i))=1
18990 ELSEIF(mint(40+i).EQ.1.AND.mstp(12).EQ.0) THEN
18991 kfac(i,mint(10+i))=1
18992 kfac(i,22)=1
18993 kfac(i,24)=1
18994 kfac(i,-24)=1
18995 ELSE
18996 DO 130 j=-25,25
18997 kfac(i,j)=kfin(i,j)
18998 IF(iabs(j).GT.mstp(58).AND.iabs(j).LE.10) kfac(i,j)=0
18999 IF(xsfx(i,j).LT.1d-10) kfac(i,j)=0
19000 130 CONTINUE
19001 ENDIF
19002 140 CONTINUE
19003
19004C...Lower and upper limit for fermion flavour loops
19005 mmin1=0
19006 mmax1=0
19007 mmin2=0
19008 mmax2=0
19009 DO 150 j=-20,20
19010 IF(kfac(1,-j).EQ.1) mmin1=-j
19011 IF(kfac(1,j).EQ.1) mmax1=j
19012 IF(kfac(2,-j).EQ.1) mmin2=-j
19013 IF(kfac(2,j).EQ.1) mmax2=j
19014 150 CONTINUE
19015 mmina=min(mmin1,mmin2)
19016 mmaxa=max(mmax1,mmax2)
19017
19018C...Common resonance mass and width combinations
19019 sqmz=pmas(23,1)**2
19020 sqmw=pmas(24,1)**2
19021 sqmh=pmas(kfhigg,1)**2
19022 gmmz=pmas(23,1)*pmas(23,2)
19023 gmmw=pmas(24,1)*pmas(24,2)
19024 gmmh=pmas(kfhigg,1)*pmas(kfhigg,2)
19025C...MRENNA+++
19026 zwid=pmas(23,2)
19027 wwid=pmas(24,2)
19028 tanw=sqrt(xw/xw1)
19029 ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
19030C...MRENNA---
19031
19032C...Phase space integral in tau
19033 comfac=paru(1)*paru(5)/vint(2)
19034 IF(mint(41).EQ.2.AND.mint(42).EQ.2) comfac=comfac*fack
19035 IF((mint(47).GE.2.OR.(istsb.GE.3.AND.istsb.LE.5)).AND.
19036 &istsb.NE.8.AND.istsb.NE.9) THEN
19037 atau1=log(taumax/taumin)
19038 atau2=(taumax-taumin)/(taumax*taumin)
19039 h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/tau
19040 IF(mint(72).GE.1) THEN
19041 taur1=vint(73)
19042 gamr1=vint(74)
19043 ataud=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))
19044 atau3=ataud/taur1
19045 IF(ataud.GT.1d-10) h1=h1+
19046 & (atau1/atau3)*coef(isubsv,3)/(tau+taur1)
19047 ataud=atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1)
19048 atau4=ataud/gamr1
19049 IF(ataud.GT.1d-10) h1=h1+
19050 & (atau1/atau4)*coef(isubsv,4)*tau/((tau-taur1)**2+gamr1**2)
19051 ENDIF
19052 IF(mint(72).EQ.2) THEN
19053 taur2=vint(75)
19054 gamr2=vint(76)
19055 ataud=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))
19056 atau5=ataud/taur2
19057 IF(ataud.GT.1d-10) h1=h1+
19058 & (atau1/atau5)*coef(isubsv,5)/(tau+taur2)
19059 ataud=atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2)
19060 atau6=ataud/gamr2
19061 IF(ataud.GT.1d-10) h1=h1+
19062 & (atau1/atau6)*coef(isubsv,6)*tau/((tau-taur2)**2+gamr2**2)
19063 ENDIF
19064 IF(mint(47).EQ.5.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
19065 atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
19066 IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
19067 & max(2d-10,1d0-tau)
19068 ELSEIF(mint(47).GE.6.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
19069 atau7=log(max(1d-10,1d0-taumin)/max(1d-10,1d0-taumax))
19070 IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
19071 & max(1d-10,1d0-tau)
19072 ENDIF
19073 comfac=comfac*atau1/(tau*h1)
19074 ENDIF
19075
19076C...Phase space integral in y*
19077 IF((mint(47).EQ.4.OR.mint(47).EQ.5).AND.istsb.NE.8.AND.istsb.NE.9)
19078 &THEN
19079 ayst0=ystmax-ystmin
19080 IF(ayst0.LT.1d-10) THEN
19081 comfac=0d0
19082 ELSE
19083 ayst1=0.5d0*(ystmax-ystmin)**2
19084 ayst2=ayst1
19085 ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
19086 h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
19087 & (ayst0/ayst2)*coef(isubsv,9)*(ystmax-yst)+
19088 & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
19089 IF(mint(45).EQ.3) THEN
19090 yst0=-0.5d0*log(taue)
19091 ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
19092 & max(1d-10,exp(yst0-ystmax)-1d0))
19093 IF(ayst4.GT.1d-10) h2=h2+(ayst0/ayst4)*coef(isubsv,11)/
19094 & max(1d-10,1d0-exp(yst-yst0))
19095 ENDIF
19096 IF(mint(46).EQ.3) THEN
19097 yst0=-0.5d0*log(taue)
19098 ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
19099 & max(1d-10,exp(yst0+ystmin)-1d0))
19100 IF(ayst5.GT.1d-10) h2=h2+(ayst0/ayst5)*coef(isubsv,12)/
19101 & max(1d-10,1d0-exp(-yst-yst0))
19102 ENDIF
19103 comfac=comfac*ayst0/h2
19104 ENDIF
19105 ENDIF
19106
19107C...2 -> 1 processes: reduction in angular part of phase space integral
19108C...for case of decaying resonance
19109 acth0=ctnmax-ctnmin+ctpmax-ctpmin
19110 IF((istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5)) THEN
19111 IF(mdcy(pycomp(kfpr(isubsv,1)),1).EQ.1) THEN
19112 IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37.OR.
19113 & kfpr(isub,1).EQ.39) THEN
19114 comfac=comfac*0.5d0*acth0
19115 ELSE
19116 comfac=comfac*0.125d0*(3d0*acth0+ctnmax**3-ctnmin**3+
19117 & ctpmax**3-ctpmin**3)
19118 ENDIF
19119 ENDIF
19120
19121C...2 -> 2 processes: angular part of phase space integral
19122 ELSEIF(istsb.EQ.2.OR.istsb.EQ.4) THEN
19123 acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/
19124 & (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))
19125 acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/
19126 & (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))
19127 acth3=1d0/max(rm34,rsqm-ctnmax)-1d0/max(rm34,rsqm-ctnmin)+
19128 & 1d0/max(rm34,rsqm-ctpmax)-1d0/max(rm34,rsqm-ctpmin)
19129 acth4=1d0/max(rm34,rsqm+ctnmin)-1d0/max(rm34,rsqm+ctnmax)+
19130 & 1d0/max(rm34,rsqm+ctpmin)-1d0/max(rm34,rsqm+ctpmax)
19131 h3=coef(isubsv,13)+
19132 & (acth0/acth1)*coef(isubsv,14)/max(rm34,rsqm-cth)+
19133 & (acth0/acth2)*coef(isubsv,15)/max(rm34,rsqm+cth)+
19134 & (acth0/acth3)*coef(isubsv,16)/max(rm34,rsqm-cth)**2+
19135 & (acth0/acth4)*coef(isubsv,17)/max(rm34,rsqm+cth)**2
19136 comfac=comfac*acth0*0.5d0*be34/h3
19137
19138C...2 -> 2 processes: take into account final state Breit-Wigners
19139 comfac=comfac*vint(80)
19140 ENDIF
19141
19142C...2 -> 3, 4 processes: phace space integral in tau'
19143 IF(mint(47).GE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN
19144 ataup1=log(taupmx/taupmn)
19145 ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
19146 h4=coef(isubsv,18)+
19147 & (ataup1/ataup2)*coef(isubsv,19)*(1d0-tau/taup)**3/taup
19148 IF(mint(47).EQ.5) THEN
19149 ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
19150 h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(2d-10,1d0-taup)
19151 ELSEIF(mint(47).GE.6) THEN
19152 ataup3=log(max(1d-10,1d0-taupmn)/max(1d-10,1d0-taupmx))
19153 h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(1d-10,1d0-taup)
19154 ENDIF
19155 comfac=comfac*ataup1/h4
19156 ENDIF
19157
19158C...2 -> 3, 4 processes: effective W/Z parton distributions
19159 IF(istsb.EQ.3.OR.istsb.EQ.4) THEN
19160 IF(1d0-tau/taup.GT.1d-4) THEN
19161 fzw=(1d0+tau/taup)*log(taup/tau)-2d0*(1d0-tau/taup)
19162 ELSE
19163 fzw=1d0/6d0*(1d0-tau/taup)**3*tau/taup
19164 ENDIF
19165 comfac=comfac*fzw
19166 ENDIF
19167
19168C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
19169 IF(istsb.EQ.5) THEN
19170 comfac=comfac*vint(205)*vint(210)*vint(212)*vint(214)/
19171 & (128d0*paru(1)**4*vint(220))*(tau**2/taup)
19172 ENDIF
19173
19174C...Phase space integral for low-pT and multiple interactions
19175 IF(istsb.EQ.9) THEN
19176 comfac=paru(1)*paru(5)*fack*0.5d0*vint(2)/sh2
19177 atau1=log(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)
19178 atau2=2d0*atan(1d0/xt2-1d0)/sqrt(xt2)
19179 h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/sqrt(tau)
19180 comfac=comfac*atau1/h1
19181 ayst0=ystmax-ystmin
19182 ayst1=0.5d0*(ystmax-ystmin)**2
19183 ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
19184 h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
19185 & (ayst0/ayst1)*coef(isubsv,9)*(ystmax-yst)+
19186 & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
19187 comfac=comfac*ayst0/h2
19188 IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1d0/vint(149)-1d0)
19189C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
19190C...introduced to make cross-section finite for xT2 -> 0
19191 IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*
19192 & (1d0+vint(149)))
19193 ENDIF
19194
19195C...Real gamma + gamma: include factor 2 when different nature
19196 152 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
19197 &mstp(14).LE.10) comfac=2d0*comfac
19198
19199C...Extra factors to include the effects of
19200C...longitudinal resolved photons (but not direct or DIS ones).
19201 DO 155 isde=1,2
19202 IF(mint(10+isde).EQ.22.AND.mint(106+isde).GE.1.AND.
19203 & mint(106+isde).LE.3) THEN
19204 vint(314+isde)=1d0
19205 xy=parp(166+isde)
19206 IF(mstp(16).EQ.0) THEN
19207 IF(vint(304+isde).GT.0d0.AND.vint(304+isde).LT.1d0)
19208 & xy=vint(304+isde)
19209 ELSE
19210 IF(vint(308+isde).GT.0d0.AND.vint(308+isde).LT.1d0)
19211 & xy=vint(308+isde)
19212 ENDIF
19213 q2ga=vint(306+isde)
19214 IF(mstp(17).GT.0.AND.xy.GT.0d0.AND.xy.LT.1d0.AND.
19215 & q2ga.GT.0d0) THEN
19216 reduce=0d0
19217 IF(mstp(17).EQ.1) THEN
19218 reduce=4d0*q2*q2ga/(q2+q2ga)**2
19219 ELSEIF(mstp(17).EQ.2) THEN
19220 reduce=4d0*q2ga/(q2+q2ga)
19221 ELSEIF(mstp(17).EQ.3) THEN
19222 pmvirt=pmas(pycomp(113),1)
19223 reduce=4d0*q2ga/(pmvirt**2+q2ga)
19224 ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.1) THEN
19225 pmvirt=pmas(pycomp(113),1)
19226 reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
19227 ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.2) THEN
19228 pmvirt=pmas(pycomp(113),1)
19229 reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
19230 ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.3) THEN
19231 pmvsmn=4d0*parp(15)**2
19232 pmvsmx=4d0*vint(154)**2
19233 redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
19234 redlon=(3d0*pmvsmn+q2ga)/(pmvsmn+q2ga)**3-
19235 & (3d0*pmvsmx+q2ga)/(pmvsmx+q2ga)**3
19236 reduce=4d0*(q2ga/6d0)*redlon/redtra
19237 ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.1) THEN
19238 pmvirt=pmas(pycomp(113),1)
19239 reduce=4d0*q2ga/(pmvirt**2+q2ga)
19240 ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.2) THEN
19241 pmvirt=pmas(pycomp(113),1)
19242 reduce=4d0*q2ga/(pmvirt**2+q2ga)
19243 ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.3) THEN
19244 pmvsmn=4d0*parp(15)**2
19245 pmvsmx=4d0*vint(154)**2
19246 redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
19247 redlon=1d0/(pmvsmn+q2ga)**2-1d0/(pmvsmx+q2ga)**2
19248 reduce=4d0*(q2ga/2d0)*redlon/redtra
19249 ENDIF
19250 beamas=pymass(11)
19251 IF(vint(302+isde).GT.0d0) beamas=vint(302+isde)
19252 fraclt=1d0/(1d0+xy**2/2d0/(1d0-xy)*
19253 & (1d0-2d0*beamas**2/q2ga))
19254 vint(314+isde)=1d0+parp(165)*reduce*fraclt
19255 ENDIF
19256 ELSE
19257 vint(314+isde)=1d0
19258 ENDIF
19259 comfac=comfac*vint(314+isde)
19260 155 CONTINUE
19261
19262C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
19263 IF((mstp(46).GE.3.AND.mstp(46).LE.6).AND.(isub.EQ.71.OR.isub.EQ.
19264 &72.OR.isub.EQ.73.OR.isub.EQ.76.OR.isub.EQ.77)) THEN
19265C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
19266 IF(mstp(46).LE.4) THEN
19267 hdtlh=log(pmas(25,1)/parp(44))
19268 hdtmr=(4.5d0*paru(1)/sqrt(3d0)-74d0/9d0)/8d0+hdtlh/12d0
19269 hdtnr=-1d0/18d0+hdtlh/6d0
19270 ELSE
19271 hdtnm=0.125d0*(1d0/(288d0*paru(1)**2)+(parp(47)/parp(45))**2)
19272 hdtlq=log(parp(45)/parp(44))
19273 hdtmr=-(4d0*paru(1))**2*0.5d0*hdtnm+hdtlq/12d0
19274 hdtnr=(4d0*paru(1))**2*hdtnm+hdtlq/6d0
19275 ENDIF
19276
19277C...Calculate lowest and next-to-lowest order partial wave amplitudes
19278 hdtv=1d0/(16d0*paru(1)*parp(47)**2)
19279 a00l=sngl(hdtv*sh)
19280 a20l=-0.5*a00l
19281 a11l=a00l/6.
19282 hdtls=log(sh/parp(44)**2)
19283 a004=sngl((hdtv*sh)**2/(4d0*paru(1)))*
19284 & cmplx(sngl((176d0*hdtmr+112d0*hdtnr)/3d0+11d0/27d0-
19285 & (50d0/9d0)*hdtls),sngl(4d0*paru(1)))
19286 a204=sngl((hdtv*sh)**2/(4d0*paru(1)))*
19287 & cmplx(sngl(32d0*(hdtmr+2d0*hdtnr)/3d0+25d0/54d0-
19288 & (20d0/9d0)*hdtls),sngl(paru(1)))
19289 a114=sngl((hdtv*sh)**2/(6d0*paru(1)))*
19290 & cmplx(sngl(4d0*(-2d0*hdtmr+hdtnr)-1d0/18d0),sngl(paru(1)/6d0))
19291
19292C...Unitarize partial wave amplitudes with Pade or K-matrix method
19293 IF(mstp(46).EQ.3.OR.mstp(46).EQ.5) THEN
19294 a00u=a00l/(1.-a004/a00l)
19295 a20u=a20l/(1.-a204/a20l)
19296 a11u=a11l/(1.-a114/a11l)
19297 ELSE
19298 a00u=(a00l+real(a004))/(1.-cmplx(0.,a00l+real(a004)))
19299 a20u=(a20l+real(a204))/(1.-cmplx(0.,a20l+real(a204)))
19300 a11u=(a11l+real(a114))/(1.-cmplx(0.,a11l+real(a114)))
19301 ENDIF
19302 ENDIF
19303
19304C...Supersymmetric processes - all of type 2 -> 2 :
19305C...correct final-state Breit-Wigners from fixed to running width.
19306 IF(isub.GE.200.AND.isub.LE.301.AND.mstp(42).GT.0) THEN
19307 DO 160 i=1,2
19308 kflw=kfpr(isubsv,i)
19309 kcw=pycomp(kflw)
19310 IF(pmas(kcw,2).LT.parp(41)) GOTO 160
19311 IF(i.EQ.1) sqmi=sqm3
19312 IF(i.EQ.2) sqmi=sqm4
19313 sqms=pmas(kcw,1)**2
19314 gmms=pmas(kcw,1)*pmas(kcw,2)
19315 hbws=gmms/((sqmi-sqms)**2+gmms**2)
19316 CALL pywidt(kflw,sqmi,wdtp,wdte)
19317 gmmi=sqrt(sqmi)*wdtp(0)
19318 hbwi=gmmi/((sqmi-sqms)**2+gmmi**2)
19319 comfac=comfac*(hbwi/hbws)
19320 160 CONTINUE
19321 ENDIF
19322
19323C...A: 2 -> 1, tree diagrams
19324
19325 IF(isub.LE.10) THEN
19326 IF(isub.EQ.1) THEN
19327C...f + fbar -> gamma*/Z0
19328 mint(61)=2
19329 CALL pywidt(23,sh,wdtp,wdte)
19330 hs=shr*wdtp(0)
19331 facz=4d0*comfac*3d0
19332 hp0=aem/3d0*sh
19333 hp1=aem/3d0*xwc*sh
19334 DO 180 i=mmina,mmaxa
19335 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 180
19336 ei=kchg(iabs(i),1)/3d0
19337 ai=sign(1d0,ei)
19338 vi=ai-4d0*ei*xwv
19339 hi0=hp0
19340 IF(iabs(i).LE.10) hi0=hi0*faca/3d0
19341 hi1=hp1
19342 IF(iabs(i).LE.10) hi1=hi1*faca/3d0
19343 nchn=nchn+1
19344 isig(nchn,1)=i
19345 isig(nchn,2)=-i
19346 isig(nchn,3)=1
19347 sigh(nchn)=facz*(ei**2/sh2*hi0*hp0*vint(111)+
19348 & ei*vi*(1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*
19349 & (hi0*hp1+hi1*hp0)*vint(112)+(vi**2+ai**2)/
19350 & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114))
19351 180 CONTINUE
19352
19353 ELSEIF(isub.EQ.2) THEN
19354C...f + fbar' -> W+/-
19355 CALL pywidt(24,sh,wdtp,wdte)
19356 hs=shr*wdtp(0)
19357 facbw=4d0*comfac/((sh-sqmw)**2+hs**2)*3d0
19358 hp=aem/(24d0*xw)*sh
19359 DO 200 i=mmin1,mmax1
19360 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 200
19361 ia=iabs(i)
19362 DO 190 j=mmin2,mmax2
19363 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 190
19364 ja=iabs(j)
19365 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 190
19366 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19367 & GOTO 190
19368 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19369 hi=hp*2d0
19370 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
19371 nchn=nchn+1
19372 isig(nchn,1)=i
19373 isig(nchn,2)=j
19374 isig(nchn,3)=1
19375 hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
19376 sigh(nchn)=hi*facbw*hf
19377 190 CONTINUE
19378 200 CONTINUE
19379
19380 ELSEIF(isub.EQ.3) THEN
19381C...f + fbar -> h0 (or H0, or A0)
19382 CALL pywidt(kfhigg,sh,wdtp,wdte)
19383 hs=shr*wdtp(0)
19384 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
19385 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
19386 & facbw=0d0
19387 hp=aem/(8d0*xw)*sh/sqmw*sh
19388 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19389 DO 210 i=mmina,mmaxa
19390 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 210
19391 ia=iabs(i)
19392 rmq=pymrun(ia,sh)**2/sh
19393 hi=hp*rmq
19394 IF(ia.LE.10) hi=hp*rmq*faca/3d0
19395 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
19396 ikfi=1
19397 IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
19398 IF(ia.GT.10) ikfi=3
19399 hi=hi*paru(150+10*ihigg+ikfi)**2
19400 ENDIF
19401 nchn=nchn+1
19402 isig(nchn,1)=i
19403 isig(nchn,2)=-i
19404 isig(nchn,3)=1
19405 sigh(nchn)=hi*facbw*hf
19406 210 CONTINUE
19407
19408 ELSEIF(isub.EQ.4) THEN
19409C...gamma + W+/- -> W+/-
19410
19411 ELSEIF(isub.EQ.5) THEN
19412C...Z0 + Z0 -> h0
19413 CALL pywidt(25,sh,wdtp,wdte)
19414 hs=shr*wdtp(0)
19415 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
19416 IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
19417 hp=aem/(8d0*xw)*sh/sqmw*sh
19418 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19419 hi=hp/4d0
19420 faci=8d0/(paru(1)**2*xw1)*(aem*xwc)**2
19421 DO 230 i=mmin1,mmax1
19422 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 230
19423 DO 220 j=mmin2,mmax2
19424 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 220
19425 ei=kchg(iabs(i),1)/3d0
19426 ai=sign(1d0,ei)
19427 vi=ai-4d0*ei*xwv
19428 ej=kchg(iabs(j),1)/3d0
19429 aj=sign(1d0,ej)
19430 vj=aj-4d0*ej*xwv
19431 nchn=nchn+1
19432 isig(nchn,1)=i
19433 isig(nchn,2)=j
19434 isig(nchn,3)=1
19435 sigh(nchn)=faci*(vi**2+ai**2)*(vj**2+aj**2)*hi*facbw*hf
19436 220 CONTINUE
19437 230 CONTINUE
19438
19439 ELSEIF(isub.EQ.6) THEN
19440C...Z0 + W+/- -> W+/-
19441
19442 ELSEIF(isub.EQ.7) THEN
19443C...W+ + W- -> Z0
19444
19445 ELSEIF(isub.EQ.8) THEN
19446C...W+ + W- -> h0
19447 CALL pywidt(25,sh,wdtp,wdte)
19448 hs=shr*wdtp(0)
19449 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
19450 IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
19451 hp=aem/(8d0*xw)*sh/sqmw*sh
19452 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19453 hi=hp/2d0
19454 faci=1d0/(4d0*paru(1)**2)*(aem/xw)**2
19455 DO 250 i=mmin1,mmax1
19456 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 250
19457 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
19458 DO 240 j=mmin2,mmax2
19459 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 240
19460 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
19461 IF(ei*ej.GT.0d0) GOTO 240
19462 nchn=nchn+1
19463 isig(nchn,1)=i
19464 isig(nchn,2)=j
19465 isig(nchn,3)=1
19466 sigh(nchn)=faci*vint(180+i)*vint(180+j)*hi*facbw*hf
19467 240 CONTINUE
19468 250 CONTINUE
19469
19470C...B: 2 -> 2, tree diagrams
19471
19472 ELSEIF(isub.EQ.10) THEN
19473C...f + f' -> f + f' (gamma/Z/W exchange)
19474 facggf=comfac*aem**2*2d0*(sh2+uh2)/th2
19475 facgzf=comfac*aem**2*xwc*4d0*sh2/(th*(th-sqmz))
19476 faczzf=comfac*(aem*xwc)**2*2d0*sh2/(th-sqmz)**2
19477 facwwf=comfac*(0.5d0*aem/xw)**2*sh2/(th-sqmw)**2
19478 DO 270 i=mmin1,mmax1
19479 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 270
19480 ia=iabs(i)
19481 DO 260 j=mmin2,mmax2
19482 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 260
19483 ja=iabs(j)
19484C...Electroweak couplings
19485 ei=kchg(ia,1)*isign(1,i)/3d0
19486 ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
19487 vi=ai-4d0*ei*xwv
19488 ej=kchg(ja,1)*isign(1,j)/3d0
19489 aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
19490 vj=aj-4d0*ej*xwv
19491 epsij=isign(1,i*j)
19492C...gamma/Z exchange, only gamma exchange, or only Z exchange
19493 IF(mstp(21).GE.1.AND.mstp(21).LE.4) THEN
19494 IF(mstp(21).EQ.1.OR.mstp(21).EQ.4) THEN
19495 facncf=facggf*ei**2*ej**2+facgzf*ei*ej*
19496 & (vi*vj*(1d0+uh2/sh2)+ai*aj*epsij*(1d0-uh2/sh2))+
19497 & faczzf*((vi**2+ai**2)*(vj**2+aj**2)*(1d0+uh2/sh2)+
19498 & 4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
19499 ELSEIF(mstp(21).EQ.2) THEN
19500 facncf=facggf*ei**2*ej**2
19501 ELSE
19502 facncf=faczzf*((vi**2+ai**2)*(vj**2+aj**2)*
19503 & (1d0+uh2/sh2)+4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
19504 ENDIF
19505 nchn=nchn+1
19506 isig(nchn,1)=i
19507 isig(nchn,2)=j
19508 isig(nchn,3)=1
19509 sigh(nchn)=facncf
19510 ENDIF
19511C...W exchange
19512 IF((mstp(21).EQ.1.OR.mstp(21).EQ.5).AND.ai*aj.LT.0d0) THEN
19513 facccf=facwwf*vint(180+i)*vint(180+j)
19514 IF(epsij.LT.0d0) facccf=facccf*uh2/sh2
19515 IF(ia.GT.10.AND.mod(ia,2).EQ.0) facccf=2d0*facccf
19516 IF(ja.GT.10.AND.mod(ja,2).EQ.0) facccf=2d0*facccf
19517 nchn=nchn+1
19518 isig(nchn,1)=i
19519 isig(nchn,2)=j
19520 isig(nchn,3)=2
19521 sigh(nchn)=facccf
19522 ENDIF
19523 260 CONTINUE
19524 270 CONTINUE
19525 ENDIF
19526
19527 ELSEIF(isub.LE.20) THEN
19528 IF(isub.EQ.11) THEN
19529C...f + f' -> f + f' (g exchange)
19530 facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
19531 facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
19532 & mstp(34)*2d0/3d0*uh2/(sh*th))
19533 facqq2=comfac*as**2*4d0/9d0*(sh2+th2)/uh2
19534 facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
19535 ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
19536 IF(mstp(5).GE.1) THEN
19537C...Modifications from contact interactions (compositeness)
19538 facci1=facqq1+comfac*(sh2/paru(155)**4)
19539 faccib=facqqb+comfac*(8d0/9d0)*(as*paru(156)/paru(155)**2)*
19540 & (uh2/th+uh2/sh)+comfac*(5d0/3d0)*(uh2/paru(155)**4)
19541 facci2=facqq2+comfac*(8d0/9d0)*(as*paru(156)/paru(155)**2)*
19542 & (sh2/th+sh2/uh)+comfac*(5d0/3d0)*(sh2/paru(155)**4)
19543 facci3=facqq1+comfac*(uh2/paru(155)**4)
19544 ratcii=(facci1*facci2+facqqi)/(facci1+facci2)
19545 ENDIF
19546 DO 290 i=mmin1,mmax1
19547 ia=iabs(i)
19548 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 290
19549 DO 280 j=mmin2,mmax2
19550 ja=iabs(j)
19551 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 280
19552 nchn=nchn+1
19553 isig(nchn,1)=i
19554 isig(nchn,2)=j
19555 isig(nchn,3)=1
19556 IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.(ia.GE.3.OR.
19557 & ja.GE.3))) THEN
19558 sigh(nchn)=facqq1
19559 IF(i.EQ.-j) sigh(nchn)=facqqb
19560 ELSE
19561 sigh(nchn)=facci1
19562 IF(i*j.LT.0) sigh(nchn)=facci3
19563 IF(i.EQ.-j) sigh(nchn)=faccib
19564 ENDIF
19565 IF(i.EQ.j) THEN
19566 nchn=nchn+1
19567 isig(nchn,1)=i
19568 isig(nchn,2)=j
19569 isig(nchn,3)=2
19570 IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.ia.GE.3)) THEN
19571 sigh(nchn-1)=0.5d0*facqq1*ratqqi
19572 sigh(nchn)=0.5d0*facqq2*ratqqi
19573 ELSE
19574 sigh(nchn-1)=0.5d0*facci1*ratcii
19575 sigh(nchn)=0.5d0*facci2*ratcii
19576 ENDIF
19577 ENDIF
19578 280 CONTINUE
19579 290 CONTINUE
19580
19581 ELSEIF(isub.EQ.12) THEN
19582C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
19583 CALL pywidt(21,sh,wdtp,wdte)
19584 facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
19585 & (wdte(0,1)+wdte(0,2)+wdte(0,4))
19586 IF(mstp(5).EQ.1) THEN
19587C...Modifications from contact interactions (compositeness)
19588 faccib=facqqb
19589 DO 300 i=1,2
19590 faccib=faccib+comfac*(uh2/paru(155)**4)*(wdte(i,1)+
19591 & wdte(i,2)+wdte(i,4))
19592 300 CONTINUE
19593 ELSEIF(mstp(5).GE.2) THEN
19594 faccib=facqqb+comfac*(uh2/paru(155)**4)*
19595 & (wdte(0,1)+wdte(0,2)+wdte(0,4))
19596 ENDIF
19597 DO 310 i=mmina,mmaxa
19598 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
19599 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310
19600 nchn=nchn+1
19601 isig(nchn,1)=i
19602 isig(nchn,2)=-i
19603 isig(nchn,3)=1
19604 IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.iabs(i).GE.3)) THEN
19605 sigh(nchn)=facqqb
19606 ELSE
19607 sigh(nchn)=faccib
19608 ENDIF
19609 310 CONTINUE
19610
19611 ELSEIF(isub.EQ.13) THEN
19612C...f + fbar -> g + g (q + qbar -> g + g only)
19613 facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
19614 & uh2/sh2)
19615 facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
19616 & th2/sh2)
19617 DO 320 i=mmina,mmaxa
19618 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
19619 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320
19620 nchn=nchn+1
19621 isig(nchn,1)=i
19622 isig(nchn,2)=-i
19623 isig(nchn,3)=1
19624 sigh(nchn)=0.5d0*facgg1
19625 nchn=nchn+1
19626 isig(nchn,1)=i
19627 isig(nchn,2)=-i
19628 isig(nchn,3)=2
19629 sigh(nchn)=0.5d0*facgg2
19630 320 CONTINUE
19631
19632 ELSEIF(isub.EQ.14) THEN
19633C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
19634 facgg=comfac*as*aem*8d0/9d0*(th2+uh2)/(th*uh)
19635 DO 330 i=mmina,mmaxa
19636 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
19637 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 330
19638 ei=kchg(iabs(i),1)/3d0
19639 nchn=nchn+1
19640 isig(nchn,1)=i
19641 isig(nchn,2)=-i
19642 isig(nchn,3)=1
19643 sigh(nchn)=facgg*ei**2
19644 330 CONTINUE
19645
19646 ELSEIF(isub.EQ.15) THEN
19647C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
19648 faczg=comfac*as*aem*(8d0/9d0)*(th2+uh2+2d0*sqm4*sh)/(th*uh)
19649C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19650 hfgg=0d0
19651 hfgz=0d0
19652 hfzz=0d0
19653 radc4=1d0+pyalps(sqm4)/paru(1)
19654 DO 340 i=1,min(16,mdcy(23,3))
19655 idc=i+mdcy(23,2)-1
19656 IF(mdme(idc,1).LT.0) GOTO 340
19657 imdm=0
19658 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
19659 & imdm=1
19660 IF(i.LE.8) THEN
19661 ef=kchg(i,1)/3d0
19662 af=sign(1d0,ef+0.1d0)
19663 vf=af-4d0*ef*xwv
19664 ELSEIF(i.LE.16) THEN
19665 ef=kchg(i+2,1)/3d0
19666 af=sign(1d0,ef+0.1d0)
19667 vf=af-4d0*ef*xwv
19668 ENDIF
19669 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
19670 IF(4d0*rm1.LT.1d0) THEN
19671 fcof=1d0
19672 IF(i.LE.8) fcof=3d0*radc4
19673 be34=sqrt(max(0d0,1d0-4d0*rm1))
19674 IF(imdm.EQ.1) THEN
19675 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
19676 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
19677 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
19678 & af**2*(1d0-4d0*rm1))*be34
19679 ENDIF
19680 ENDIF
19681 340 CONTINUE
19682C...Propagators: as simulated in PYOFSH and as desired
19683 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
19684 mint15=mint(15)
19685 mint(15)=1
19686 mint(61)=1
19687 CALL pywidt(23,sqm4,wdtp,wdte)
19688 mint(15)=mint15
19689 hfaem=(paru(108)/paru(2))*(2d0/3d0)
19690 hfgg=hfgg*hfaem*vint(111)/sqm4
19691 hfgz=hfgz*hfaem*vint(112)/sqm4
19692 hfzz=hfzz*hfaem*vint(114)/sqm4
19693C...Loop over flavours; consider full gamma/Z structure
19694 DO 350 i=mmina,mmaxa
19695 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
19696 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 350
19697 ei=kchg(iabs(i),1)/3d0
19698 ai=sign(1d0,ei)
19699 vi=ai-4d0*ei*xwv
19700 nchn=nchn+1
19701 isig(nchn,1)=i
19702 isig(nchn,2)=-i
19703 isig(nchn,3)=1
19704 sigh(nchn)=faczg*(ei**2*hfgg+ei*vi*hfgz+
19705 & (vi**2+ai**2)*hfzz)/hbw4
19706 350 CONTINUE
19707
19708 ELSEIF(isub.EQ.16) THEN
19709C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
19710 facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)
19711C...Propagators: as simulated in PYOFSH and as desired
19712 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
19713 CALL pywidt(24,sqm4,wdtp,wdte)
19714 gmmwc=sqrt(sqm4)*wdtp(0)
19715 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
19716 facwg=facwg*hbw4c/hbw4
19717 DO 370 i=mmin1,mmax1
19718 ia=iabs(i)
19719 IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 370
19720 DO 360 j=mmin2,mmax2
19721 ja=iabs(j)
19722 IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 360
19723 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 360
19724 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19725 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
19726 fckm=vckm((ia+1)/2,(ja+1)/2)
19727 nchn=nchn+1
19728 isig(nchn,1)=i
19729 isig(nchn,2)=j
19730 isig(nchn,3)=1
19731 sigh(nchn)=facwg*fckm*widsc
19732 360 CONTINUE
19733 370 CONTINUE
19734
19735 ELSEIF(isub.EQ.17) THEN
19736C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
19737
19738 ELSEIF(isub.EQ.18) THEN
19739C...f + fbar -> gamma + gamma
19740 facgg=comfac*aem**2*2d0*(th2+uh2)/(th*uh)
19741 DO 380 i=mmina,mmaxa
19742 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380
19743 ei=kchg(iabs(i),1)/3d0
19744 fcoi=1d0
19745 IF(iabs(i).LE.10) fcoi=faca/3d0
19746 nchn=nchn+1
19747 isig(nchn,1)=i
19748 isig(nchn,2)=-i
19749 isig(nchn,3)=1
19750 sigh(nchn)=0.5d0*facgg*fcoi*ei**4
19751 380 CONTINUE
19752
19753 ELSEIF(isub.EQ.19) THEN
19754C...f + fbar -> gamma + (gamma*/Z0)
19755 facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)
19756C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19757 hfgg=0d0
19758 hfgz=0d0
19759 hfzz=0d0
19760 radc4=1d0+pyalps(sqm4)/paru(1)
19761 DO 390 i=1,min(16,mdcy(23,3))
19762 idc=i+mdcy(23,2)-1
19763 IF(mdme(idc,1).LT.0) GOTO 390
19764 imdm=0
19765 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
19766 & imdm=1
19767 IF(i.LE.8) THEN
19768 ef=kchg(i,1)/3d0
19769 af=sign(1d0,ef+0.1d0)
19770 vf=af-4d0*ef*xwv
19771 ELSEIF(i.LE.16) THEN
19772 ef=kchg(i+2,1)/3d0
19773 af=sign(1d0,ef+0.1d0)
19774 vf=af-4d0*ef*xwv
19775 ENDIF
19776 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
19777 IF(4d0*rm1.LT.1d0) THEN
19778 fcof=1d0
19779 IF(i.LE.8) fcof=3d0*radc4
19780 be34=sqrt(max(0d0,1d0-4d0*rm1))
19781 IF(imdm.EQ.1) THEN
19782 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
19783 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
19784 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
19785 & af**2*(1d0-4d0*rm1))*be34
19786 ENDIF
19787 ENDIF
19788 390 CONTINUE
19789C...Propagators: as simulated in PYOFSH and as desired
19790 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
19791 mint15=mint(15)
19792 mint(15)=1
19793 mint(61)=1
19794 CALL pywidt(23,sqm4,wdtp,wdte)
19795 mint(15)=mint15
19796 hfaem=(paru(108)/paru(2))*(2d0/3d0)
19797 hfgg=hfgg*hfaem*vint(111)/sqm4
19798 hfgz=hfgz*hfaem*vint(112)/sqm4
19799 hfzz=hfzz*hfaem*vint(114)/sqm4
19800C...Loop over flavours; consider full gamma/Z structure
19801 DO 400 i=mmina,mmaxa
19802 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
19803 ei=kchg(iabs(i),1)/3d0
19804 ai=sign(1d0,ei)
19805 vi=ai-4d0*ei*xwv
19806 fcoi=1d0
19807 IF(iabs(i).LE.10) fcoi=faca/3d0
19808 nchn=nchn+1
19809 isig(nchn,1)=i
19810 isig(nchn,2)=-i
19811 isig(nchn,3)=1
19812 sigh(nchn)=facgz*fcoi*ei**2*(ei**2*hfgg+ei*vi*hfgz+
19813 & (vi**2+ai**2)*hfzz)/hbw4
19814 400 CONTINUE
19815
19816 ELSEIF(isub.EQ.20) THEN
19817C...f + fbar' -> gamma + W+/-
19818 facgw=comfac*0.5d0*aem**2/xw
19819C...Propagators: as simulated in PYOFSH and as desired
19820 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
19821 CALL pywidt(24,sqm4,wdtp,wdte)
19822 gmmwc=sqrt(sqm4)*wdtp(0)
19823 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
19824 facgw=facgw*hbw4c/hbw4
19825C...Anomalous couplings
19826 term1=(th2+uh2+2d0*sqm4*sh)/(th*uh)
19827 term2=0d0
19828 term3=0d0
19829 IF(mstp(5).GE.1) THEN
19830 term2=paru(153)*(th-uh)/(th+uh)
19831 term3=0.5d0*paru(153)**2*(th*uh+(th2+uh2)*sh/
19832 & (4d0*sqmw))/(th+uh)**2
19833 ENDIF
19834 DO 420 i=mmin1,mmax1
19835 ia=iabs(i)
19836 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 420
19837 DO 410 j=mmin2,mmax2
19838 ja=iabs(j)
19839 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 410
19840 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 410
19841 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19842 & GOTO 410
19843 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19844 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
19845 IF(ia.LE.10) THEN
19846 facwr=uh/(th+uh)-1d0/3d0
19847 fckm=vckm((ia+1)/2,(ja+1)/2)
19848 fcoi=faca/3d0
19849 ELSE
19850 facwr=-th/(th+uh)
19851 fckm=1d0
19852 fcoi=1d0
19853 ENDIF
19854 facwk=term1*facwr**2+term2*facwr+term3
19855 nchn=nchn+1
19856 isig(nchn,1)=i
19857 isig(nchn,2)=j
19858 isig(nchn,3)=1
19859 sigh(nchn)=facgw*facwk*fcoi*fckm*widsc
19860 410 CONTINUE
19861 420 CONTINUE
19862 ENDIF
19863
19864 ELSEIF(isub.LE.30) THEN
19865 IF(isub.EQ.21) THEN
19866C...f + fbar -> gamma + h0
19867
19868 ELSEIF(isub.EQ.22) THEN
19869C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
19870C...Kinematics dependence
19871 faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-
19872 & sqm3*sqm4*(1d0/th2+1d0/uh2))
19873C...gamma, gamma/Z interference and Z couplings to final fermion pairs
19874 DO 440 i=1,6
19875 DO 430 j=1,3
19876 hgz(i,j)=0d0
19877 430 CONTINUE
19878 440 CONTINUE
19879 radc3=1d0+pyalps(sqm3)/paru(1)
19880 radc4=1d0+pyalps(sqm4)/paru(1)
19881 DO 450 i=1,min(16,mdcy(23,3))
19882 idc=i+mdcy(23,2)-1
19883 IF(mdme(idc,1).LT.0) GOTO 450
19884 imdm=0
19885 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2) imdm=1
19886 IF(mdme(idc,1).EQ.4.OR.mdme(idc,1).EQ.5) imdm=mdme(idc,1)-2
19887 IF(i.LE.8) THEN
19888 ef=kchg(i,1)/3d0
19889 af=sign(1d0,ef+0.1d0)
19890 vf=af-4d0*ef*xwv
19891 ELSEIF(i.LE.16) THEN
19892 ef=kchg(i+2,1)/3d0
19893 af=sign(1d0,ef+0.1d0)
19894 vf=af-4d0*ef*xwv
19895 ENDIF
19896 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm3
19897 IF(4d0*rm1.LT.1d0) THEN
19898 fcof=1d0
19899 IF(i.LE.8) fcof=3d0*radc3
19900 be34=sqrt(max(0d0,1d0-4d0*rm1))
19901 IF(imdm.GE.1) THEN
19902 hgz(1,imdm)=hgz(1,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
19903 hgz(2,imdm)=hgz(2,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
19904 hgz(3,imdm)=hgz(3,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
19905 & af**2*(1d0-4d0*rm1))*be34
19906 ENDIF
19907 ENDIF
19908 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
19909 IF(4d0*rm1.LT.1d0) THEN
19910 fcof=1d0
19911 IF(i.LE.8) fcof=3d0*radc4
19912 be34=sqrt(max(0d0,1d0-4d0*rm1))
19913 IF(imdm.GE.1) THEN
19914 hgz(4,imdm)=hgz(4,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
19915 hgz(5,imdm)=hgz(5,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
19916 hgz(6,imdm)=hgz(6,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
19917 & af**2*(1d0-4d0*rm1))*be34
19918 ENDIF
19919 ENDIF
19920 450 CONTINUE
19921C...Propagators: as simulated in PYOFSH and as desired
19922 hbw3=(1d0/paru(1))*gmmz/((sqm3-sqmz)**2+gmmz**2)
19923 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
19924 mint15=mint(15)
19925 mint(15)=1
19926 mint(61)=1
19927 CALL pywidt(23,sqm3,wdtp,wdte)
19928 mint(15)=mint15
19929 hfaem=(paru(108)/paru(2))*(2d0/3d0)
19930 DO 460 j=1,3
19931 hgz(1,j)=hgz(1,j)*hfaem*vint(111)/sqm3
19932 hgz(2,j)=hgz(2,j)*hfaem*vint(112)/sqm3
19933 hgz(3,j)=hgz(3,j)*hfaem*vint(114)/sqm3
19934 460 CONTINUE
19935 mint15=mint(15)
19936 mint(15)=1
19937 mint(61)=1
19938 CALL pywidt(23,sqm4,wdtp,wdte)
19939 mint(15)=mint15
19940 hfaem=(paru(108)/paru(2))*(2d0/3d0)
19941 DO 470 j=1,3
19942 hgz(4,j)=hgz(4,j)*hfaem*vint(111)/sqm4
19943 hgz(5,j)=hgz(5,j)*hfaem*vint(112)/sqm4
19944 hgz(6,j)=hgz(6,j)*hfaem*vint(114)/sqm4
19945 470 CONTINUE
19946C...Loop over flavours; separate left- and right-handed couplings
19947 DO 490 i=mmina,mmaxa
19948 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 490
19949 ei=kchg(iabs(i),1)/3d0
19950 ai=sign(1d0,ei)
19951 vi=ai-4d0*ei*xwv
19952 vali=vi-ai
19953 vari=vi+ai
19954 fcoi=1d0
19955 IF(iabs(i).LE.10) fcoi=faca/3d0
19956 DO 480 j=1,3
19957 hl3(j)=ei**2*hgz(1,j)+ei*vali*hgz(2,j)+vali**2*hgz(3,j)
19958 hr3(j)=ei**2*hgz(1,j)+ei*vari*hgz(2,j)+vari**2*hgz(3,j)
19959 hl4(j)=ei**2*hgz(4,j)+ei*vali*hgz(5,j)+vali**2*hgz(6,j)
19960 hr4(j)=ei**2*hgz(4,j)+ei*vari*hgz(5,j)+vari**2*hgz(6,j)
19961 480 CONTINUE
19962 faclr=hl3(1)*hl4(1)+hl3(1)*(hl4(2)+hl4(3))+
19963 & hl4(1)*(hl3(2)+hl3(3))+hl3(2)*hl4(3)+hl4(2)*hl3(3)+
19964 & hr3(1)*hr4(1)+hr3(1)*(hr4(2)+hr4(3))+
19965 & hr4(1)*(hr3(2)+hr3(3))+hr3(2)*hr4(3)+hr4(2)*hr3(3)
19966 nchn=nchn+1
19967 isig(nchn,1)=i
19968 isig(nchn,2)=-i
19969 isig(nchn,3)=1
19970 sigh(nchn)=0.5d0*faczz*fcoi*faclr/(hbw3*hbw4)
19971 490 CONTINUE
19972
19973 ELSEIF(isub.EQ.23) THEN
19974C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
19975 faczw=comfac*0.5d0*(aem/xw)**2
19976 faczw=faczw*wids(23,2)
19977 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
19978 facbw=1d0/((sh-sqmw)**2+gmmw**2)
19979 DO 510 i=mmin1,mmax1
19980 ia=iabs(i)
19981 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 510
19982 DO 500 j=mmin2,mmax2
19983 ja=iabs(j)
19984 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 500
19985 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 500
19986 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19987 & GOTO 500
19988 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19989 ei=kchg(ia,1)/3d0
19990 ai=sign(1d0,ei+0.1d0)
19991 vi=ai-4d0*ei*xwv
19992 ej=kchg(ja,1)/3d0
19993 aj=sign(1d0,ej+0.1d0)
19994 vj=aj-4d0*ej*xwv
19995 IF(vi+ai.GT.0) THEN
19996 visav=vi
19997 aisav=ai
19998 vi=vj
19999 ai=aj
20000 vj=visav
20001 aj=aisav
20002 ENDIF
20003 fckm=1d0
20004 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
20005 fcoi=1d0
20006 IF(ia.LE.10) fcoi=faca/3d0
20007 nchn=nchn+1
20008 isig(nchn,1)=i
20009 isig(nchn,2)=j
20010 isig(nchn,3)=1
20011 sigh(nchn)=faczw*fcoi*fckm*(facbw*((9d0-8d0*xw)/4d0*thuh+
20012 & (8d0*xw-6d0)/4d0*sh*(sqm3+sqm4))+(thuh-sh*(sqm3+sqm4))*
20013 & (sh-sqmw)*facbw*0.5d0*((vj+aj)/th-(vi+ai)/uh)+
20014 & thuh/(16d0*xw1)*((vj+aj)**2/th2+(vi+ai)**2/uh2)+
20015 & sh*(sqm3+sqm4)/(8d0*xw1)*(vi+ai)*(vj+aj)/(th*uh))*
20016 & wids(24,(5-kchw)/2)
20017C***Protect against slightly negative cross sections. (Reason yet to be
20018C***sorted out. One possibility: addition of width to the W propagator.)
20019 sigh(nchn)=max(0d0,sigh(nchn))
20020 500 CONTINUE
20021 510 CONTINUE
20022
20023 ELSEIF(isub.EQ.24) THEN
20024C...f + fbar -> Z0 + h0 (or H0, or A0)
20025 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
20026 fachz=comfac*8d0*(aem*xwc)**2*
20027 & (thuh+2d0*sh*sqm3)/((sh-sqmz)**2+gmmz**2)
20028 fachz=fachz*wids(23,2)*wids(kfhigg,2)
20029 IF(mstp(4).GE.1.OR.ihigg.GE.2) fachz=fachz*
20030 & paru(154+10*ihigg)**2
20031 DO 520 i=mmina,mmaxa
20032 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 520
20033 ei=kchg(iabs(i),1)/3d0
20034 ai=sign(1d0,ei)
20035 vi=ai-4d0*ei*xwv
20036 fcoi=1d0
20037 IF(iabs(i).LE.10) fcoi=faca/3d0
20038 nchn=nchn+1
20039 isig(nchn,1)=i
20040 isig(nchn,2)=-i
20041 isig(nchn,3)=1
20042 sigh(nchn)=fachz*fcoi*(vi**2+ai**2)
20043 520 CONTINUE
20044
20045 ELSEIF(isub.EQ.25) THEN
20046C...f + fbar -> W+ + W-
20047C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
20048 gmmzc=gmmz
20049 hbwzc=sh**2/((sh-sqmz)**2+gmmzc**2)
20050 hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
20051 CALL pywidt(24,sqm3,wdtp,wdte)
20052 gmmw3=sqrt(sqm3)*wdtp(0)
20053 hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
20054 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
20055 CALL pywidt(24,sqm4,wdtp,wdte)
20056 gmmw4=sqrt(sqm4)*wdtp(0)
20057 hbw4c=gmmw4/((sqm4-sqmw)**2+gmmw4**2)
20058C...Kinematical functions
20059 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
20060 thuh34=(2d0*sh*(sqm3+sqm4)+thuh)/(sqm3*sqm4)
20061 gs=(((sh-sqm3-sqm4)**2-4d0*sqm3*sqm4)*thuh34+12d0*thuh)/sh2
20062 gt=thuh34+4d0*thuh/th2
20063 gst=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/th)/sh
20064 gu=thuh34+4d0*thuh/uh2
20065 gsu=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/uh)/sh
20066C...Common factors and couplings
20067 facww=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)
20068 facww=facww*wids(24,1)
20069 cgg=aem**2/2d0
20070 cgz=aem**2/(4d0*xw)*hbwzc*(1d0-sqmz/sh)
20071 czz=aem**2/(32d0*xw**2)*hbwzc
20072 cng=aem**2/(4d0*xw)
20073 cnz=aem**2/(16d0*xw**2)*hbwzc*(1d0-sqmz/sh)
20074 cnn=aem**2/(16d0*xw**2)
20075C...Coulomb factor for W+W- pair
20076 IF(mstp(40).GE.1.AND.mstp(40).LE.3) THEN
20077 coule=(sh-4d0*sqmw)/(4d0*pmas(24,1))
20078 coulp=max(1d-10,0.5d0*be34*sqrt(sh))
20079 IF(coule.LT.100d0*pmas(24,2)) THEN
20080 coulp1=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
20081 & pmas(24,2)**2)-coule))
20082 ELSE
20083 coulp1=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/coule))
20084 ENDIF
20085 IF(coule.GT.-100d0*pmas(24,2)) THEN
20086 coulp2=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
20087 & pmas(24,2)**2)+coule))
20088 ELSE
20089 coulp2=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/
20090 & abs(coule)))
20091 ENDIF
20092 IF(mstp(40).EQ.1) THEN
20093 couldc=paru(1)-2d0*atan((coulp1**2+coulp2**2-coulp**2)/
20094 & max(1d-10,2d0*coulp*coulp1))
20095 faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
20096 ELSEIF(mstp(40).EQ.2) THEN
20097 coulck=cmplx(sngl(coulp1),sngl(coulp2))
20098 coulcp=cmplx(0.,sngl(coulp))
20099 coulcd=(coulck+coulcp)/(coulck-coulcp)
20100 coulcr=1.+sngl(paru(101)*sqrt(sh))/(4.*coulcp)*log(coulcd)
20101 coulcs=cmplx(0.,0.)
20102 nstp=100
20103 DO 530 istp=1,nstp
20104 coulxx=(istp-0.5)/nstp
20105 coulcs=coulcs+(1./coulxx)*log((1.+coulxx*coulcd)/
20106 & (1.+coulxx/coulcd))
20107 530 CONTINUE
20108 coulcr=coulcr+sngl(paru(101)**2*sh)/(16.*coulcp*coulck)*
20109 & (coulcs/nstp)
20110 faccou=abs(coulcr)**2
20111 ELSEIF(mstp(40).EQ.3) THEN
20112 couldc=paru(1)-2d0*(1d0-be34)**2*atan((coulp1**2+
20113 & coulp2**2-coulp**2)/max(1d-10,2d0*coulp*coulp1))
20114 faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
20115 ENDIF
20116 ELSEIF(mstp(40).EQ.4) THEN
20117 faccou=1d0+0.5d0*paru(101)*paru(1)/max(1d-5,be34)
20118 ELSE
20119 faccou=1d0
20120 ENDIF
20121 vint(95)=faccou
20122 facww=facww*faccou
20123C...Loop over allowed flavours
20124 DO 540 i=mmina,mmaxa
20125 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 540
20126 ei=kchg(iabs(i),1)/3d0
20127 ai=sign(1d0,ei+0.1d0)
20128 vi=ai-4d0*ei*xwv
20129 fcoi=1d0
20130 IF(iabs(i).LE.10) fcoi=faca/3d0
20131 IF(ai.LT.0d0) THEN
20132 dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs+
20133 & (cng*ei+cnz*(vi+ai))*gst+cnn*gt
20134 ELSE
20135 dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs-
20136 & (cng*ei+cnz*(vi+ai))*gsu+cnn*gu
20137 ENDIF
20138 nchn=nchn+1
20139 isig(nchn,1)=i
20140 isig(nchn,2)=-i
20141 isig(nchn,3)=1
20142 sigh(nchn)=facww*fcoi*dsigww
20143 540 CONTINUE
20144
20145 ELSEIF(isub.EQ.26) THEN
20146C...f + fbar' -> W+/- + h0 (or H0, or A0)
20147 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
20148 fachw=comfac*0.125d0*(aem/xw)**2*(thuh+2d0*sh*sqm3)/
20149 & ((sh-sqmw)**2+gmmw**2)
20150 fachw=fachw*wids(kfhigg,2)
20151 IF(mstp(4).GE.1.OR.ihigg.GE.2) fachw=fachw*
20152 & paru(155+10*ihigg)**2
20153 DO 560 i=mmin1,mmax1
20154 ia=iabs(i)
20155 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 560
20156 DO 550 j=mmin2,mmax2
20157 ja=iabs(j)
20158 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(1,j).EQ.0) GOTO 550
20159 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 550
20160 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
20161 & GOTO 550
20162 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
20163 fckm=1d0
20164 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
20165 fcoi=1d0
20166 IF(ia.LE.10) fcoi=faca/3d0
20167 nchn=nchn+1
20168 isig(nchn,1)=i
20169 isig(nchn,2)=j
20170 isig(nchn,3)=1
20171 sigh(nchn)=fachw*fcoi*fckm*wids(24,(5-kchw)/2)
20172 550 CONTINUE
20173 560 CONTINUE
20174
20175 ELSEIF(isub.EQ.27) THEN
20176C...f + fbar -> h0 + h0
20177
20178 ELSEIF(isub.EQ.28) THEN
20179C...f + g -> f + g (q + g -> q + g only)
20180 facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
20181 & uh/sh)*faca
20182 facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
20183 & sh/uh)
20184 DO 580 i=mmina,mmaxa
20185 IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 580
20186 DO 570 isde=1,2
20187 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 570
20188 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 570
20189 nchn=nchn+1
20190 isig(nchn,isde)=i
20191 isig(nchn,3-isde)=21
20192 isig(nchn,3)=1
20193 sigh(nchn)=facqg1
20194 nchn=nchn+1
20195 isig(nchn,isde)=i
20196 isig(nchn,3-isde)=21
20197 isig(nchn,3)=2
20198 sigh(nchn)=facqg2
20199 570 CONTINUE
20200 580 CONTINUE
20201
20202 ELSEIF(isub.EQ.29) THEN
20203C...f + g -> f + gamma (q + g -> q + gamma only)
20204 fgq=comfac*faca*as*aem*1d0/3d0*(sh2+uh2)/(-sh*uh)
20205 DO 600 i=mmina,mmaxa
20206 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 600
20207 ei=kchg(iabs(i),1)/3d0
20208 facgq=fgq*ei**2
20209 DO 590 isde=1,2
20210 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 590
20211 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 590
20212 nchn=nchn+1
20213 isig(nchn,isde)=i
20214 isig(nchn,3-isde)=21
20215 isig(nchn,3)=1
20216 sigh(nchn)=facgq
20217 590 CONTINUE
20218 600 CONTINUE
20219
20220 ELSEIF(isub.EQ.30) THEN
20221C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
20222 fzq=comfac*faca*as*aem*(1d0/3d0)*(sh2+uh2+2d0*sqm4*th)/
20223 & (-sh*uh)
20224C...gamma, gamma/Z interference and Z couplings to final fermion pairs
20225 hfgg=0d0
20226 hfgz=0d0
20227 hfzz=0d0
20228 radc4=1d0+pyalps(sqm4)/paru(1)
20229 DO 610 i=1,min(16,mdcy(23,3))
20230 idc=i+mdcy(23,2)-1
20231 IF(mdme(idc,1).LT.0) GOTO 610
20232 imdm=0
20233 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
20234 & imdm=1
20235 IF(i.LE.8) THEN
20236 ef=kchg(i,1)/3d0
20237 af=sign(1d0,ef+0.1d0)
20238 vf=af-4d0*ef*xwv
20239 ELSEIF(i.LE.16) THEN
20240 ef=kchg(i+2,1)/3d0
20241 af=sign(1d0,ef+0.1d0)
20242 vf=af-4d0*ef*xwv
20243 ENDIF
20244 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
20245 IF(4d0*rm1.LT.1d0) THEN
20246 fcof=1d0
20247 IF(i.LE.8) fcof=3d0*radc4
20248 be34=sqrt(max(0d0,1d0-4d0*rm1))
20249 IF(imdm.EQ.1) THEN
20250 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
20251 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
20252 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
20253 & af**2*(1d0-4d0*rm1))*be34
20254 ENDIF
20255 ENDIF
20256 610 CONTINUE
20257C...Propagators: as simulated in PYOFSH and as desired
20258 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
20259 mint15=mint(15)
20260 mint(15)=1
20261 mint(61)=1
20262 CALL pywidt(23,sqm4,wdtp,wdte)
20263 mint(15)=mint15
20264 hfaem=(paru(108)/paru(2))*(2d0/3d0)
20265 hfgg=hfgg*hfaem*vint(111)/sqm4
20266 hfgz=hfgz*hfaem*vint(112)/sqm4
20267 hfzz=hfzz*hfaem*vint(114)/sqm4
20268C...Loop over flavours; consider full gamma/Z structure
20269 DO 630 i=mmina,mmaxa
20270 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 630
20271 ei=kchg(iabs(i),1)/3d0
20272 ai=sign(1d0,ei)
20273 vi=ai-4d0*ei*xwv
20274 faczq=fzq*(ei**2*hfgg+ei*vi*hfgz+
20275 & (vi**2+ai**2)*hfzz)/hbw4
20276 DO 620 isde=1,2
20277 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 620
20278 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 620
20279 nchn=nchn+1
20280 isig(nchn,isde)=i
20281 isig(nchn,3-isde)=21
20282 isig(nchn,3)=1
20283 sigh(nchn)=faczq
20284 620 CONTINUE
20285 630 CONTINUE
20286 ENDIF
20287
20288 ELSEIF(isub.LE.40) THEN
20289 IF(isub.EQ.31) THEN
20290C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
20291 facwq=comfac*faca*as*aem/xw*1d0/12d0*
20292 & (sh2+uh2+2d0*sqm4*th)/(-sh*uh)
20293C...Propagators: as simulated in PYOFSH and as desired
20294 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
20295 CALL pywidt(24,sqm4,wdtp,wdte)
20296 gmmwc=sqrt(sqm4)*wdtp(0)
20297 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
20298 facwq=facwq*hbw4c/hbw4
20299 DO 650 i=mmina,mmaxa
20300 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 650
20301 ia=iabs(i)
20302 kchw=isign(1,kchg(ia,1)*isign(1,i))
20303 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
20304 DO 640 isde=1,2
20305 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 640
20306 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 640
20307 nchn=nchn+1
20308 isig(nchn,isde)=i
20309 isig(nchn,3-isde)=21
20310 isig(nchn,3)=1
20311 sigh(nchn)=facwq*vint(180+i)*widsc
20312 640 CONTINUE
20313 650 CONTINUE
20314
20315 ELSEIF(isub.EQ.32) THEN
20316C...f + g -> f + h0 (q + g -> q + h0 only)
20317 sqmhc=pmas(25,1)**2
20318 fhcq=comfac*faca*as*aem/xw*1d0/24d0
20319 DO 651 i=mmina,mmaxa
20320 ia=iabs(i)
20321 IF(ia.NE.5) GOTO 651
20322 sqml=pmas(ia,1)**2
20323 IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) sqml=sqml*
20324 & (log(max(4d0,parp(37)**2*sqml/paru(117)**2))/
20325 & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
20326 iua=ia+mod(ia,2)
20327 sqmq=sqml
20328 fachcq=fhcq*sqml/sqmw*
20329 & (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+
20330 & 2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*
20331 & (sqmhc-sqmq-sh)/sh)
20332 kchhc=isign(1,kchg(ia,1)*isign(1,i))
20333 DO 641 isde=1,2
20334 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 641
20335 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,1).EQ.0) GOTO 641
20336 nchn=nchn+1
20337 isig(nchn,isde)=i
20338 isig(nchn,3-isde)=21
20339 isig(nchn,3)=1
20340 sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)
20341 641 CONTINUE
20342 651 CONTINUE
20343
20344 ELSEIF(isub.EQ.33) THEN
20345C...f + gamma -> f + g (q + gamma -> q + g only)
20346 fgq=comfac*as*aem*8d0/3d0*(sh2+uh2)/(-sh*uh)
20347 DO 670 i=mmina,mmaxa
20348 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 670
20349 ei=kchg(iabs(i),1)/3d0
20350 facgq=fgq*ei**2
20351 DO 660 isde=1,2
20352 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 660
20353 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 660
20354 nchn=nchn+1
20355 isig(nchn,isde)=i
20356 isig(nchn,3-isde)=22
20357 isig(nchn,3)=1
20358 sigh(nchn)=facgq
20359 660 CONTINUE
20360 670 CONTINUE
20361
20362 ELSEIF(isub.EQ.34) THEN
20363C...f + gamma -> f + gamma
20364 fgq=comfac*aem**2*2d0*(sh2+uh2)/(-sh*uh)
20365 DO 690 i=mmina,mmaxa
20366 IF(i.EQ.0) GOTO 690
20367 ei=kchg(iabs(i),1)/3d0
20368 facgq=fgq*ei**4
20369 DO 680 isde=1,2
20370 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 680
20371 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 680
20372 nchn=nchn+1
20373 isig(nchn,isde)=i
20374 isig(nchn,3-isde)=22
20375 isig(nchn,3)=1
20376 sigh(nchn)=facgq
20377 680 CONTINUE
20378 690 CONTINUE
20379
20380 ELSEIF(isub.EQ.35) THEN
20381C...f + gamma -> f + (gamma*/Z0)
20382 IF(mint(15).EQ.22.AND.vint(3).LT.0d0) THEN
20383 fzqn=sh2+uh2+2d0*(sqm4-vint(3)**2)*th
20384 fzqdtm=vint(3)**2*sqm4-sh*(uh-vint(4)**2)
20385 ELSEIF(mint(16).EQ.22.AND.vint(4).LT.0d0) THEN
20386 fzqn=sh2+uh2+2d0*(sqm4-vint(4)**2)*th
20387 fzqdtm=vint(4)**2*sqm4-sh*(uh-vint(3)**2)
20388 ELSE
20389 fzqn=sh2+uh2+2d0*sqm4*th
20390 fzqdtm=-sh*uh
20391 ENDIF
20392 fzqn=comfac*2d0*aem**2*max(0d0,fzqn)
20393C...gamma, gamma/Z interference and Z couplings to final fermion pairs
20394 hfgg=0d0
20395 hfgz=0d0
20396 hfzz=0d0
20397 radc4=1d0+pyalps(sqm4)/paru(1)
20398 DO 700 i=1,min(16,mdcy(23,3))
20399 idc=i+mdcy(23,2)-1
20400 IF(mdme(idc,1).LT.0) GOTO 700
20401 imdm=0
20402 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
20403 & imdm=1
20404 IF(i.LE.8) THEN
20405 ef=kchg(i,1)/3d0
20406 af=sign(1d0,ef+0.1d0)
20407 vf=af-4d0*ef*xwv
20408 ELSEIF(i.LE.16) THEN
20409 ef=kchg(i+2,1)/3d0
20410 af=sign(1d0,ef+0.1d0)
20411 vf=af-4d0*ef*xwv
20412 ENDIF
20413 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
20414 IF(4d0*rm1.LT.1d0) THEN
20415 fcof=1d0
20416 IF(i.LE.8) fcof=3d0*radc4
20417 be34=sqrt(max(0d0,1d0-4d0*rm1))
20418 IF(imdm.EQ.1) THEN
20419 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
20420 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
20421 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
20422 & af**2*(1d0-4d0*rm1))*be34
20423 ENDIF
20424 ENDIF
20425 700 CONTINUE
20426C...Propagators: as simulated in PYOFSH and as desired
20427 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
20428 mint15=mint(15)
20429 mint(15)=1
20430 mint(61)=1
20431 CALL pywidt(23,sqm4,wdtp,wdte)
20432 mint(15)=mint15
20433 hfaem=(paru(108)/paru(2))*(2d0/3d0)
20434 hfgg=hfgg*hfaem*vint(111)/sqm4
20435 hfgz=hfgz*hfaem*vint(112)/sqm4
20436 hfzz=hfzz*hfaem*vint(114)/sqm4
20437C...Loop over flavours; consider full gamma/Z structure
20438 DO 720 i=mmina,mmaxa
20439 IF(i.EQ.0) GOTO 720
20440 ei=kchg(iabs(i),1)/3d0
20441 ai=sign(1d0,ei)
20442 vi=ai-4d0*ei*xwv
20443 faczq=ei**2*(ei**2*hfgg+ei*vi*hfgz+
20444 & (vi**2+ai**2)*hfzz)/hbw4
20445 fzqd=max(pmas(iabs(i),1)**2*sqm4,fzqdtm)
20446 DO 710 isde=1,2
20447 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 710
20448 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 710
20449 nchn=nchn+1
20450 isig(nchn,isde)=i
20451 isig(nchn,3-isde)=22
20452 isig(nchn,3)=1
20453 sigh(nchn)=faczq*fzqn/fzqd
20454 710 CONTINUE
20455 720 CONTINUE
20456
20457 ELSEIF(isub.EQ.36) THEN
20458C...f + gamma -> f' + W+/-
20459 fwq=comfac*aem**2/(2d0*xw)*
20460 & (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)
20461C...Propagators: as simulated in PYOFSH and as desired
20462 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
20463 CALL pywidt(24,sqm4,wdtp,wdte)
20464 gmmwc=sqrt(sqm4)*wdtp(0)
20465 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
20466 fwq=fwq*hbw4c/hbw4
20467 DO 740 i=mmina,mmaxa
20468 IF(i.EQ.0) GOTO 740
20469 ia=iabs(i)
20470 eia=abs(kchg(iabs(i),1)/3d0)
20471 facwq=fwq*(eia-sh/(sh+uh))**2
20472 kchw=isign(1,kchg(ia,1)*isign(1,i))
20473 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
20474 DO 730 isde=1,2
20475 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 730
20476 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 730
20477 nchn=nchn+1
20478 isig(nchn,isde)=i
20479 isig(nchn,3-isde)=22
20480 isig(nchn,3)=1
20481 sigh(nchn)=facwq*vint(180+i)*widsc
20482 730 CONTINUE
20483 740 CONTINUE
20484
20485 ELSEIF(isub.EQ.37) THEN
20486C...f + gamma -> f + h0
20487
20488 ELSEIF(isub.EQ.38) THEN
20489C...f + Z0 -> f + g (q + Z0 -> q + g only)
20490
20491 ELSEIF(isub.EQ.39) THEN
20492C...f + Z0 -> f + gamma
20493
20494 ELSEIF(isub.EQ.40) THEN
20495C...f + Z0 -> f + Z0
20496 ENDIF
20497
20498 ELSEIF(isub.LE.50) THEN
20499 IF(isub.EQ.41) THEN
20500C...f + Z0 -> f' + W+/-
20501
20502 ELSEIF(isub.EQ.42) THEN
20503C...f + Z0 -> f + h0
20504
20505 ELSEIF(isub.EQ.43) THEN
20506C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
20507
20508 ELSEIF(isub.EQ.44) THEN
20509C...f + W+/- -> f' + gamma
20510
20511 ELSEIF(isub.EQ.45) THEN
20512C...f + W+/- -> f' + Z0
20513
20514 ELSEIF(isub.EQ.46) THEN
20515C...f + W+/- -> f' + W+/-
20516
20517 ELSEIF(isub.EQ.47) THEN
20518C...f + W+/- -> f' + h0
20519
20520 ELSEIF(isub.EQ.48) THEN
20521C...f + h0 -> f + g (q + h0 -> q + g only)
20522
20523 ELSEIF(isub.EQ.49) THEN
20524C...f + h0 -> f + gamma
20525
20526 ELSEIF(isub.EQ.50) THEN
20527C...f + h0 -> f + Z0
20528 ENDIF
20529
20530 ELSEIF(isub.LE.60) THEN
20531 IF(isub.EQ.51) THEN
20532C...f + h0 -> f' + W+/-
20533
20534 ELSEIF(isub.EQ.52) THEN
20535C...f + h0 -> f + h0
20536
20537 ELSEIF(isub.EQ.53) THEN
20538C...g + g -> f + fbar (g + g -> q + qbar only)
20539 CALL pywidt(21,sh,wdtp,wdte)
20540 facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
20541 & uh2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
20542 facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
20543 & th2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
20544 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 750
20545 nchn=nchn+1
20546 isig(nchn,1)=21
20547 isig(nchn,2)=21
20548 isig(nchn,3)=1
20549 sigh(nchn)=facqq1
20550 nchn=nchn+1
20551 isig(nchn,1)=21
20552 isig(nchn,2)=21
20553 isig(nchn,3)=2
20554 sigh(nchn)=facqq2
20555 750 CONTINUE
20556
20557 ELSEIF(isub.EQ.54) THEN
20558C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
20559 CALL pywidt(21,sh,wdtp,wdte)
20560 wdtesu=0d0
20561 DO 760 i=1,min(8,mdcy(21,3))
20562 ef=kchg(i,1)/3d0
20563 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
20564 & wdte(i,4))
20565 760 CONTINUE
20566 facqq=comfac*aem*as*wdtesu*(th2+uh2)/(th*uh)
20567 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
20568 nchn=nchn+1
20569 isig(nchn,1)=21
20570 isig(nchn,2)=22
20571 isig(nchn,3)=1
20572 sigh(nchn)=facqq
20573 ENDIF
20574 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
20575 nchn=nchn+1
20576 isig(nchn,1)=22
20577 isig(nchn,2)=21
20578 isig(nchn,3)=1
20579 sigh(nchn)=facqq
20580 ENDIF
20581
20582 ELSEIF(isub.EQ.55) THEN
20583C...g + Z -> f + fbar (g + Z -> q + qbar only)
20584
20585 ELSEIF(isub.EQ.56) THEN
20586C...g + W -> f + f'bar (g + W -> q + q'bar only)
20587
20588 ELSEIF(isub.EQ.57) THEN
20589C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
20590
20591 ELSEIF(isub.EQ.58) THEN
20592C...gamma + gamma -> f + fbar
20593 CALL pywidt(22,sh,wdtp,wdte)
20594 wdtesu=0d0
20595 DO 770 i=1,min(12,mdcy(22,3))
20596 IF(i.LE.8) ef= kchg(i,1)/3d0
20597 IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
20598 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
20599 & wdte(i,4))
20600 770 CONTINUE
20601 facff=comfac*aem**2*wdtesu*2d0*(th2+uh2)/(th*uh)
20602 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
20603 nchn=nchn+1
20604 isig(nchn,1)=22
20605 isig(nchn,2)=22
20606 isig(nchn,3)=1
20607 sigh(nchn)=facff
20608 ENDIF
20609
20610 ELSEIF(isub.EQ.59) THEN
20611C...gamma + Z0 -> f + fbar
20612
20613 ELSEIF(isub.EQ.60) THEN
20614C...gamma + W+/- -> f + fbar'
20615 ENDIF
20616
20617 ELSEIF(isub.LE.70) THEN
20618 IF(isub.EQ.61) THEN
20619C...gamma + h0 -> f + fbar
20620
20621 ELSEIF(isub.EQ.62) THEN
20622C...Z0 + Z0 -> f + fbar
20623
20624 ELSEIF(isub.EQ.63) THEN
20625C...Z0 + W+/- -> f + fbar'
20626
20627 ELSEIF(isub.EQ.64) THEN
20628C...Z0 + h0 -> f + fbar
20629
20630 ELSEIF(isub.EQ.65) THEN
20631C...W+ + W- -> f + fbar
20632
20633 ELSEIF(isub.EQ.66) THEN
20634C...W+/- + h0 -> f + fbar'
20635
20636 ELSEIF(isub.EQ.67) THEN
20637C...h0 + h0 -> f + fbar
20638
20639 ELSEIF(isub.EQ.68) THEN
20640C...g + g -> g + g
20641 facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+2d0*th/sh+
20642 & th2/sh2)*faca
20643 facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+2d0*sh/uh+
20644 & sh2/uh2)*faca
20645 facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+2d0*uh/th+
20646 & uh2/th2)
20647 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 780
20648 nchn=nchn+1
20649 isig(nchn,1)=21
20650 isig(nchn,2)=21
20651 isig(nchn,3)=1
20652 sigh(nchn)=0.5d0*facgg1
20653 nchn=nchn+1
20654 isig(nchn,1)=21
20655 isig(nchn,2)=21
20656 isig(nchn,3)=2
20657 sigh(nchn)=0.5d0*facgg2
20658 nchn=nchn+1
20659 isig(nchn,1)=21
20660 isig(nchn,2)=21
20661 isig(nchn,3)=3
20662 sigh(nchn)=0.5d0*facgg3
20663 780 CONTINUE
20664
20665 ELSEIF(isub.EQ.69) THEN
20666C...gamma + gamma -> W+ + W-
20667 sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
20668 fprop=sh2/((sqmwe-th)*(sqmwe-uh))
20669 facww=comfac*6d0*aem**2*(1d0-fprop*(4d0/3d0+2d0*sqmwe/sh)+
20670 & fprop**2*(2d0/3d0+2d0*(sqmwe/sh)**2))*wids(24,1)
20671 IF(kfac(1,22)*kfac(2,22).EQ.0) GOTO 790
20672 nchn=nchn+1
20673 isig(nchn,1)=22
20674 isig(nchn,2)=22
20675 isig(nchn,3)=1
20676 sigh(nchn)=facww
20677 790 CONTINUE
20678
20679 ELSEIF(isub.EQ.70) THEN
20680C...gamma + W+/- -> Z0 + W+/-
20681 sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
20682 fprop=(th-sqmwe)**2/(-sh*(sqmwe-uh))
20683 faczw=comfac*6d0*aem**2*(xw1/xw)*
20684 & (1d0-fprop*(4d0/3d0+2d0*sqmwe/(th-sqmwe))+
20685 & fprop**2*(2d0/3d0+2d0*(sqmwe/(th-sqmwe))**2))*wids(23,2)
20686 DO 810 kchw=1,-1,-2
20687 DO 800 isde=1,2
20688 IF(kfac(isde,22)*kfac(3-isde,24*kchw).EQ.0) GOTO 800
20689 nchn=nchn+1
20690 isig(nchn,isde)=22
20691 isig(nchn,3-isde)=24*kchw
20692 isig(nchn,3)=1
20693 sigh(nchn)=faczw*wids(24,(5-kchw)/2)
20694 800 CONTINUE
20695 810 CONTINUE
20696 ENDIF
20697
20698 ELSEIF(isub.LE.80) THEN
20699 IF(isub.EQ.71) THEN
20700C...Z0 + Z0 -> Z0 + Z0
20701 IF(sh.LE.4.01d0*sqmz) GOTO 840
20702
20703 IF(mstp(46).LE.2) THEN
20704C...Exact scattering ME:s for on-mass-shell gauge bosons
20705 be2=1d0-4d0*sqmz/sh
20706 th=-0.5d0*sh*be2*(1d0-cth)
20707 uh=-0.5d0*sh*be2*(1d0+cth)
20708 IF(max(th,uh).GT.-1d0) GOTO 840
20709 shang=1d0/xw1*sqmw/sqmz*(1d0+be2)**2
20710 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
20711 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
20712 thang=1d0/xw1*sqmw/sqmz*(be2-cth)**2
20713 athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
20714 athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
20715 uhang=1d0/xw1*sqmw/sqmz*(be2+cth)**2
20716 auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
20717 auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
20718 faczz=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
20719 & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
20720 IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
20721 IF(mstp(46).EQ.1) faczz=faczz*((ashre+athre+auhre)**2+
20722 & (ashim+athim+auhim)**2)
20723 IF(mstp(46).EQ.2) faczz=0d0
20724
20725 ELSE
20726C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20727 faczz=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
20728 & abs(a00u+2.*a20u)**2
20729 ENDIF
20730 faczz=faczz*wids(23,1)
20731
20732 DO 830 i=mmin1,mmax1
20733 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 830
20734 ei=kchg(iabs(i),1)/3d0
20735 ai=sign(1d0,ei)
20736 vi=ai-4d0*ei*xwv
20737 avi=ai**2+vi**2
20738 DO 820 j=mmin2,mmax2
20739 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 820
20740 ej=kchg(iabs(j),1)/3d0
20741 aj=sign(1d0,ej)
20742 vj=aj-4d0*ej*xwv
20743 avj=aj**2+vj**2
20744 nchn=nchn+1
20745 isig(nchn,1)=i
20746 isig(nchn,2)=j
20747 isig(nchn,3)=1
20748 sigh(nchn)=0.5d0*faczz*avi*avj
20749 820 CONTINUE
20750 830 CONTINUE
20751 840 CONTINUE
20752
20753 ELSEIF(isub.EQ.72) THEN
20754C...Z0 + Z0 -> W+ + W-
20755 IF(sh.LE.4.01d0*sqmz) GOTO 870
20756
20757 IF(mstp(46).LE.2) THEN
20758C...Exact scattering ME:s for on-mass-shell gauge bosons
20759 be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
20760 cth2=cth**2
20761 th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
20762 uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
20763 IF(max(th,uh).GT.-1d0) GOTO 870
20764 shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
20765 & (1d0-2d0*sqmz/sh)
20766 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
20767 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
20768 atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
20769 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
20770 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
20771 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
20772 & 2d0*(sqmw+sqmz)/sh*be2*cth))
20773 atwim=0d0
20774 auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
20775 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
20776 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
20777 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
20778 & 2d0*(sqmw+sqmz)/sh*be2*cth))
20779 auwim=0d0
20780 a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
20781 a4im=0d0
20782 facww=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
20783 & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
20784 IF(mstp(46).LE.0) facww=facww*(ashre**2+ashim**2)
20785 IF(mstp(46).EQ.1) facww=facww*((ashre+atwre+auwre+a4re)**2+
20786 & (ashim+atwim+auwim+a4im)**2)
20787 IF(mstp(46).EQ.2) facww=facww*((atwre+auwre+a4re)**2+
20788 & (atwim+auwim+a4im)**2)
20789
20790 ELSE
20791C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20792 facww=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
20793 & abs(a00u-a20u)**2
20794 ENDIF
20795 facww=facww*wids(24,1)
20796
20797 DO 860 i=mmin1,mmax1
20798 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 860
20799 ei=kchg(iabs(i),1)/3d0
20800 ai=sign(1d0,ei)
20801 vi=ai-4d0*ei*xwv
20802 avi=ai**2+vi**2
20803 DO 850 j=mmin2,mmax2
20804 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 850
20805 ej=kchg(iabs(j),1)/3d0
20806 aj=sign(1d0,ej)
20807 vj=aj-4d0*ej*xwv
20808 avj=aj**2+vj**2
20809 nchn=nchn+1
20810 isig(nchn,1)=i
20811 isig(nchn,2)=j
20812 isig(nchn,3)=1
20813 sigh(nchn)=facww*avi*avj
20814 850 CONTINUE
20815 860 CONTINUE
20816 870 CONTINUE
20817
20818 ELSEIF(isub.EQ.73) THEN
20819C...Z0 + W+/- -> Z0 + W+/-
20820 IF(sh.LE.2d0*sqmz+2d0*sqmw) GOTO 900
20821
20822 IF(mstp(46).LE.2) THEN
20823C...Exact scattering ME:s for on-mass-shell gauge bosons
20824 be2=1d0-2d0*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2
20825 ep1=1d0-(sqmz-sqmw)/sh
20826 ep2=1d0+(sqmz-sqmw)/sh
20827 th=-0.5d0*sh*be2*(1d0-cth)
20828 uh=(sqmz-sqmw)**2/sh-0.5d0*sh*be2*(1d0+cth)
20829 IF(max(th,uh).GT.-1d0) GOTO 900
20830 thang=(be2-ep1*cth)*(be2-ep2*cth)
20831 athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
20832 athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
20833 aswre=-xw1/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+
20834 & 1d0/4d0*(be2+ep1*ep2)**2*((ep1-ep2)**2-4d0*be2*cth)+
20835 & 2d0*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-
20836 & 1d0/16d0*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)
20837 aswim=0d0
20838 auwre=xw1/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*
20839 & (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*
20840 & (be2+ep1*ep2*cth)*(2d0*ep2-ep2*cth+ep1)-
20841 & be2*(ep2+ep1*cth)**2*(be2-ep2**2*cth)-1d0/8d0*
20842 & (be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2d0*be2*(1d0-cth))+
20843 & 1d0/32d0*sh/sqmw*(be2+ep1*ep2*cth)**2*
20844 & (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*
20845 & (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*
20846 & (2d0*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*
20847 & (be2-ep1**2*cth)-1d0/8d0*(be2+ep1*ep2*cth)**2*
20848 & ((ep1+ep2)**2+2d0*be2*(1d0-cth))+1d0/32d0*sh/sqmw*
20849 & (be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)
20850 auwim=0d0
20851 a4re=xw1/sqmz*(ep1**2*ep2**2*(cth**2-1d0)-
20852 & 2d0*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2d0*be2*ep1*ep2)
20853 a4im=0d0
20854 faczw=comfac*1d0/(4096d0*paru(1)**2*4d0*xw1)*(aem/xw)**4*
20855 & (sh/sqmw)**2*sqrt(sqmz/sqmw)*sh2
20856 IF(mstp(46).LE.0) faczw=0d0
20857 IF(mstp(46).EQ.1) faczw=faczw*((athre+aswre+auwre+a4re)**2+
20858 & (athim+aswim+auwim+a4im)**2)
20859 IF(mstp(46).EQ.2) faczw=faczw*((aswre+auwre+a4re)**2+
20860 & (aswim+auwim+a4im)**2)
20861
20862 ELSE
20863C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20864 faczw=comfac*aem**2/(64d0*paru(1)**2*xw**2*xw1)*16d0*
20865 & abs(a20u+3.*a11u*sngl(cth))**2
20866 ENDIF
20867 faczw=faczw*wids(23,2)
20868
20869 DO 890 i=mmin1,mmax1
20870 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 890
20871 ei=kchg(iabs(i),1)/3d0
20872 ai=sign(1d0,ei)
20873 vi=ai-4d0*ei*xwv
20874 avi=ai**2+vi**2
20875 kchwi=isign(1,kchg(iabs(i),1)*isign(1,i))
20876 DO 880 j=mmin2,mmax2
20877 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 880
20878 ej=kchg(iabs(j),1)/3d0
20879 aj=sign(1d0,ej)
20880 vj=ai-4d0*ej*xwv
20881 avj=aj**2+vj**2
20882 kchwj=isign(1,kchg(iabs(j),1)*isign(1,j))
20883 nchn=nchn+1
20884 isig(nchn,1)=i
20885 isig(nchn,2)=j
20886 isig(nchn,3)=1
20887 sigh(nchn)=faczw*avi*vint(180+j)*wids(24,(5-kchwj)/2)
20888 nchn=nchn+1
20889 isig(nchn,1)=i
20890 isig(nchn,2)=j
20891 isig(nchn,3)=2
20892 sigh(nchn)=faczw*vint(180+i)*wids(24,(5-kchwi)/2)*avj
20893 880 CONTINUE
20894 890 CONTINUE
20895 900 CONTINUE
20896
20897 ELSEIF(isub.EQ.75) THEN
20898C...W+ + W- -> gamma + gamma
20899
20900 ELSEIF(isub.EQ.76) THEN
20901C...W+ + W- -> Z0 + Z0
20902 IF(sh.LE.4.01d0*sqmz) GOTO 930
20903
20904 IF(mstp(46).LE.2) THEN
20905C...Exact scattering ME:s for on-mass-shell gauge bosons
20906 be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
20907 cth2=cth**2
20908 th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
20909 uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
20910 IF(max(th,uh).GT.-1d0) GOTO 930
20911 shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
20912 & (1d0-2d0*sqmz/sh)
20913 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
20914 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
20915 atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
20916 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
20917 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
20918 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
20919 & 2d0*(sqmw+sqmz)/sh*be2*cth))
20920 atwim=0d0
20921 auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
20922 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
20923 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
20924 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
20925 & 2d0*(sqmw+sqmz)/sh*be2*cth))
20926 auwim=0d0
20927 a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
20928 a4im=0d0
20929 faczz=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
20930 & (sh/sqmw)**2*sh2
20931 IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
20932 IF(mstp(46).EQ.1) faczz=faczz*((ashre+atwre+auwre+a4re)**2+
20933 & (ashim+atwim+auwim+a4im)**2)
20934 IF(mstp(46).EQ.2) faczz=faczz*((atwre+auwre+a4re)**2+
20935 & (atwim+auwim+a4im)**2)
20936
20937 ELSE
20938C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20939 faczz=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
20940 & abs(a00u-a20u)**2
20941 ENDIF
20942 faczz=faczz*wids(23,1)
20943
20944 DO 920 i=mmin1,mmax1
20945 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 920
20946 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
20947 DO 910 j=mmin2,mmax2
20948 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 910
20949 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
20950 IF(ei*ej.GT.0d0) GOTO 910
20951 nchn=nchn+1
20952 isig(nchn,1)=i
20953 isig(nchn,2)=j
20954 isig(nchn,3)=1
20955 sigh(nchn)=0.5d0*faczz*vint(180+i)*vint(180+j)
20956 910 CONTINUE
20957 920 CONTINUE
20958 930 CONTINUE
20959
20960 ELSEIF(isub.EQ.77) THEN
20961C...W+/- + W+/- -> W+/- + W+/-
20962 IF(sh.LE.4.01d0*sqmw) GOTO 960
20963
20964 IF(mstp(46).LE.2) THEN
20965C...Exact scattering ME:s for on-mass-shell gauge bosons
20966 be2=1d0-4d0*sqmw/sh
20967 be4=be2**2
20968 cth2=cth**2
20969 cth3=cth**3
20970 th=-0.5d0*sh*be2*(1d0-cth)
20971 uh=-0.5d0*sh*be2*(1d0+cth)
20972 IF(max(th,uh).GT.-1d0) GOTO 960
20973 shang=(1d0+be2)**2
20974 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
20975 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
20976 thang=(be2-cth)**2
20977 athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
20978 athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
20979 uhang=(be2+cth)**2
20980 auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
20981 auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
20982 sgzang=1d0/sqmw*be2*(3d0-be2)**2*cth
20983 asgre=xw*sgzang
20984 asgim=0d0
20985 aszre=xw1*sh/(sh-sqmz)*sgzang
20986 aszim=0d0
20987 tgzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)+be2*(4d0-10d0*be2+
20988 & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2+be2*cth3)
20989 atgre=0.5d0*xw*sh/th*tgzang
20990 atgim=0d0
20991 atzre=0.5d0*xw1*sh/(th-sqmz)*tgzang
20992 atzim=0d0
20993 ugzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)-be2*(4d0-10d0*be2+
20994 & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2-be2*cth3)
20995 augre=0.5d0*xw*sh/uh*ugzang
20996 augim=0d0
20997 auzre=0.5d0*xw1*sh/(uh-sqmz)*ugzang
20998 auzim=0d0
20999 a4are=1d0/sqmw*(1d0+2d0*be2-6d0*be2*cth-cth2)
21000 a4aim=0d0
21001 a4sre=2d0/sqmw*(1d0+2d0*be2-cth2)
21002 a4sim=0d0
21003 fww=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
21004 & (sh/sqmw)**2*sh2
21005 IF(mstp(46).LE.0) THEN
21006 awware=ashre
21007 awwaim=ashim
21008 awwsre=0d0
21009 awwsim=0d0
21010 ELSEIF(mstp(46).EQ.1) THEN
21011 awware=ashre+athre+asgre+aszre+atgre+atzre+a4are
21012 awwaim=ashim+athim+asgim+aszim+atgim+atzim+a4aim
21013 awwsre=-athre-auhre+atgre+atzre+augre+auzre+a4sre
21014 awwsim=-athim-auhim+atgim+atzim+augim+auzim+a4sim
21015 ELSE
21016 awware=asgre+aszre+atgre+atzre+a4are
21017 awwaim=asgim+aszim+atgim+atzim+a4aim
21018 awwsre=atgre+atzre+augre+auzre+a4sre
21019 awwsim=atgim+atzim+augim+auzim+a4sim
21020 ENDIF
21021 awwa2=awware**2+awwaim**2
21022 awws2=awwsre**2+awwsim**2
21023
21024 ELSE
21025C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
21026 fwwa=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
21027 & abs(a00u+0.5*a20u+4.5*a11u*sngl(cth))**2
21028 fwws=comfac*(aem/(4d0*paru(1)*xw))**2*64d0*abs(a20u)**2
21029 ENDIF
21030
21031 DO 950 i=mmin1,mmax1
21032 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 950
21033 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
21034 DO 940 j=mmin2,mmax2
21035 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 940
21036 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
21037 IF(ei*ej.LT.0d0) THEN
21038C...W+W-
21039 IF(mstp(45).EQ.1) GOTO 940
21040 IF(mstp(46).LE.2) facww=fww*awwa2*wids(24,1)
21041 IF(mstp(46).GE.3) facww=fwwa*wids(24,1)
21042 ELSE
21043C...W+W+/W-W-
21044 IF(mstp(45).EQ.2) GOTO 940
21045 IF(mstp(46).LE.2) facww=fww*awws2
21046 IF(mstp(46).GE.3) facww=fwws
21047 IF(ei.GT.0d0) facww=facww*wids(24,4)
21048 IF(ei.LT.0d0) facww=facww*wids(24,5)
21049 ENDIF
21050 nchn=nchn+1
21051 isig(nchn,1)=i
21052 isig(nchn,2)=j
21053 isig(nchn,3)=1
21054 sigh(nchn)=facww*vint(180+i)*vint(180+j)
21055 IF(ei*ej.GT.0d0) sigh(nchn)=0.5d0*sigh(nchn)
21056 940 CONTINUE
21057 950 CONTINUE
21058 960 CONTINUE
21059
21060 ELSEIF(isub.EQ.78) THEN
21061C...W+/- + h0 -> W+/- + h0
21062
21063 ELSEIF(isub.EQ.79) THEN
21064C...h0 + h0 -> h0 + h0
21065
21066 ELSEIF(isub.EQ.80) THEN
21067C...q + gamma -> q' + pi+/-
21068 fqpi=comfac*(2d0*aem/9d0)*(-sh/th)*(1d0/sh2+1d0/th2)
21069 assh=pyalps(max(0.5d0,0.5d0*sh))
21070 q2fpsh=0.55d0/log(max(2d0,2d0*sh))
21071 delsh=uh*sqrt(assh*q2fpsh)
21072 asuh=pyalps(max(0.5d0,-0.5d0*uh))
21073 q2fpuh=0.55d0/log(max(2d0,-2d0*uh))
21074 deluh=sh*sqrt(asuh*q2fpuh)
21075 DO 980 i=max(-2,mmina),min(2,mmaxa)
21076 IF(i.EQ.0) GOTO 980
21077 ei=kchg(iabs(i),1)/3d0
21078 ej=sign(1d0-abs(ei),ei)
21079 DO 970 isde=1,2
21080 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 970
21081 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 970
21082 nchn=nchn+1
21083 isig(nchn,isde)=i
21084 isig(nchn,3-isde)=22
21085 isig(nchn,3)=1
21086 sigh(nchn)=fqpi*(ei*delsh+ej*deluh)**2
21087 970 CONTINUE
21088 980 CONTINUE
21089
21090 ENDIF
21091
21092C...C: 2 -> 2, tree diagrams with masses
21093
21094 ELSEIF(isub.LE.90) THEN
21095 IF(isub.EQ.81) THEN
21096C...q + qbar -> Q + Qbar
21097 sqma=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
21098 facqqb=comfac*as**2*4d0/9d0*(((th-sqma)**2+
21099 & (uh-sqma)**2)/sh2+2d0*sqma/sh)
21100 IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqma,0d0)
21101 wid2=1d0
21102 IF(mint(55).EQ.6) wid2=wids(6,1)
21103 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
21104 facqqb=facqqb*wid2
21105 DO 990 i=mmina,mmaxa
21106 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
21107 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 990
21108 nchn=nchn+1
21109 isig(nchn,1)=i
21110 isig(nchn,2)=-i
21111 isig(nchn,3)=1
21112 sigh(nchn)=facqqb
21113 990 CONTINUE
21114
21115 ELSEIF(isub.EQ.82) THEN
21116C...g + g -> Q + Qbar
21117 sqma=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
21118 IF(mstp(34).EQ.0) THEN
21119 facqq1=comfac*faca*as**2*(1d0/6d0)*((uh-sqma)/(th-sqma)-
21120 & 2d0*(uh-sqma)**2/sh2+4d0*(sqma/sh)*(th*uh-sqma**2)/
21121 & (th-sqma)**2)
21122 facqq2=comfac*faca*as**2*(1d0/6d0)*((th-sqma)/(uh-sqma)-
21123 & 2d0*(th-sqma)**2/sh2+4d0*(sqma/sh)*(th*uh-sqma**2)/
21124 & (uh-sqma)**2)
21125 ELSE
21126 facqq1=comfac*faca*as**2*(1d0/6d0)*((uh-sqma)/(th-sqma)-
21127 & 2.25d0*(uh-sqma)**2/sh2+4.5d0*(sqma/sh)*(th*uh-sqma**2)/
21128 & (th-sqma)**2+0.5d0*sqma*th/(th-sqma)**2-sqma**2/
21129 & (sh*(th-sqma)))
21130 facqq2=comfac*faca*as**2*(1d0/6d0)*((th-sqma)/(uh-sqma)-
21131 & 2.25d0*(th-sqma)**2/sh2+4.5d0*(sqma/sh)*(th*uh-sqma**2)/
21132 & (uh-sqma)**2+0.5d0*sqma*uh/(uh-sqma)**2-sqma**2/
21133 & (sh*(uh-sqma)))
21134 ENDIF
21135 IF(mstp(35).GE.1) THEN
21136 fatre=pyhfth(sh,sqma,2d0/7d0)
21137 facqq1=facqq1*fatre
21138 facqq2=facqq2*fatre
21139 ENDIF
21140 wid2=1d0
21141 IF(mint(55).EQ.6) wid2=wids(6,1)
21142 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
21143 facqq1=facqq1*wid2
21144 facqq2=facqq2*wid2
21145 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1000
21146 nchn=nchn+1
21147 isig(nchn,1)=21
21148 isig(nchn,2)=21
21149 isig(nchn,3)=1
21150 sigh(nchn)=facqq1
21151 nchn=nchn+1
21152 isig(nchn,1)=21
21153 isig(nchn,2)=21
21154 isig(nchn,3)=2
21155 sigh(nchn)=facqq2
21156 1000 CONTINUE
21157
21158 ELSEIF(isub.EQ.83) THEN
21159C...f + q -> f' + Q
21160 facqqs=comfac*(0.5d0*aem/xw)**2*sh*(sh-sqm3)/(sqmw-th)**2
21161 facqqu=comfac*(0.5d0*aem/xw)**2*uh*(uh-sqm3)/(sqmw-th)**2
21162 DO 1020 i=mmin1,mmax1
21163 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1020
21164 DO 1010 j=mmin2,mmax2
21165 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1010
21166 IF(i*j.GT.0.AND.mod(iabs(i+j),2).EQ.0) GOTO 1010
21167 IF(i*j.LT.0.AND.mod(iabs(i+j),2).EQ.1) GOTO 1010
21168 IF(iabs(i).LT.mint(55).AND.mod(iabs(i+mint(55)),2).EQ.1)
21169 & THEN
21170 nchn=nchn+1
21171 isig(nchn,1)=i
21172 isig(nchn,2)=j
21173 isig(nchn,3)=1
21174 IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
21175 & (iabs(i)+1)/2)*vint(180+j)
21176 IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(i)/2,
21177 & (mint(55)+1)/2)*vint(180+j)
21178 wid2=1d0
21179 IF(i.GT.0) THEN
21180 IF(mint(55).EQ.6) wid2=wids(6,2)
21181 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
21182 & wids(mint(55),2)
21183 ELSE
21184 IF(mint(55).EQ.6) wid2=wids(6,3)
21185 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
21186 & wids(mint(55),3)
21187 ENDIF
21188 IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
21189 IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
21190 ENDIF
21191 IF(iabs(j).LT.mint(55).AND.mod(iabs(j+mint(55)),2).EQ.1)
21192 & THEN
21193 nchn=nchn+1
21194 isig(nchn,1)=i
21195 isig(nchn,2)=j
21196 isig(nchn,3)=2
21197 IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
21198 & (iabs(j)+1)/2)*vint(180+i)
21199 IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(j)/2,
21200 & (mint(55)+1)/2)*vint(180+i)
21201 IF(j.GT.0) THEN
21202 IF(mint(55).EQ.6) wid2=wids(6,2)
21203 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
21204 & wids(mint(55),2)
21205 ELSE
21206 IF(mint(55).EQ.6) wid2=wids(6,3)
21207 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
21208 & wids(mint(55),3)
21209 ENDIF
21210 IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
21211 IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
21212 ENDIF
21213 1010 CONTINUE
21214 1020 CONTINUE
21215
21216 ELSEIF(isub.EQ.84) THEN
21217C...g + gamma -> Q + Qbar
21218 sqma=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
21219 fmtu=sqma/(sqma-th)+sqma/(sqma-uh)
21220 facqq=comfac*as*aem*(kchg(iabs(mint(55)),1)/3d0)**2*
21221 & ((sqma-th)/(sqma-uh)+(sqma-uh)/(sqma-th)+4d0*fmtu*(1d0-fmtu))
21222 IF(mstp(35).GE.1) facqq=facqq*pyhfth(sh,sqma,0d0)
21223 wid2=1d0
21224 IF(mint(55).EQ.6) wid2=wids(6,1)
21225 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
21226 facqq=facqq*wid2
21227 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
21228 nchn=nchn+1
21229 isig(nchn,1)=21
21230 isig(nchn,2)=22
21231 isig(nchn,3)=1
21232 sigh(nchn)=facqq
21233 ENDIF
21234 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
21235 nchn=nchn+1
21236 isig(nchn,1)=22
21237 isig(nchn,2)=21
21238 isig(nchn,3)=1
21239 sigh(nchn)=facqq
21240 ENDIF
21241
21242 ELSEIF(isub.EQ.85) THEN
21243C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
21244 sqma=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
21245 fmtu=sqma/(sqma-th)+sqma/(sqma-uh)
21246 facff=comfac*aem**2*(kchg(iabs(mint(56)),1)/3d0)**4*2d0*
21247 & ((sqma-th)/(sqma-uh)+(sqma-uh)/(sqma-th)+4d0*fmtu*(1d0-fmtu))
21248 IF(iabs(mint(56)).LT.10) facff=3d0*facff
21249 IF(iabs(mint(56)).LT.10.AND.mstp(35).GE.1)
21250 & facff=facff*pyhfth(sh,sqma,1d0)
21251 wid2=1d0
21252 IF(mint(56).EQ.6) wid2=wids(6,1)
21253 IF(mint(56).EQ.7.OR.mint(56).EQ.8) wid2=wids(mint(56),1)
21254 IF(mint(56).EQ.17) wid2=wids(17,1)
21255 facff=facff*wid2
21256 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
21257 nchn=nchn+1
21258 isig(nchn,1)=22
21259 isig(nchn,2)=22
21260 isig(nchn,3)=1
21261 sigh(nchn)=facff
21262 ENDIF
21263
21264 ELSEIF(isub.EQ.86) THEN
21265C...g + g -> J/Psi + g
21266 facqqg=comfac*as**3*(5d0/9d0)*parp(38)*sqrt(sqm3)*
21267 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
21268 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
21269 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21270 nchn=nchn+1
21271 isig(nchn,1)=21
21272 isig(nchn,2)=21
21273 isig(nchn,3)=1
21274 sigh(nchn)=facqqg
21275 ENDIF
21276
21277 ELSEIF(isub.EQ.87) THEN
21278C...g + g -> chi_0c + g
21279 pgtw=(sh*th+th*uh+uh*sh)/sh2
21280 qgtw=(sh*th*uh)/sh**3
21281 rgtw=sqm3/sh
21282 facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
21283 & (9d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
21284 & 6d0*rgtw*pgtw**3*qgtw*(2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)-
21285 & pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)+
21286 & 2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)+6d0*rgtw**2*qgtw**4)/
21287 & (qgtw*(qgtw-rgtw*pgtw)**4)
21288 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21289 nchn=nchn+1
21290 isig(nchn,1)=21
21291 isig(nchn,2)=21
21292 isig(nchn,3)=1
21293 sigh(nchn)=facqqg
21294 ENDIF
21295
21296 ELSEIF(isub.EQ.88) THEN
21297C...g + g -> chi_1c + g
21298 pgtw=(sh*th+th*uh+uh*sh)/sh2
21299 qgtw=(sh*th*uh)/sh**3
21300 rgtw=sqm3/sh
21301 facqqg=comfac*as**3*12d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
21302 & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)+2d0*qgtw*(-rgtw**4+
21303 & 5d0*rgtw**2*pgtw+pgtw**2)-15d0*rgtw*qgtw**2)/
21304 & (qgtw-rgtw*pgtw)**4
21305 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21306 nchn=nchn+1
21307 isig(nchn,1)=21
21308 isig(nchn,2)=21
21309 isig(nchn,3)=1
21310 sigh(nchn)=facqqg
21311 ENDIF
21312
21313 ELSEIF(isub.EQ.89) THEN
21314C...g + g -> chi_2c + g
21315 pgtw=(sh*th+th*uh+uh*sh)/sh2
21316 qgtw=(sh*th*uh)/sh**3
21317 rgtw=sqm3/sh
21318 facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
21319 & (12d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
21320 & 3d0*rgtw*pgtw**3*qgtw*(8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)+
21321 & 2d0*pgtw**2*qgtw**2*(-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)+
21322 & rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)+12d0*rgtw**2*
21323 & qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
21324 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21325 nchn=nchn+1
21326 isig(nchn,1)=21
21327 isig(nchn,2)=21
21328 isig(nchn,3)=1
21329 sigh(nchn)=facqqg
21330 ENDIF
21331 ENDIF
21332
21333C...D: Mimimum bias processes
21334
21335 ELSEIF(isub.LE.100) THEN
21336 IF(isub.EQ.91) THEN
21337C...Elastic scattering
21338 sigs=vint(315)*vint(316)*sigt(0,0,1)
21339
21340 ELSEIF(isub.EQ.92) THEN
21341C...Single diffractive scattering (first side, i.e. XB)
21342 sigs=vint(315)*vint(316)*sigt(0,0,2)
21343
21344 ELSEIF(isub.EQ.93) THEN
21345C...Single diffractive scattering (second side, i.e. AX)
21346 sigs=vint(315)*vint(316)*sigt(0,0,3)
21347
21348 ELSEIF(isub.EQ.94) THEN
21349C...Double diffractive scattering
21350 sigs=vint(315)*vint(316)*sigt(0,0,4)
21351
21352 ELSEIF(isub.EQ.95) THEN
21353C...Low-pT scattering
21354 sigs=vint(315)*vint(316)*sigt(0,0,5)
21355
21356 ELSEIF(isub.EQ.96) THEN
21357C...Multiple interactions: sum of QCD processes
21358 CALL pywidt(21,sh,wdtp,wdte)
21359
21360C...q + q' -> q + q'
21361 facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
21362 facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
21363 & mstp(34)*2d0/3d0*uh2/(sh*th))
21364 facqq2=comfac*as**2*4d0/9d0*(sh2+th2)/uh2
21365 facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
21366 ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
21367 DO 1040 i=-5,5
21368 IF(i.EQ.0) GOTO 1040
21369 DO 1030 j=-5,5
21370 IF(j.EQ.0) GOTO 1030
21371 nchn=nchn+1
21372 isig(nchn,1)=i
21373 isig(nchn,2)=j
21374 isig(nchn,3)=111
21375 sigh(nchn)=facqq1
21376 IF(i.EQ.-j) sigh(nchn)=facqqb
21377 IF(i.EQ.j) THEN
21378 sigh(nchn)=0.5d0*facqq1*ratqqi
21379 nchn=nchn+1
21380 isig(nchn,1)=i
21381 isig(nchn,2)=j
21382 isig(nchn,3)=112
21383 sigh(nchn)=0.5d0*facqq2*ratqqi
21384 ENDIF
21385 1030 CONTINUE
21386 1040 CONTINUE
21387
21388C...q + qbar -> q' + qbar' or g + g
21389 facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
21390 & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))
21391 facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
21392 & uh2/sh2)
21393 facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
21394 & th2/sh2)
21395 DO 1050 i=-5,5
21396 IF(i.EQ.0) GOTO 1050
21397 nchn=nchn+1
21398 isig(nchn,1)=i
21399 isig(nchn,2)=-i
21400 isig(nchn,3)=121
21401 sigh(nchn)=facqqb
21402 nchn=nchn+1
21403 isig(nchn,1)=i
21404 isig(nchn,2)=-i
21405 isig(nchn,3)=131
21406 sigh(nchn)=0.5d0*facgg1
21407 nchn=nchn+1
21408 isig(nchn,1)=i
21409 isig(nchn,2)=-i
21410 isig(nchn,3)=132
21411 sigh(nchn)=0.5d0*facgg2
21412 1050 CONTINUE
21413
21414C...q + g -> q + g
21415 facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
21416 & uh/sh)*faca
21417 facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
21418 & sh/uh)
21419 DO 1070 i=-5,5
21420 IF(i.EQ.0) GOTO 1070
21421 DO 1060 isde=1,2
21422 nchn=nchn+1
21423 isig(nchn,isde)=i
21424 isig(nchn,3-isde)=21
21425 isig(nchn,3)=281
21426 sigh(nchn)=facqg1
21427 nchn=nchn+1
21428 isig(nchn,isde)=i
21429 isig(nchn,3-isde)=21
21430 isig(nchn,3)=282
21431 sigh(nchn)=facqg2
21432 1060 CONTINUE
21433 1070 CONTINUE
21434
21435C...g + g -> q + qbar or g + g
21436 facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
21437 & uh2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
21438 facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
21439 & th2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
21440 facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
21441 & 2d0*th/sh+th2/sh2)*faca
21442 facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
21443 & 2d0*sh/uh+sh2/uh2)*faca
21444 facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3+
21445 & 2d0*uh/th+uh2/th2)
21446 nchn=nchn+1
21447 isig(nchn,1)=21
21448 isig(nchn,2)=21
21449 isig(nchn,3)=531
21450 sigh(nchn)=facqq1
21451 nchn=nchn+1
21452 isig(nchn,1)=21
21453 isig(nchn,2)=21
21454 isig(nchn,3)=532
21455 sigh(nchn)=facqq2
21456 nchn=nchn+1
21457 isig(nchn,1)=21
21458 isig(nchn,2)=21
21459 isig(nchn,3)=681
21460 sigh(nchn)=0.5d0*facgg1
21461 nchn=nchn+1
21462 isig(nchn,1)=21
21463 isig(nchn,2)=21
21464 isig(nchn,3)=682
21465 sigh(nchn)=0.5d0*facgg2
21466 nchn=nchn+1
21467 isig(nchn,1)=21
21468 isig(nchn,2)=21
21469 isig(nchn,3)=683
21470 sigh(nchn)=0.5d0*facgg3
21471
21472 ELSEIF(isub.EQ.99) THEN
21473C...f + gamma* -> f.
21474 IF(mint(107).EQ.4) THEN
21475 q2ga=vint(307)
21476 p2ga=vint(308)
21477 isde=2
21478 ELSE
21479 q2ga=vint(308)
21480 p2ga=vint(307)
21481 isde=1
21482 ENDIF
21483 comfac=paru(5)*4d0*paru(1)**2*paru(101)*vint(315)*vint(316)
21484 pm2rho=pmas(pycomp(113),1)**2
21485 IF(mstp(19).EQ.0) THEN
21486 comfac=comfac/q2ga
21487 ELSEIF(mstp(19).EQ.1) THEN
21488 comfac=comfac/(q2ga+pm2rho)
21489 ELSEIF(mstp(19).EQ.2) THEN
21490 comfac=comfac*q2ga/(q2ga+pm2rho)**2
21491 ELSE
21492 comfac=comfac*q2ga/(q2ga+pm2rho)**2
21493 w2ga=vint(2)
21494 IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
21495 rdrds=4.1d-3*w2ga**2.167d0/((q2ga+0.15d0*w2ga)**2*
21496 & q2ga**0.75d0)*(1d0+0.11d0*q2ga*p2ga/(1d0+0.02d0*p2ga**2))
21497 xga=q2ga/(w2ga+vint(307)+vint(308))
21498 ELSE
21499 rdrds=1.5d-4*w2ga**2.167d0/((q2ga+0.041d0*w2ga)**2*
21500 & q2ga**0.57d0)
21501 xga=q2ga/(w2ga+q2ga-pmas(pycomp(mint(10+isde)),1)**2)
21502 ENDIF
21503 comfac=comfac*exp(-max(1d-10,rdrds))
21504 IF(mstp(19).EQ.4) comfac=comfac/max(1d-2,1d0-xga)
21505 ENDIF
21506 DO 1075 i=mmina,mmaxa
21507 IF(i.EQ.0.OR.kfac(isde,i).EQ.0) GOTO 1075
21508 IF(iabs(i).LT.10.AND.iabs(i).GT.mstp(58)) GOTO 1075
21509 ei=kchg(iabs(i),1)/3d0
21510 nchn=nchn+1
21511 isig(nchn,isde)=i
21512 isig(nchn,3-isde)=22
21513 isig(nchn,3)=1
21514 sigh(nchn)=comfac*ei**2
21515 1075 CONTINUE
21516 ENDIF
21517
21518C...E: 2 -> 1, loop diagrams
21519
21520 ELSEIF(isub.LE.110) THEN
21521 IF(isub.EQ.101) THEN
21522C...g + g -> gamma*/Z0
21523
21524 ELSEIF(isub.EQ.102) THEN
21525C...g + g -> h0 (or H0, or A0)
21526 CALL pywidt(kfhigg,sh,wdtp,wdte)
21527 hs=shr*wdtp(0)
21528 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
21529 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
21530 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
21531 & facbw=0d0
21532 hi=shr*wdtp(13)/32d0
21533 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1080
21534 nchn=nchn+1
21535 isig(nchn,1)=21
21536 isig(nchn,2)=21
21537 isig(nchn,3)=1
21538 sigh(nchn)=hi*facbw*hf
21539 1080 CONTINUE
21540
21541 ELSEIF(isub.EQ.103) THEN
21542C...gamma + gamma -> h0 (or H0, or A0)
21543 CALL pywidt(kfhigg,sh,wdtp,wdte)
21544 hs=shr*wdtp(0)
21545 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
21546 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
21547 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
21548 & facbw=0d0
21549 hi=shr*wdtp(14)*2d0
21550 IF(kfac(1,22)*kfac(2,22).EQ.0) GOTO 1090
21551 nchn=nchn+1
21552 isig(nchn,1)=22
21553 isig(nchn,2)=22
21554 isig(nchn,3)=1
21555 sigh(nchn)=hi*facbw*hf
21556 1090 CONTINUE
21557
21558 ELSEIF(isub.EQ.104) THEN
21559C...g + g -> chi_c0.
21560 kc=pycomp(10441)
21561 facbw=comfac*12d0*as**2*parp(39)*pmas(kc,2)/
21562 & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
21563 IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
21564 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21565 nchn=nchn+1
21566 isig(nchn,1)=21
21567 isig(nchn,2)=21
21568 isig(nchn,3)=1
21569 sigh(nchn)=facbw
21570 ENDIF
21571
21572 ELSEIF(isub.EQ.105) THEN
21573C...g + g -> chi_c2.
21574 kc=pycomp(445)
21575 facbw=comfac*16d0*as**2*parp(39)*pmas(kc,2)/
21576 & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
21577 IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
21578 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21579 nchn=nchn+1
21580 isig(nchn,1)=21
21581 isig(nchn,2)=21
21582 isig(nchn,3)=1
21583 sigh(nchn)=facbw
21584 ENDIF
21585
21586C...Continuation C: 2 -> 2, tree diagrams with masses.
21587
21588 ELSEIF(isub.EQ.106) THEN
21589C...g + g -> J/Psi + gamma.
21590 eq=2d0/3d0
21591 facqqg=comfac*aem*eq**2*as**2*(4d0/3d0)*parp(38)*sqrt(sqm3)*
21592 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
21593 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
21594 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
21595 nchn=nchn+1
21596 isig(nchn,1)=21
21597 isig(nchn,2)=21
21598 isig(nchn,3)=1
21599 sigh(nchn)=facqqg
21600 ENDIF
21601
21602 ELSEIF(isub.EQ.107) THEN
21603C...g + gamma -> J/Psi + g.
21604 eq=2d0/3d0
21605 facqqg=comfac*aem*eq**2*as**2*(32d0/3d0)*parp(38)*sqrt(sqm3)*
21606 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
21607 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
21608 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
21609 nchn=nchn+1
21610 isig(nchn,1)=21
21611 isig(nchn,2)=22
21612 isig(nchn,3)=1
21613 sigh(nchn)=facqqg
21614 ENDIF
21615 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
21616 nchn=nchn+1
21617 isig(nchn,1)=22
21618 isig(nchn,2)=21
21619 isig(nchn,3)=1
21620 sigh(nchn)=facqqg
21621 ENDIF
21622
21623 ELSEIF(isub.EQ.108) THEN
21624C...gamma + gamma -> J/Psi + gamma.
21625 eq=2d0/3d0
21626 facqqg=comfac*aem**3*eq**6*384d0*parp(38)*sqrt(sqm3)*
21627 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
21628 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
21629 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
21630 nchn=nchn+1
21631 isig(nchn,1)=22
21632 isig(nchn,2)=22
21633 isig(nchn,3)=1
21634 sigh(nchn)=facqqg
21635 ENDIF
21636
21637C...F: 2 -> 2, box diagrams
21638
21639 ELSEIF(isub.EQ.110) THEN
21640C...f + fbar -> gamma + h0
21641 thuh=max(th*uh,sh*ckin(3)**2)
21642 fachg=comfac*(3d0*aem**4)/(2d0*paru(1)**2*xw*sqmw)*sh*thuh
21643 fachg=fachg*wids(kfhigg,2)
21644C...Calculate loop contributions for intermediate gamma* and Z0
21645 cigtot=cmplx(0.,0.)
21646 ciztot=cmplx(0.,0.)
21647 jmax=3*mstp(1)+1
21648 DO 1100 j=1,jmax
21649 IF(j.LE.2*mstp(1)) THEN
21650 fnc=1d0
21651 ej=kchg(j,1)/3d0
21652 aj=sign(1d0,ej+0.1d0)
21653 vj=aj-4d0*ej*xwv
21654 balp=sqm4/(2d0*pmas(j,1))**2
21655 bbet=sh/(2d0*pmas(j,1))**2
21656 ELSEIF(j.LE.3*mstp(1)) THEN
21657 fnc=3d0
21658 jl=2*(j-2*mstp(1))-1
21659 ej=kchg(10+jl,1)/3d0
21660 aj=sign(1d0,ej+0.1d0)
21661 vj=aj-4d0*ej*xwv
21662 balp=sqm4/(2d0*pmas(10+jl,1))**2
21663 bbet=sh/(2d0*pmas(10+jl,1))**2
21664 ELSE
21665 balp=sqm4/(2d0*pmas(24,1))**2
21666 bbet=sh/(2d0*pmas(24,1))**2
21667 ENDIF
21668 babi=1d0/(balp-bbet)
21669 IF(balp.LT.1d0) THEN
21670 f0alp=cmplx(sngl(asin(sqrt(balp))),0.)
21671 f1alp=f0alp**2
21672 ELSE
21673 f0alp=cmplx(sngl(log(sqrt(balp)+sqrt(balp-1d0))),
21674 & -sngl(0.5d0*paru(1)))
21675 f1alp=-f0alp**2
21676 ENDIF
21677 f2alp=sngl(sqrt(abs(balp-1d0)/balp))*f0alp
21678 IF(bbet.LT.1d0) THEN
21679 f0bet=cmplx(sngl(asin(sqrt(bbet))),0.)
21680 f1bet=f0bet**2
21681 ELSE
21682 f0bet=cmplx(sngl(log(sqrt(bbet)+sqrt(bbet-1d0))),
21683 & -sngl(0.5d0*paru(1)))
21684 f1bet=-f0bet**2
21685 ENDIF
21686 f2bet=sngl(sqrt(abs(bbet-1d0)/bbet))*f0bet
21687 IF(j.LE.3*mstp(1)) THEN
21688 fif=sngl(0.5d0*babi)+sngl(babi**2)*(sngl(0.5d0*(1d0-balp+
21689 & bbet))*(f1bet-f1alp)+sngl(bbet)*(f2bet-f2alp))
21690 cigtot=cigtot+sngl(fnc*ej**2)*fif
21691 ciztot=ciztot+sngl(fnc*ej*vj)*fif
21692 ELSE
21693 txw=xw/xw1
21694 cigtot=cigtot-0.5*(sngl(babi*(1.5d0+balp))+sngl(babi**2)*
21695 & (sngl(1.5d0-3d0*balp+4d0*bbet)*(f1bet-f1alp)+
21696 & sngl(bbet*(2d0*balp+3d0))*(f2bet-f2alp)))
21697 ciztot=ciztot-sngl(0.5d0*babi*xw1)*(sngl(5d0-txw+2d0*balp*
21698 & (1d0-txw))*(1.+sngl(2d0*babi*bbet)*(f2bet-f2alp))+
21699 & sngl(babi*(4d0*bbet*(3d0-txw)-(2d0*balp-1d0)*(5d0-txw)))*
21700 & (f1bet-f1alp))
21701 ENDIF
21702 1100 CONTINUE
21703 cigtot=cigtot/sngl(sh)
21704 ciztot=ciztot*sngl(xwc)/cmplx(sngl(sh-sqmz),sngl(gmmz))
21705C...Loop over initial flavours
21706 DO 1110 i=mmina,mmaxa
21707 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1110
21708 ei=kchg(iabs(i),1)/3d0
21709 ai=sign(1d0,ei)
21710 vi=ai-4d0*ei*xwv
21711 fcoi=1d0
21712 IF(iabs(i).LE.10) fcoi=faca/3d0
21713 nchn=nchn+1
21714 isig(nchn,1)=i
21715 isig(nchn,2)=-i
21716 isig(nchn,3)=1
21717 sigh(nchn)=fachg*fcoi*(abs(sngl(ei)*cigtot+sngl(vi)*
21718 & ciztot)**2+ai**2*abs(ciztot)**2)
21719 1110 CONTINUE
21720
21721 ENDIF
21722
21723 ELSEIF(isub.LE.120) THEN
21724 IF(isub.EQ.111) THEN
21725C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
21726 a5stur=0d0
21727 a5stui=0d0
21728 DO 1120 i=1,2*mstp(1)
21729 sqmq=pmas(i,1)**2
21730 epss=4d0*sqmq/sh
21731 epsh=4d0*sqmq/sqmh
21732 CALL pywaux(1,epss,w1sr,w1si)
21733 CALL pywaux(1,epsh,w1hr,w1hi)
21734 CALL pywaux(2,epss,w2sr,w2si)
21735 CALL pywaux(2,epsh,w2hr,w2hi)
21736 a5stur=a5stur+epsh*(1d0+sh/(th+uh)*(w1sr-w1hr)+
21737 & (0.25d0-sqmq/(th+uh))*(w2sr-w2hr))
21738 a5stui=a5stui+epsh*(sh/(th+uh)*(w1si-w1hi)+
21739 & (0.25d0-sqmq/(th+uh))*(w2si-w2hi))
21740 1120 CONTINUE
21741 facgh=comfac*faca/(144d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
21742 & sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)
21743 facgh=facgh*wids(25,2)
21744 DO 1130 i=mmina,mmaxa
21745 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
21746 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1130
21747 nchn=nchn+1
21748 isig(nchn,1)=i
21749 isig(nchn,2)=-i
21750 isig(nchn,3)=1
21751 sigh(nchn)=facgh
21752 1130 CONTINUE
21753
21754 ELSEIF(isub.EQ.112) THEN
21755C...f + g -> f + h0 (q + g -> q + h0 only)
21756 a5tsur=0d0
21757 a5tsui=0d0
21758 DO 1140 i=1,2*mstp(1)
21759 sqmq=pmas(i,1)**2
21760 epst=4d0*sqmq/th
21761 epsh=4d0*sqmq/sqmh
21762 CALL pywaux(1,epst,w1tr,w1ti)
21763 CALL pywaux(1,epsh,w1hr,w1hi)
21764 CALL pywaux(2,epst,w2tr,w2ti)
21765 CALL pywaux(2,epsh,w2hr,w2hi)
21766 a5tsur=a5tsur+epsh*(1d0+th/(sh+uh)*(w1tr-w1hr)+
21767 & (0.25d0-sqmq/(sh+uh))*(w2tr-w2hr))
21768 a5tsui=a5tsui+epsh*(th/(sh+uh)*(w1ti-w1hi)+
21769 & (0.25d0-sqmq/(sh+uh))*(w2ti-w2hi))
21770 1140 CONTINUE
21771 facqh=comfac*faca/(384d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
21772 & sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)
21773 facqh=facqh*wids(25,2)
21774 DO 1160 i=mmina,mmaxa
21775 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 1160
21776 DO 1150 isde=1,2
21777 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1150
21778 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 1150
21779 nchn=nchn+1
21780 isig(nchn,isde)=i
21781 isig(nchn,3-isde)=21
21782 isig(nchn,3)=1
21783 sigh(nchn)=facqh
21784 1150 CONTINUE
21785 1160 CONTINUE
21786
21787 ELSEIF(isub.EQ.113) THEN
21788C...g + g -> g + h0
21789 a2stur=0d0
21790 a2stui=0d0
21791 a2ustr=0d0
21792 a2usti=0d0
21793 a2tusr=0d0
21794 a2tusi=0d0
21795 a4stur=0d0
21796 a4stui=0d0
21797 DO 1170 i=1,2*mstp(1)
21798 sqmq=pmas(i,1)**2
21799 epss=4d0*sqmq/sh
21800 epst=4d0*sqmq/th
21801 epsu=4d0*sqmq/uh
21802 epsh=4d0*sqmq/sqmh
21803 IF(epsh.LT.1d-6) GOTO 1170
21804 CALL pywaux(1,epss,w1sr,w1si)
21805 CALL pywaux(1,epst,w1tr,w1ti)
21806 CALL pywaux(1,epsu,w1ur,w1ui)
21807 CALL pywaux(1,epsh,w1hr,w1hi)
21808 CALL pywaux(2,epss,w2sr,w2si)
21809 CALL pywaux(2,epst,w2tr,w2ti)
21810 CALL pywaux(2,epsu,w2ur,w2ui)
21811 CALL pywaux(2,epsh,w2hr,w2hi)
21812 CALL pyi3au(epss,th/uh,y3stur,y3stui)
21813 CALL pyi3au(epss,uh/th,y3sutr,y3suti)
21814 CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
21815 CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
21816 CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
21817 CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
21818 CALL pyi3au(epsh,sqmh/sh*th/uh,yhstur,yhstui)
21819 CALL pyi3au(epsh,sqmh/sh*uh/th,yhsutr,yhsuti)
21820 CALL pyi3au(epsh,sqmh/th*sh/uh,yhtsur,yhtsui)
21821 CALL pyi3au(epsh,sqmh/th*uh/sh,yhtusr,yhtusi)
21822 CALL pyi3au(epsh,sqmh/uh*sh/th,yhustr,yhusti)
21823 CALL pyi3au(epsh,sqmh/uh*th/sh,yhutsr,yhutsi)
21824 w3stur=yhstur-y3stur-y3utsr
21825 w3stui=yhstui-y3stui-y3utsi
21826 w3sutr=yhsutr-y3sutr-y3tusr
21827 w3suti=yhsuti-y3suti-y3tusi
21828 w3tsur=yhtsur-y3tsur-y3ustr
21829 w3tsui=yhtsui-y3tsui-y3usti
21830 w3tusr=yhtusr-y3tusr-y3sutr
21831 w3tusi=yhtusi-y3tusi-y3suti
21832 w3ustr=yhustr-y3ustr-y3tsur
21833 w3usti=yhusti-y3usti-y3tsui
21834 w3utsr=yhutsr-y3utsr-y3stur
21835 w3utsi=yhutsi-y3utsi-y3stui
21836 b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2d0*th*uh*
21837 & (uh+2d0*sh)/(sh+uh)**2*(w1tr-w1hr)+(sqmq-sh/4d0)*
21838 & (0.5d0*w2sr+0.5d0*w2hr-w2tr+w3stur)+sh2*(2d0*sqmq/
21839 & (sh+uh)**2-0.5d0/(sh+uh))*(w2tr-w2hr)+0.5d0*th*uh/sh*
21840 & (w2hr-2d0*w2tr)+0.125d0*(sh-12d0*sqmq-4d0*th*uh/sh)*w3tsur)
21841 b2stui=sqmq/sqmh**2*(2d0*th*uh*(uh+2d0*sh)/(sh+uh)**2*
21842 & (w1ti-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ti+
21843 & w3stui)+sh2*(2d0*sqmq/(sh+uh)**2-0.5d0/(sh+uh))*
21844 & (w2ti-w2hi)+0.5d0*th*uh/sh*(w2hi-2d0*w2ti)+0.125d0*
21845 & (sh-12d0*sqmq-4d0*th*uh/sh)*w3tsui)
21846 b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2d0*uh*th*
21847 & (th+2d0*sh)/(sh+th)**2*(w1ur-w1hr)+(sqmq-sh/4d0)*
21848 & (0.5d0*w2sr+0.5d0*w2hr-w2ur+w3sutr)+sh2*(2d0*sqmq/
21849 & (sh+th)**2-0.5d0/(sh+th))*(w2ur-w2hr)+0.5d0*uh*th/sh*
21850 & (w2hr-2d0*w2ur)+0.125d0*(sh-12d0*sqmq-4d0*uh*th/sh)*w3ustr)
21851 b2suti=sqmq/sqmh**2*(2d0*uh*th*(th+2d0*sh)/(sh+th)**2*
21852 & (w1ui-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ui+
21853 & w3suti)+sh2*(2d0*sqmq/(sh+th)**2-0.5d0/(sh+th))*
21854 & (w2ui-w2hi)+0.5d0*uh*th/sh*(w2hi-2d0*w2ui)+0.125d0*
21855 & (sh-12d0*sqmq-4d0*uh*th/sh)*w3usti)
21856 b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2d0*sh*uh*
21857 & (uh+2d0*th)/(th+uh)**2*(w1sr-w1hr)+(sqmq-th/4d0)*
21858 & (0.5d0*w2tr+0.5d0*w2hr-w2sr+w3tsur)+th2*(2d0*sqmq/
21859 & (th+uh)**2-0.5d0/(th+uh))*(w2sr-w2hr)+0.5d0*sh*uh/th*
21860 & (w2hr-2d0*w2sr)+0.125d0*(th-12d0*sqmq-4d0*sh*uh/th)*w3stur)
21861 b2tsui=sqmq/sqmh**2*(2d0*sh*uh*(uh+2d0*th)/(th+uh)**2*
21862 & (w1si-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2si+
21863 & w3tsui)+th2*(2d0*sqmq/(th+uh)**2-0.5d0/(th+uh))*
21864 & (w2si-w2hi)+0.5d0*sh*uh/th*(w2hi-2d0*w2si)+0.125d0*
21865 & (th-12d0*sqmq-4d0*sh*uh/th)*w3stui)
21866 b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2d0*uh*sh*
21867 & (sh+2d0*th)/(th+sh)**2*(w1ur-w1hr)+(sqmq-th/4d0)*
21868 & (0.5d0*w2tr+0.5d0*w2hr-w2ur+w3tusr)+th2*(2d0*sqmq/
21869 & (th+sh)**2-0.5d0/(th+sh))*(w2ur-w2hr)+0.5d0*uh*sh/th*
21870 & (w2hr-2d0*w2ur)+0.125d0*(th-12d0*sqmq-4d0*uh*sh/th)*w3utsr)
21871 b2tusi=sqmq/sqmh**2*(2d0*uh*sh*(sh+2d0*th)/(th+sh)**2*
21872 & (w1ui-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2ui+
21873 & w3tusi)+th2*(2d0*sqmq/(th+sh)**2-0.5d0/(th+sh))*
21874 & (w2ui-w2hi)+0.5d0*uh*sh/th*(w2hi-2d0*w2ui)+0.125d0*
21875 & (th-12d0*sqmq-4d0*uh*sh/th)*w3utsi)
21876 b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2d0*sh*th*
21877 & (th+2d0*uh)/(uh+th)**2*(w1sr-w1hr)+(sqmq-uh/4d0)*
21878 & (0.5d0*w2ur+0.5d0*w2hr-w2sr+w3ustr)+uh2*(2d0*sqmq/
21879 & (uh+th)**2-0.5d0/(uh+th))*(w2sr-w2hr)+0.5d0*sh*th/uh*
21880 & (w2hr-2d0*w2sr)+0.125d0*(uh-12d0*sqmq-4d0*sh*th/uh)*w3sutr)
21881 b2usti=sqmq/sqmh**2*(2d0*sh*th*(th+2d0*uh)/(uh+th)**2*
21882 & (w1si-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2si+
21883 & w3usti)+uh2*(2d0*sqmq/(uh+th)**2-0.5d0/(uh+th))*
21884 & (w2si-w2hi)+0.5d0*sh*th/uh*(w2hi-2d0*w2si)+0.125d0*
21885 & (uh-12d0*sqmq-4d0*sh*th/uh)*w3suti)
21886 b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2d0*th*sh*
21887 & (sh+2d0*uh)/(uh+sh)**2*(w1tr-w1hr)+(sqmq-uh/4d0)*
21888 & (0.5d0*w2ur+0.5d0*w2hr-w2tr+w3utsr)+uh2*(2d0*sqmq/
21889 & (uh+sh)**2-0.5d0/(uh+sh))*(w2tr-w2hr)+0.5d0*th*sh/uh*
21890 & (w2hr-2d0*w2tr)+0.125d0*(uh-12d0*sqmq-4d0*th*sh/uh)*w3tusr)
21891 b2utsi=sqmq/sqmh**2*(2d0*th*sh*(sh+2d0*uh)/(uh+sh)**2*
21892 & (w1ti-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2ti+
21893 & w3utsi)+uh2*(2d0*sqmq/(uh+sh)**2-0.5d0/(uh+sh))*
21894 & (w2ti-w2hi)+0.5d0*th*sh/uh*(w2hi-2d0*w2ti)+0.125d0*
21895 & (uh-12d0*sqmq-4d0*th*sh/uh)*w3tusi)
21896 b4stur=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
21897 & (w2sr-w2hr+w3stur))
21898 b4stui=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2si-w2hi+w3stui)
21899 b4tusr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
21900 & (w2tr-w2hr+w3tusr))
21901 b4tusi=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ti-w2hi+w3tusi)
21902 b4ustr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
21903 & (w2ur-w2hr+w3ustr))
21904 b4usti=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ui-w2hi+w3usti)
21905 a2stur=a2stur+b2stur+b2sutr
21906 a2stui=a2stui+b2stui+b2suti
21907 a2ustr=a2ustr+b2ustr+b2utsr
21908 a2usti=a2usti+b2usti+b2utsi
21909 a2tusr=a2tusr+b2tusr+b2tsur
21910 a2tusi=a2tusi+b2tusi+b2tsui
21911 a4stur=a4stur+b4stur+b4ustr+b4tusr
21912 a4stui=a4stui+b4stui+b4usti+b4tusi
21913 1170 CONTINUE
21914 facgh=comfac*faca*3d0/(128d0*paru(1)**2)*aem/xw*as**3*
21915 & sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+
21916 & a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)
21917 facgh=facgh*wids(25,2)
21918 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1180
21919 nchn=nchn+1
21920 isig(nchn,1)=21
21921 isig(nchn,2)=21
21922 isig(nchn,3)=1
21923 sigh(nchn)=facgh
21924 1180 CONTINUE
21925
21926 ELSEIF(isub.EQ.114.OR.isub.EQ.115) THEN
21927C...g + g -> gamma + gamma or g + g -> g + gamma
21928 a0stur=0d0
21929 a0stui=0d0
21930 a0tsur=0d0
21931 a0tsui=0d0
21932 a0utsr=0d0
21933 a0utsi=0d0
21934 a1stur=0d0
21935 a1stui=0d0
21936 a2stur=0d0
21937 a2stui=0d0
21938 alst=log(-sh/th)
21939 alsu=log(-sh/uh)
21940 altu=log(th/uh)
21941 imax=2*mstp(1)
21942 IF(mstp(38).GE.1.AND.mstp(38).LE.8) imax=mstp(38)
21943 DO 1190 i=1,imax
21944 ei=kchg(iabs(i),1)/3d0
21945 eiwt=ei**2
21946 IF(isub.EQ.115) eiwt=ei
21947 sqmq=pmas(i,1)**2
21948 epss=4d0*sqmq/sh
21949 epst=4d0*sqmq/th
21950 epsu=4d0*sqmq/uh
21951 IF((mstp(38).GE.1.AND.mstp(38).LE.8).OR.epss.LT.1d-4) THEN
21952 b0stur=1d0+(th-uh)/sh*altu+0.5d0*(th2+uh2)/sh2*(altu**2+
21953 & paru(1)**2)
21954 b0stui=0d0
21955 b0tsur=1d0+(sh-uh)/th*alsu+0.5d0*(sh2+uh2)/th2*alsu**2
21956 b0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*alsu)
21957 b0utsr=1d0+(sh-th)/uh*alst+0.5d0*(sh2+th2)/uh2*alst**2
21958 b0utsi=-paru(1)*((sh-th)/uh+(sh2+th2)/uh2*alst)
21959 b1stur=-1d0
21960 b1stui=0d0
21961 b2stur=-1d0
21962 b2stui=0d0
21963 ELSE
21964 CALL pywaux(1,epss,w1sr,w1si)
21965 CALL pywaux(1,epst,w1tr,w1ti)
21966 CALL pywaux(1,epsu,w1ur,w1ui)
21967 CALL pywaux(2,epss,w2sr,w2si)
21968 CALL pywaux(2,epst,w2tr,w2ti)
21969 CALL pywaux(2,epsu,w2ur,w2ui)
21970 CALL pyi3au(epss,th/uh,y3stur,y3stui)
21971 CALL pyi3au(epss,uh/th,y3sutr,y3suti)
21972 CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
21973 CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
21974 CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
21975 CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
21976 b0stur=1d0+(1d0+2d0*th/sh)*w1tr+(1d0+2d0*uh/sh)*w1ur+
21977 & 0.5d0*((th2+uh2)/sh2-epss)*(w2tr+w2ur)-
21978 & 0.25d0*epst*(1d0-0.5d0*epss)*(y3sutr+y3tusr)-
21979 & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stur+y3utsr)+
21980 & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
21981 & 0.5d0*epst*epsu)*(y3tsur+y3ustr)
21982 b0stui=(1d0+2d0*th/sh)*w1ti+(1d0+2d0*uh/sh)*w1ui+
21983 & 0.5d0*((th2+uh2)/sh2-epss)*(w2ti+w2ui)-
21984 & 0.25d0*epst*(1d0-0.5d0*epss)*(y3suti+y3tusi)-
21985 & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stui+y3utsi)+
21986 & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
21987 & 0.5d0*epst*epsu)*(y3tsui+y3usti)
21988 b0tsur=1d0+(1d0+2d0*sh/th)*w1sr+(1d0+2d0*uh/th)*w1ur+
21989 & 0.5d0*((sh2+uh2)/th2-epst)*(w2sr+w2ur)-
21990 & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusr+y3sutr)-
21991 & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsur+y3ustr)+
21992 & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
21993 & 0.5d0*epss*epsu)*(y3stur+y3utsr)
21994 b0tsui=(1d0+2d0*sh/th)*w1si+(1d0+2d0*uh/th)*w1ui+
21995 & 0.5d0*((sh2+uh2)/th2-epst)*(w2si+w2ui)-
21996 & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusi+y3suti)-
21997 & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsui+y3usti)+
21998 & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
21999 & 0.5d0*epss*epsu)*(y3stui+y3utsi)
22000 b0utsr=1d0+(1d0+2d0*th/uh)*w1tr+(1d0+2d0*sh/uh)*w1sr+
22001 & 0.5d0*((th2+sh2)/uh2-epsu)*(w2tr+w2sr)-
22002 & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3ustr+y3tsur)-
22003 & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsr+y3stur)+
22004 & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
22005 & 0.5d0*epst*epss)*(y3tusr+y3sutr)
22006 b0utsi=(1d0+2d0*th/uh)*w1ti+(1d0+2d0*sh/uh)*w1si+
22007 & 0.5d0*((th2+sh2)/uh2-epsu)*(w2ti+w2si)-
22008 & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3usti+y3tsui)-
22009 & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsi+y3stui)+
22010 & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
22011 & 0.5d0*epst*epss)*(y3tusi+y3suti)
22012 b1stur=-1d0-0.25d0*(epss+epst+epsu)*(w2sr+w2tr+w2ur)+
22013 & 0.25d0*(epsu+0.5d0*epss*epst)*(y3sutr+y3tusr)+
22014 & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stur+y3utsr)+
22015 & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsur+y3ustr)
22016 b1stui=-0.25d0*(epss+epst+epsu)*(w2si+w2ti+w2ui)+
22017 & 0.25d0*(epsu+0.5d0*epss*epst)*(y3suti+y3tusi)+
22018 & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stui+y3utsi)+
22019 & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsui+y3usti)
22020 b2stur=-1d0+0.125d0*epss*epst*(y3sutr+y3tusr)+
22021 & 0.125d0*epss*epsu*(y3stur+y3utsr)+
22022 & 0.125d0*epst*epsu*(y3tsur+y3ustr)
22023 b2stui=0.125d0*epss*epst*(y3suti+y3tusi)+
22024 & 0.125d0*epss*epsu*(y3stui+y3utsi)+
22025 & 0.125d0*epst*epsu*(y3tsui+y3usti)
22026 ENDIF
22027 a0stur=a0stur+eiwt*b0stur
22028 a0stui=a0stui+eiwt*b0stui
22029 a0tsur=a0tsur+eiwt*b0tsur
22030 a0tsui=a0tsui+eiwt*b0tsui
22031 a0utsr=a0utsr+eiwt*b0utsr
22032 a0utsi=a0utsi+eiwt*b0utsi
22033 a1stur=a1stur+eiwt*b1stur
22034 a1stui=a1stui+eiwt*b1stui
22035 a2stur=a2stur+eiwt*b2stur
22036 a2stui=a2stui+eiwt*b2stui
22037 1190 CONTINUE
22038 asqsum=a0stur**2+a0stui**2+a0tsur**2+a0tsui**2+a0utsr**2+
22039 & a0utsi**2+4d0*a1stur**2+4d0*a1stui**2+a2stur**2+a2stui**2
22040 facgg=comfac*faca/(16d0*paru(1)**2)*as**2*aem**2*asqsum
22041 facgp=comfac*faca*5d0/(192d0*paru(1)**2)*as**3*aem*asqsum
22042 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1200
22043 nchn=nchn+1
22044 isig(nchn,1)=21
22045 isig(nchn,2)=21
22046 isig(nchn,3)=1
22047 IF(isub.EQ.114) sigh(nchn)=0.5d0*facgg
22048 IF(isub.EQ.115) sigh(nchn)=facgp
22049 1200 CONTINUE
22050
22051 ELSEIF(isub.EQ.116) THEN
22052C...g + g -> gamma + Z0
22053
22054 ELSEIF(isub.EQ.117) THEN
22055C...g + g -> Z0 + Z0
22056
22057 ELSEIF(isub.EQ.118) THEN
22058C...g + g -> W+ + W-
22059
22060 ENDIF
22061
22062C...G: 2 -> 3, tree diagrams
22063
22064 ELSEIF(isub.LE.140) THEN
22065 IF(isub.EQ.121) THEN
22066C...g + g -> Q + Qbar + h0
22067 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1210
22068 ia=kfpr(isubsv,2)
22069 pmf=pymrun(ia,sh)
22070 facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
22071 & (0.5d0*pmf/pmas(24,1))**2
22072 wid2=1d0
22073 IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
22074 facqqh=facqqh*wid2
22075 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
22076 ikfi=1
22077 IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
22078 IF(ia.GT.10) ikfi=3
22079 facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
22080 ENDIF
22081 CALL pyqqbh(wtqqbh)
22082 CALL pywidt(kfhigg,sh,wdtp,wdte)
22083 hs=shr*wdtp(0)
22084 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22085 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
22086 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
22087 & facbw=0d0
22088 nchn=nchn+1
22089 isig(nchn,1)=21
22090 isig(nchn,2)=21
22091 isig(nchn,3)=1
22092 sigh(nchn)=facqqh*wtqqbh*facbw
22093 1210 CONTINUE
22094
22095 ELSEIF(isub.EQ.122) THEN
22096C...q + qbar -> Q + Qbar + h0
22097 ia=kfpr(isubsv,2)
22098 pmf=pymrun(ia,sh)
22099 facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
22100 & (0.5d0*pmf/pmas(24,1))**2
22101 wid2=1d0
22102 IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
22103 facqqh=facqqh*wid2
22104 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
22105 ikfi=1
22106 IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
22107 IF(ia.GT.10) ikfi=3
22108 facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
22109 ENDIF
22110 CALL pyqqbh(wtqqbh)
22111 CALL pywidt(kfhigg,sh,wdtp,wdte)
22112 hs=shr*wdtp(0)
22113 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22114 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
22115 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
22116 & facbw=0d0
22117 DO 1220 i=mmina,mmaxa
22118 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
22119 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1220
22120 nchn=nchn+1
22121 isig(nchn,1)=i
22122 isig(nchn,2)=-i
22123 isig(nchn,3)=1
22124 sigh(nchn)=facqqh*wtqqbh*facbw
22125 1220 CONTINUE
22126
22127 ELSEIF(isub.EQ.123) THEN
22128C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
22129C...inner process)
22130 facnor=comfac*(4d0*paru(1)*aem/(xw*xw1))**3*sqmz/32d0
22131 IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
22132 & paru(154+10*ihigg)**2
22133 facprp=1d0/((vint(215)-vint(204)**2)*
22134 & (vint(216)-vint(209)**2))**2
22135 faczz1=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
22136 faczz2=facnor*facprp*vint(217)*vint(218)
22137 CALL pywidt(kfhigg,sh,wdtp,wdte)
22138 hs=shr*wdtp(0)
22139 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22140 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
22141 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
22142 & facbw=0d0
22143 DO 1240 i=mmin1,mmax1
22144 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1240
22145 ia=iabs(i)
22146 DO 1230 j=mmin2,mmax2
22147 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1230
22148 ja=iabs(j)
22149 ei=kchg(ia,1)*isign(1,i)/3d0
22150 ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
22151 vi=ai-4d0*ei*xwv
22152 ej=kchg(ja,1)*isign(1,j)/3d0
22153 aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
22154 vj=aj-4d0*ej*xwv
22155 faclr1=(vi**2+ai**2)*(vj**2+aj**2)+4d0*vi*ai*vj*aj
22156 faclr2=(vi**2+ai**2)*(vj**2+aj**2)-4d0*vi*ai*vj*aj
22157 nchn=nchn+1
22158 isig(nchn,1)=i
22159 isig(nchn,2)=j
22160 isig(nchn,3)=1
22161 sigh(nchn)=(faclr1*faczz1+faclr2*faczz2)*facbw
22162 1230 CONTINUE
22163 1240 CONTINUE
22164
22165 ELSEIF(isub.EQ.124) THEN
22166C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
22167C...inner process)
22168 facnor=comfac*(4d0*paru(1)*aem/xw)**3*sqmw
22169 IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
22170 & paru(155+10*ihigg)**2
22171 facprp=1d0/((vint(215)-vint(204)**2)*
22172 & (vint(216)-vint(209)**2))**2
22173 facww=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
22174 CALL pywidt(kfhigg,sh,wdtp,wdte)
22175 hs=shr*wdtp(0)
22176 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22177 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
22178 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
22179 & facbw=0d0
22180 DO 1260 i=mmin1,mmax1
22181 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1260
22182 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
22183 DO 1250 j=mmin2,mmax2
22184 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1250
22185 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
22186 IF(ei*ej.GT.0d0) GOTO 1250
22187 faclr=vint(180+i)*vint(180+j)
22188 nchn=nchn+1
22189 isig(nchn,1)=i
22190 isig(nchn,2)=j
22191 isig(nchn,3)=1
22192 sigh(nchn)=faclr*facww*facbw
22193 1250 CONTINUE
22194 1260 CONTINUE
22195
22196 ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
22197C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
22198 ph=0d0
22199 IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
22200 & ph=vint(3)**2
22201 IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
22202 & ph=vint(4)**2
22203 IF(isub.EQ.131) THEN
22204 fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**2*
22205 & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
22206 ELSE
22207 fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
22208 ENDIF
22209 DO 1280 i=mmina,mmaxa
22210 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 1280
22211 ei=kchg(iabs(i),1)/3d0
22212 facgq=fgq*ei**2
22213 DO 1270 isde=1,2
22214 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 1270
22215 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 1270
22216 nchn=nchn+1
22217 isig(nchn,isde)=i
22218 isig(nchn,3-isde)=22
22219 isig(nchn,3)=1
22220 sigh(nchn)=facgq
22221 1270 CONTINUE
22222 1280 CONTINUE
22223
22224 ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
22225C...f + gamma*_(T,L) -> f + gamma
22226 ph=0d0
22227 IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
22228 & ph=vint(3)**2
22229 IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
22230 & ph=vint(4)**2
22231 IF(isub.EQ.133) THEN
22232 fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**2*
22233 & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
22234 ELSE
22235 fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
22236 ENDIF
22237 DO 1300 i=mmina,mmaxa
22238 IF(i.EQ.0) GOTO 1300
22239 ei=kchg(iabs(i),1)/3d0
22240 facgq=fgq*ei**4
22241 DO 1290 isde=1,2
22242 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 1290
22243 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 1290
22244 nchn=nchn+1
22245 isig(nchn,isde)=i
22246 isig(nchn,3-isde)=22
22247 isig(nchn,3)=1
22248 sigh(nchn)=facgq
22249 1290 CONTINUE
22250 1300 CONTINUE
22251
22252 ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
22253C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
22254 ph=0d0
22255 IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
22256 & ph=vint(3)**2
22257 IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
22258 & ph=vint(4)**2
22259 CALL pywidt(21,sh,wdtp,wdte)
22260 wdtesu=0d0
22261 DO 1310 i=1,min(8,mdcy(21,3))
22262 ef=kchg(i,1)/3d0
22263 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
22264 & wdte(i,4))
22265 1310 CONTINUE
22266 IF(isub.EQ.135) THEN
22267 facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**2*
22268 & ((th2+uh2-2d0*ph*sh)/(th*uh)+4d0*ph*sh/(sh+ph)**2)
22269 ELSE
22270 facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**4*8d0*ph*sh
22271 ENDIF
22272 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
22273 nchn=nchn+1
22274 isig(nchn,1)=21
22275 isig(nchn,2)=22
22276 isig(nchn,3)=1
22277 sigh(nchn)=facqq
22278 ENDIF
22279 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
22280 nchn=nchn+1
22281 isig(nchn,1)=22
22282 isig(nchn,2)=21
22283 isig(nchn,3)=1
22284 sigh(nchn)=facqq
22285 ENDIF
22286
22287 ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
22288C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
22289 ph1=0d0
22290 IF(vint(3).LT.0d0) ph1=vint(3)**2
22291 ph2=0d0
22292 IF(vint(4).LT.0d0) ph2=vint(4)**2
22293 CALL pywidt(22,sh,wdtp,wdte)
22294 wdtesu=0d0
22295 DO 1320 i=1,min(12,mdcy(22,3))
22296 IF(i.LE.8) ef= kchg(i,1)/3d0
22297 IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
22298 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
22299 & wdte(i,4))
22300 1320 CONTINUE
22301 dlamb2=(th+uh)**2-4d0*ph1*ph2
22302 IF(isub.EQ.137) THEN
22303 fparam=-sh*(th+uh)/dlamb2
22304 facff=comfac*aem**2*wdtesu*2d0*sh2/(dlamb2*th2*uh2)*
22305 & (th*uh-ph1*ph2)*((th2+uh2)*(1d0-2d0*fparam*(1d0-fparam))-
22306 & 2d0*ph1*ph2*fparam**2)
22307 ELSEIF(isub.EQ.138) THEN
22308 facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
22309 & ph2*(4d0*(th*uh-ph1*ph2)*(th*uh+ph1*sh*(th-uh)**2/dlamb2)+
22310 & 2d0*ph1**2*(th-uh)**2)
22311 ELSEIF(isub.EQ.139) THEN
22312 facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
22313 & ph1*(4d0*(th*uh-ph1*ph2)*(th*uh+ph2*sh*(th-uh)**2/dlamb2)+
22314 & 2d0*ph2**2*(th-uh)**2)
22315 ELSE
22316 facff=comfac*aem**2*wdtesu*32d0*sh2**2/(dlamb2**3*th2*uh2)*
22317 & ph1*ph2*(th*uh-ph1*ph2)*(th-uh)**2
22318 ENDIF
22319 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
22320 nchn=nchn+1
22321 isig(nchn,1)=22
22322 isig(nchn,2)=22
22323 isig(nchn,3)=1
22324 sigh(nchn)=facff
22325 ENDIF
22326
22327 ENDIF
22328
22329C...H: 2 -> 1, tree diagrams, non-standard model processes
22330
22331 ELSEIF(isub.LE.160) THEN
22332 IF(isub.EQ.141) THEN
22333C...f + fbar -> gamma*/Z0/Z'0
22334 sqmzp=pmas(32,1)**2
22335 mint(61)=2
22336 CALL pywidt(32,sh,wdtp,wdte)
22337 hp0=aem/3d0*sh
22338 hp1=aem/3d0*xwc*sh
22339 hp2=hp1
22340 hs=shr*vint(117)
22341 hsp=shr*wdtp(0)
22342 faczp=4d0*comfac*3d0
22343 DO 1330 i=mmina,mmaxa
22344 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1330
22345 ei=kchg(iabs(i),1)/3d0
22346 ai=sign(1d0,ei)
22347 vi=ai-4d0*ei*xwv
22348 ia=iabs(i)
22349 IF(ia.LT.10) THEN
22350 IF(ia.LE.2) THEN
22351 vpi=paru(123-2*mod(iabs(i),2))
22352 api=paru(124-2*mod(iabs(i),2))
22353 ELSEIF(ia.LE.4) THEN
22354 vpi=parj(182-2*mod(iabs(i),2))
22355 api=parj(183-2*mod(iabs(i),2))
22356 ELSE
22357 vpi=parj(190-2*mod(iabs(i),2))
22358 api=parj(191-2*mod(iabs(i),2))
22359 ENDIF
22360 ELSE
22361 IF(ia.LE.12) THEN
22362 vpi=paru(127-2*mod(iabs(i),2))
22363 api=paru(128-2*mod(iabs(i),2))
22364 ELSEIF(ia.LE.14) THEN
22365 vpi=parj(186-2*mod(iabs(i),2))
22366 api=parj(187-2*mod(iabs(i),2))
22367 ELSE
22368 vpi=parj(194-2*mod(iabs(i),2))
22369 api=parj(195-2*mod(iabs(i),2))
22370 ENDIF
22371 ENDIF
22372 hi0=hp0
22373 IF(iabs(i).LE.10) hi0=hi0*faca/3d0
22374 hi1=hp1
22375 IF(iabs(i).LE.10) hi1=hi1*faca/3d0
22376 hi2=hp2
22377 IF(iabs(i).LE.10) hi2=hi2*faca/3d0
22378 nchn=nchn+1
22379 isig(nchn,1)=i
22380 isig(nchn,2)=-i
22381 isig(nchn,3)=1
22382 sigh(nchn)=faczp*(ei**2/sh2*hi0*hp0*vint(111)+ei*vi*
22383 & (1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*(hi0*hp1+hi1*hp0)*
22384 & vint(112)+ei*vpi*(1d0-sqmzp/sh)/((sh-sqmzp)**2+hsp**2)*
22385 & (hi0*hp2+hi2*hp0)*vint(113)+(vi**2+ai**2)/
22386 & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114)+(vi*vpi+ai*api)*
22387 & ((sh-sqmz)*(sh-sqmzp)+hs*hsp)/(((sh-sqmz)**2+hs**2)*
22388 & ((sh-sqmzp)**2+hsp**2))*(hi1*hp2+hi2*hp1)*vint(115)+
22389 & (vpi**2+api**2)/((sh-sqmzp)**2+hsp**2)*hi2*hp2*vint(116))
22390 1330 CONTINUE
22391
22392 ELSEIF(isub.EQ.142) THEN
22393C...f + fbar' -> W'+/-
22394 sqmwp=pmas(34,1)**2
22395 CALL pywidt(34,sh,wdtp,wdte)
22396 hs=shr*wdtp(0)
22397 facbw=4d0*comfac/((sh-sqmwp)**2+hs**2)*3d0
22398 hp=aem/(24d0*xw)*sh
22399 DO 1350 i=mmin1,mmax1
22400 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1350
22401 ia=iabs(i)
22402 DO 1340 j=mmin2,mmax2
22403 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1340
22404 ja=iabs(j)
22405 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1340
22406 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
22407 & GOTO 1340
22408 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
22409 hi=hp*(paru(133)**2+paru(134)**2)
22410 IF(ia.LE.10) hi=hp*(paru(131)**2+paru(132)**2)*
22411 & vckm((ia+1)/2,(ja+1)/2)*faca/3d0
22412 nchn=nchn+1
22413 isig(nchn,1)=i
22414 isig(nchn,2)=j
22415 isig(nchn,3)=1
22416 hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
22417 sigh(nchn)=hi*facbw*hf
22418 1340 CONTINUE
22419 1350 CONTINUE
22420
22421 ELSEIF(isub.EQ.143) THEN
22422C...f + fbar' -> H+/-
22423 sqmhc=pmas(37,1)**2
22424 CALL pywidt(37,sh,wdtp,wdte)
22425 hs=shr*wdtp(0)
22426 facbw=4d0*comfac/((sh-sqmhc)**2+hs**2)
22427 hp=aem/(8d0*xw)*sh/sqmw*sh
22428 DO 1370 i=mmin1,mmax1
22429 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1370
22430 ia=iabs(i)
22431 im=(mod(ia,10)+1)/2
22432 DO 1360 j=mmin2,mmax2
22433 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1360
22434 ja=iabs(j)
22435 jm=(mod(ja,10)+1)/2
22436 IF(i*j.GT.0.OR.ia.EQ.ja.OR.im.NE.jm) GOTO 1360
22437 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
22438 & GOTO 1360
22439 IF(mod(ia,2).EQ.0) THEN
22440 iu=ia
22441 il=ja
22442 ELSE
22443 iu=ja
22444 il=ia
22445 ENDIF
22446 rml=pymrun(il,sh)**2/sh
22447 rmu=pymrun(iu,sh)**2/sh
22448 hi=hp*(rml*paru(141)**2+rmu/paru(141)**2)
22449 IF(ia.LE.10) hi=hi*faca/3d0
22450 kchhc=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
22451 hf=shr*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
22452 nchn=nchn+1
22453 isig(nchn,1)=i
22454 isig(nchn,2)=j
22455 isig(nchn,3)=1
22456 sigh(nchn)=hi*facbw*hf
22457 1360 CONTINUE
22458 1370 CONTINUE
22459
22460 ELSEIF(isub.EQ.144) THEN
22461C...f + fbar' -> R
22462 sqmr=pmas(40,1)**2
22463 CALL pywidt(40,sh,wdtp,wdte)
22464 hs=shr*wdtp(0)
22465 facbw=4d0*comfac/((sh-sqmr)**2+hs**2)*3d0
22466 hp=aem/(12d0*xw)*sh
22467 DO 1390 i=mmin1,mmax1
22468 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1390
22469 ia=iabs(i)
22470 DO 1380 j=mmin2,mmax2
22471 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1380
22472 ja=iabs(j)
22473 IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) GOTO 1380
22474 hi=hp
22475 IF(ia.LE.10) hi=hi*faca/3d0
22476 hf=shr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))
22477 nchn=nchn+1
22478 isig(nchn,1)=i
22479 isig(nchn,2)=j
22480 isig(nchn,3)=1
22481 sigh(nchn)=hi*facbw*hf
22482 1380 CONTINUE
22483 1390 CONTINUE
22484
22485 ELSEIF(isub.EQ.145) THEN
22486C...q + l -> LQ (leptoquark)
22487 sqmlq=pmas(39,1)**2
22488 CALL pywidt(39,sh,wdtp,wdte)
22489 hs=shr*wdtp(0)
22490 facbw=4d0*comfac/((sh-sqmlq)**2+hs**2)
22491 IF(abs(shr-pmas(39,1)).GT.parp(48)*pmas(39,2)) facbw=0d0
22492 hp=aem/4d0*sh
22493 kflqq=kfdp(mdcy(39,2),1)
22494 kflql=kfdp(mdcy(39,2),2)
22495 DO 1410 i=mmin1,mmax1
22496 IF(kfac(1,i).EQ.0) GOTO 1410
22497 ia=iabs(i)
22498 IF(ia.NE.kflqq.AND.ia.NE.iabs(kflql)) GOTO 1410
22499 DO 1400 j=mmin2,mmax2
22500 IF(kfac(2,j).EQ.0) GOTO 1400
22501 ja=iabs(j)
22502 IF(ja.NE.kflqq.AND.ja.NE.iabs(kflql)) GOTO 1400
22503 IF(i*j.NE.kflqq*kflql) GOTO 1400
22504 IF(ja.EQ.ia) GOTO 1400
22505 IF(ia.EQ.kflqq) kchlq=isign(1,i)
22506 IF(ja.EQ.kflqq) kchlq=isign(1,j)
22507 hi=hp*paru(151)
22508 hf=shr*(wdte(0,1)+wdte(0,(5-kchlq)/2)+wdte(0,4))
22509 nchn=nchn+1
22510 isig(nchn,1)=i
22511 isig(nchn,2)=j
22512 isig(nchn,3)=1
22513 sigh(nchn)=hi*facbw*hf
22514 1400 CONTINUE
22515 1410 CONTINUE
22516
22517 ELSEIF(isub.EQ.146) THEN
22518C...e + gamma* -> e* (excited lepton)
22519 kfqstr=kfpr(isub,1)
22520 kcqstr=pycomp(kfqstr)
22521 kfqexc=mod(kfqstr,kexcit)
22522 CALL pywidt(kfqstr,sh,wdtp,wdte)
22523 hs=shr*wdtp(0)
22524 facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
22525 qf=-paru(157)/2d0-paru(158)/2d0
22526 facbw=facbw*aem*qf**2*sh/paru(155)**2
22527 IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
22528 & facbw=0d0
22529 hp=sh
22530 DO 1416 i=-kfqexc,kfqexc,2*kfqexc
22531 DO 1413 isde=1,2
22532 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 1413
22533 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 1413
22534 hi=hp
22535 IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22536 IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
22537 nchn=nchn+1
22538 isig(nchn,isde)=i
22539 isig(nchn,3-isde)=22
22540 isig(nchn,3)=1
22541 sigh(nchn)=hi*facbw*hf
22542 1413 CONTINUE
22543 1416 CONTINUE
22544
22545 ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
22546C...d + g -> d* and u + g -> u* (excited quarks)
22547 kfqstr=kfpr(isub,1)
22548 kcqstr=pycomp(kfqstr)
22549 kfqexc=mod(kfqstr,kexcit)
22550 CALL pywidt(kfqstr,sh,wdtp,wdte)
22551 hs=shr*wdtp(0)
22552 facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
22553 facbw=facbw*as*paru(159)**2*sh/(3d0*paru(155)**2)
22554 IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
22555 & facbw=0d0
22556 hp=sh
22557 DO 1430 i=-kfqexc,kfqexc,2*kfqexc
22558 DO 1420 isde=1,2
22559 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1420
22560 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 1420
22561 hi=hp
22562 IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22563 IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
22564 nchn=nchn+1
22565 isig(nchn,isde)=i
22566 isig(nchn,3-isde)=21
22567 isig(nchn,3)=1
22568 sigh(nchn)=hi*facbw*hf
22569 1420 CONTINUE
22570 1430 CONTINUE
22571
22572 ELSEIF(isub.EQ.149) THEN
22573C...g + g -> eta_techni
22574 CALL pywidt(38,sh,wdtp,wdte)
22575 hs=shr*wdtp(0)
22576 facbw=comfac*0.5d0/((sh-pmas(38,1)**2)**2+hs**2)
22577 IF(abs(shr-pmas(38,1)).GT.parp(48)*pmas(38,2)) facbw=0d0
22578 hp=sh
22579 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1440
22580 hi=hp*wdtp(3)
22581 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22582 nchn=nchn+1
22583 isig(nchn,1)=21
22584 isig(nchn,2)=21
22585 isig(nchn,3)=1
22586 sigh(nchn)=hi*facbw*hf
22587 1440 CONTINUE
22588
22589 ENDIF
22590
22591C...I: 2 -> 2, tree diagrams, non-standard model processes
22592
22593 ELSEIF(isub.LE.200) THEN
22594 IF(isub.EQ.161) THEN
22595C...f + g -> f' + H+/- (b + g -> t + H+/- only)
22596C...(choice of only b and t to avoid kinematics problems)
22597 fhcq=comfac*faca*as*aem/xw*1d0/24
22598C...H propagator: as simulated in PYOFSH and as desired
22599 sqmhc=pmas(37,1)**2
22600 gmmhc=pmas(37,1)*pmas(37,2)
22601 hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
22602 CALL pywidt(37,sqm4,wdtp,wdte)
22603 gmmhcc=sqrt(sqm4)*wdtp(0)
22604 hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
22605 fhcq=fhcq*hbw4c/hbw4
22606 DO 1460 i=mmina,mmaxa
22607 ia=iabs(i)
22608 IF(ia.NE.5) GOTO 1460
22609 sqml=pymrun(ia,sh)**2
22610 iua=ia+mod(ia,2)
22611 sqmq=pymrun(iua,sh)**2
22612 fachcq=fhcq*(sqml*paru(141)**2+sqmq/paru(141)**2)/sqmw*
22613 & (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+
22614 & 2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*
22615 & (sqmhc-sqmq-sh)/sh)
22616 kchhc=isign(1,kchg(ia,1)*isign(1,i))
22617 DO 1450 isde=1,2
22618 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1450
22619 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,1).EQ.0) GOTO 1450
22620 nchn=nchn+1
22621 isig(nchn,isde)=i
22622 isig(nchn,3-isde)=21
22623 isig(nchn,3)=1
22624 sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)
22625 1450 CONTINUE
22626 1460 CONTINUE
22627
22628 ELSEIF(isub.EQ.162) THEN
22629C...q + g -> LQ + lbar; LQ=leptoquark
22630 sqmlq=pmas(39,1)**2
22631 faclq=comfac*faca*paru(151)*(as*aem/6d0)*(-th/sh)*
22632 & (uh2+sqmlq**2)/(uh-sqmlq)**2
22633 kflqq=kfdp(mdcy(39,2),1)
22634 DO 1480 i=mmina,mmaxa
22635 IF(iabs(i).NE.kflqq) GOTO 1480
22636 kchlq=isign(1,i)
22637 DO 1470 isde=1,2
22638 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1470
22639 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 1470
22640 nchn=nchn+1
22641 isig(nchn,isde)=i
22642 isig(nchn,3-isde)=21
22643 isig(nchn,3)=1
22644 sigh(nchn)=faclq*wids(39,(5-kchlq)/2)
22645 1470 CONTINUE
22646 1480 CONTINUE
22647
22648 ELSEIF(isub.EQ.163) THEN
22649C...g + g -> LQ + LQbar; LQ=leptoquark
22650 sqmlq=pmas(39,1)**2
22651 faclq=comfac*faca*wids(39,1)*(as**2/2d0)*
22652 & (7d0/48d0+3d0*(uh-th)**2/(16d0*sh2))*(1d0+2d0*sqmlq*th/
22653 & (th-sqmlq)**2+2d0*sqmlq*uh/(uh-sqmlq)**2+4d0*sqmlq**2/
22654 & ((th-sqmlq)*(uh-sqmlq)))
22655 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1490
22656 nchn=nchn+1
22657 isig(nchn,1)=21
22658 isig(nchn,2)=21
22659C...Since don't know proper colour flow, randomize between alternatives
22660 isig(nchn,3)=int(1.5d0+pyr(0))
22661 sigh(nchn)=faclq
22662 1490 CONTINUE
22663
22664 ELSEIF(isub.EQ.164) THEN
22665C...q + qbar -> LQ + LQbar; LQ=leptoquark
22666 sqmlq=pmas(39,1)**2
22667 faclqa=comfac*wids(39,1)*(as**2/9d0)*
22668 & (sh*(sh-4d0*sqmlq)-(uh-th)**2)/sh2
22669 faclqs=comfac*wids(39,1)*((paru(151)**2*aem**2/8d0)*
22670 & (-sh*th-(sqmlq-th)**2)/th2+(paru(151)*aem*as/18d0)*
22671 & ((sqmlq-th)*(uh-th)+sh*(sqmlq+th))/(sh*th))
22672 kflqq=kfdp(mdcy(39,2),1)
22673 DO 1500 i=mmina,mmaxa
22674 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
22675 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1500
22676 nchn=nchn+1
22677 isig(nchn,1)=i
22678 isig(nchn,2)=-i
22679 isig(nchn,3)=1
22680 sigh(nchn)=faclqa
22681 IF(iabs(i).EQ.kflqq) sigh(nchn)=faclqa+faclqs
22682 1500 CONTINUE
22683
22684 ELSEIF(isub.EQ.165) THEN
22685C...q + qbar -> l+ + l- (including contact term for compositeness)
22686 zratr=xwc*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
22687 zrati=xwc*sh*gmmz/((sh-sqmz)**2+gmmz**2)
22688 kff=iabs(kfpr(isub,1))
22689 ef=kchg(kff,1)/3d0
22690 af=sign(1d0,ef+0.1d0)
22691 vf=af-4d0*ef*xwv
22692 valf=vf+af
22693 varf=vf-af
22694 fcof=1d0
22695 IF(kff.LE.10) fcof=3d0
22696 wid2=1d0
22697 IF(kff.EQ.6) wid2=wids(6,1)
22698 IF(kff.EQ.7.OR.kff.EQ.8) wid2=wids(kff,1)
22699 IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
22700 DO 1510 i=mmina,mmaxa
22701 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1510
22702 ei=kchg(iabs(i),1)/3d0
22703 ai=sign(1d0,ei+0.1d0)
22704 vi=ai-4d0*ei*xwv
22705 vali=vi+ai
22706 vari=vi-ai
22707 fcoi=1d0
22708 IF(iabs(i).LE.10) fcoi=faca/3d0
22709 IF((mstp(5).EQ.1.AND.iabs(i).LE.2).OR.mstp(5).EQ.2) THEN
22710 fgza=(ei*ef+vali*valf*zratr+paru(156)*sh/
22711 & (aem*paru(155)**2))**2+(vali*valf*zrati)**2+
22712 & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
22713 ELSE
22714 fgza=(ei*ef+vali*valf*zratr)**2+(vali*valf*zrati)**2+
22715 & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
22716 ENDIF
22717 fgzb=(ei*ef+vali*varf*zratr)**2+(vali*varf*zrati)**2+
22718 & (ei*ef+vari*valf*zratr)**2+(vari*valf*zrati)**2
22719 fgzab=aem**2*(fgza*uh2/sh2+fgzb*th2/sh2)
22720 IF((mstp(5).EQ.3.AND.iabs(i).EQ.2).OR.(mstp(5).EQ.4.AND.
22721 & mod(iabs(i),2).EQ.0)) fgzab=fgzab+sh2/(2d0*paru(155)**4)
22722 nchn=nchn+1
22723 isig(nchn,1)=i
22724 isig(nchn,2)=-i
22725 isig(nchn,3)=1
22726 sigh(nchn)=comfac*fcoi*fcof*fgzab*wid2
22727 1510 CONTINUE
22728
22729 ELSEIF(isub.EQ.166) THEN
22730C...q + q'bar -> l + nu_l (including contact term for compositeness)
22731 wfac=(1d0/4d0)*(aem/xw)**2*uh2/((sh-sqmw)**2+gmmw**2)
22732 wcifac=wfac+sh2/(4d0*paru(155)**4)
22733 kff=iabs(kfpr(isub,1))
22734 fcof=1d0
22735 IF(kff.LE.10) fcof=3d0
22736 DO 1530 i=mmin1,mmax1
22737 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1530
22738 ia=iabs(i)
22739 DO 1520 j=mmin2,mmax2
22740 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1520
22741 ja=iabs(j)
22742 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1520
22743 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
22744 & GOTO 1520
22745 fcoi=1d0
22746 IF(ia.LE.10) fcoi=vckm((ia+1)/2,(ja+1)/2)*faca/3d0
22747 wid2=1d0
22748 IF((i.GT.0.AND.mod(i,2).EQ.0).OR.(j.GT.0.AND.
22749 & mod(j,2).EQ.0)) THEN
22750 IF(kff.EQ.5) wid2=wids(6,2)
22751 IF(kff.EQ.7) wid2=wids(8,2)*wids(7,3)
22752 IF(kff.EQ.17) wid2=wids(18,2)*wids(17,3)
22753 ELSE
22754 IF(kff.EQ.5) wid2=wids(6,3)
22755 IF(kff.EQ.7) wid2=wids(8,3)*wids(7,2)
22756 IF(kff.EQ.17) wid2=wids(18,3)*wids(17,2)
22757 ENDIF
22758 nchn=nchn+1
22759 isig(nchn,1)=i
22760 isig(nchn,2)=j
22761 isig(nchn,3)=1
22762 sigh(nchn)=comfac*fcoi*fcof*wfac*wid2
22763 IF((mstp(5).EQ.3.AND.ia.LE.2.AND.ja.LE.2).OR.mstp(5).EQ.4)
22764 & sigh(nchn)=comfac*fcoi*fcof*wcifac*wid2
22765 1520 CONTINUE
22766 1530 CONTINUE
22767
22768 ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
22769C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
22770 kfqstr=kfpr(isub,2)
22771 kcqstr=pycomp(kfqstr)
22772 kfqexc=mod(kfqstr,kexcit)
22773 facqsa=comfac*(sh/paru(155)**2)**2*(1d0-sqm4/sh)
22774 facqsb=comfac*0.25d0*(sh/paru(155)**2)**2*(1d0-sqm4/sh)*
22775 & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
22776C...Propagators: as simulated in PYOFSH and as desired
22777 gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
22778 hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
22779 CALL pywidt(kfqstr,sqm4,wdtp,wdte)
22780 gmmqc=sqrt(sqm4)*wdtp(0)
22781 hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
22782 facqsa=facqsa*hbw4c/hbw4
22783 facqsb=facqsb*hbw4c/hbw4
22784 DO 1550 i=mmin1,mmax1
22785 ia=iabs(i)
22786 IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) GOTO 1550
22787 DO 1540 j=mmin2,mmax2
22788 ja=iabs(j)
22789 IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) GOTO 1540
22790 IF(ia.EQ.kfqexc.AND.i.EQ.j) THEN
22791 nchn=nchn+1
22792 isig(nchn,1)=i
22793 isig(nchn,2)=j
22794 isig(nchn,3)=1
22795 sigh(nchn)=(4d0/3d0)*facqsa
22796 nchn=nchn+1
22797 isig(nchn,1)=i
22798 isig(nchn,2)=j
22799 isig(nchn,3)=2
22800 sigh(nchn)=(4d0/3d0)*facqsa
22801 ELSEIF((ia.EQ.kfqexc.OR.ja.EQ.kfqexc).AND.i*j.GT.0) THEN
22802 nchn=nchn+1
22803 isig(nchn,1)=i
22804 isig(nchn,2)=j
22805 isig(nchn,3)=1
22806 IF(ja.EQ.kfqexc) isig(nchn,3)=2
22807 sigh(nchn)=facqsa
22808 ELSEIF(ia.EQ.kfqexc.AND.i.EQ.-j) THEN
22809 nchn=nchn+1
22810 isig(nchn,1)=i
22811 isig(nchn,2)=j
22812 isig(nchn,3)=1
22813 sigh(nchn)=(8d0/3d0)*facqsb
22814 nchn=nchn+1
22815 isig(nchn,1)=i
22816 isig(nchn,2)=j
22817 isig(nchn,3)=2
22818 sigh(nchn)=(8d0/3d0)*facqsb
22819 ELSEIF(i.EQ.-j) THEN
22820 nchn=nchn+1
22821 isig(nchn,1)=i
22822 isig(nchn,2)=j
22823 isig(nchn,3)=1
22824 sigh(nchn)=facqsb
22825 nchn=nchn+1
22826 isig(nchn,1)=i
22827 isig(nchn,2)=j
22828 isig(nchn,3)=2
22829 sigh(nchn)=facqsb
22830 ELSEIF(ia.EQ.kfqexc.OR.ja.EQ.kfqexc) THEN
22831 nchn=nchn+1
22832 isig(nchn,1)=i
22833 isig(nchn,2)=j
22834 isig(nchn,3)=1
22835 IF(ja.EQ.kfqexc) isig(nchn,3)=2
22836 sigh(nchn)=facqsb
22837 ENDIF
22838 1540 CONTINUE
22839 1550 CONTINUE
22840
22841 ELSEIF(isub.EQ.169) THEN
22842C...q + qbar -> e + e* (excited lepton)
22843 kfqstr=kfpr(isub,2)
22844 kcqstr=pycomp(kfqstr)
22845 kfqexc=mod(kfqstr,kexcit)
22846 facqsb=(comfac/6d0)*(sh/paru(155)**2)**2*(1d0-sqm4/sh)*
22847 & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
22848C...Propagators: as simulated in PYOFSH and as desired
22849 gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
22850 hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
22851 CALL pywidt(kfqstr,sqm4,wdtp,wdte)
22852 gmmqc=sqrt(sqm4)*wdtp(0)
22853 hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
22854 facqsb=facqsb*hbw4c/hbw4
22855 DO 1555 i=mmin1,mmax1
22856 ia=iabs(i)
22857 IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) GOTO 1555
22858 j=-i
22859 ja=iabs(j)
22860 IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) GOTO 1555
22861 nchn=nchn+1
22862 isig(nchn,1)=i
22863 isig(nchn,2)=j
22864 isig(nchn,3)=1
22865 sigh(nchn)=facqsb
22866 nchn=nchn+1
22867 isig(nchn,1)=i
22868 isig(nchn,2)=j
22869 isig(nchn,3)=2
22870 sigh(nchn)=facqsb
22871 1555 CONTINUE
22872
22873 ELSEIF(isub.EQ.191) THEN
22874C...q + qbar -> rho_tech0.
22875 sqmrht=pmas(54,1)**2
22876 CALL pywidt(54,sh,wdtp,wdte)
22877 hs=shr*wdtp(0)
22878 facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
22879 IF(abs(shr-pmas(54,1)).GT.parp(48)*pmas(54,2)) facbw=0d0
22880 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22881 alprht=2.91d0*(3d0/parp(144))
22882 hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)
22883 xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
22884 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
22885 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
22886 DO 1560 i=mmina,mmaxa
22887 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1560
22888 ia=iabs(i)
22889 ei=kchg(iabs(i),1)/3d0
22890 ai=sign(1d0,ei+0.1d0)
22891 vi=ai-4d0*ei*xwv
22892 vali=0.5d0*(vi+ai)
22893 vari=0.5d0*(vi-ai)
22894 hi=hp*((ei+vali*bwzr)**2+(vali*bwzi)**2+
22895 & (ei+vari*bwzr)**2+(vari*bwzi)**2)
22896 IF(ia.LE.10) hi=hi*faca/3d0
22897 nchn=nchn+1
22898 isig(nchn,1)=i
22899 isig(nchn,2)=-i
22900 isig(nchn,3)=1
22901 sigh(nchn)=hi*facbw*hf
22902 1560 CONTINUE
22903
22904 ELSEIF(isub.EQ.192) THEN
22905C...q + qbar' -> rho_tech+/-.
22906 sqmrht=pmas(55,1)**2
22907 CALL pywidt(55,sh,wdtp,wdte)
22908 hs=shr*wdtp(0)
22909 facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
22910 IF(abs(shr-pmas(55,1)).GT.parp(48)*pmas(55,2)) facbw=0d0
22911 alprht=2.91d0*(3d0/parp(144))
22912 hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)*
22913 & (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
22914 DO 1580 i=mmin1,mmax1
22915 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1580
22916 ia=iabs(i)
22917 DO 1570 j=mmin2,mmax2
22918 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1570
22919 ja=iabs(j)
22920 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1570
22921 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
22922 & GOTO 1570
22923 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
22924 hf=shr*(wdte(0,1)+wdte(0,(5-kchr)/2)+wdte(0,4))
22925 hi=hp
22926 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
22927 nchn=nchn+1
22928 isig(nchn,1)=i
22929 isig(nchn,2)=j
22930 isig(nchn,3)=1
22931 sigh(nchn)=hi*facbw*hf
22932 1570 CONTINUE
22933 1580 CONTINUE
22934
22935 ELSEIF(isub.EQ.193) THEN
22936C...q + qbar -> omega_tech0.
22937 sqmomt=pmas(56,1)**2
22938 CALL pywidt(56,sh,wdtp,wdte)
22939 hs=shr*wdtp(0)
22940 facbw=12d0*comfac/((sh-sqmomt)**2+hs**2)
22941 IF(abs(shr-pmas(56,1)).GT.parp(48)*pmas(56,2)) facbw=0d0
22942 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
22943 alprht=2.91d0*(3d0/parp(144))
22944 hp=(1d0/6d0)*(aem**2/alprht)*(sqmomt**2/sh)*
22945 & (2d0*parp(143)-1d0)**2
22946 bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
22947 bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
22948 DO 1590 i=mmina,mmaxa
22949 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1590
22950 ia=iabs(i)
22951 ei=kchg(iabs(i),1)/3d0
22952 ai=sign(1d0,ei+0.1d0)
22953 vi=ai-4d0*ei*xwv
22954 vali=0.5d0*(vi+ai)
22955 vari=0.5d0*(vi-ai)
22956 hi=hp*((ei-vali*bwzr)**2+(vali*bwzi)**2+
22957 & (ei-vari*bwzr)**2+(vari*bwzi)**2)
22958 IF(ia.LE.10) hi=hi*faca/3d0
22959 nchn=nchn+1
22960 isig(nchn,1)=i
22961 isig(nchn,2)=-i
22962 isig(nchn,3)=1
22963 sigh(nchn)=hi*facbw*hf
22964 1590 CONTINUE
22965
22966 ELSEIF(isub.EQ.194) THEN
22967C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
22968 kfa=kfpr(isubsv,1)
22969 alprht=2.91d0*(3d0/parp(144))
22970 hp=aem**2*comfac
22971 tanw=sqrt(paru(102)/(1d0-paru(102)))
22972 ct2w=(1d0-2d0*paru(102))/(2d0*paru(102)/tanw)
22973
22974 qupd=2d0*parp(143)-1d0
22975 far=sqrt(aem/alprht)
22976 fao=far*qupd
22977 fzr=far*ct2w
22978 fzo=-fao*tanw
22979 sfar=far**2
22980 sfao=fao**2
22981 sfzr=fzr**2
22982 sfzo=fzo**2
22983 CALL pywidt(23,sh,wdtp,wdte)
22984 ssmz=cmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
22985 CALL pywidt(54,sh,wdtp,wdte)
22986 ssmr=cmplx(1d0-pmas(54,1)**2/sh,wdtp(0)/shr)
22987 CALL pywidt(56,sh,wdtp,wdte)
22988 ssmo=cmplx(1d0-pmas(56,1)**2/sh,wdtp(0)/shr)
22989 detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
22990 $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
22991 daa=(-sfzr*ssmo - sfzo*ssmr + ssmo*ssmr*ssmz)/detd/sh
22992 dzz=(-sfar*ssmo - sfao*ssmr + ssmo*ssmr)/detd/sh
22993 daz=(far*fzr*ssmo + fao*fzo*ssmr)/detd/sh
22994
22995 xwrht=1d0/(4d0*xw*(1d0-xw))
22996 kff=iabs(kfpr(isub,1))
22997 ef=kchg(kff,1)/3d0
22998 af=sign(1d0,ef+0.1d0)
22999 vf=af-4d0*ef*xwv
23000 valf=0.5d0*(vf+af)
23001 varf=0.5d0*(vf-af)
23002 fcof=1d0
23003 IF(kff.LE.10) fcof=3d0
23004
23005 wid2=1d0
23006 IF(kff.GE.6.AND.kff.LE.8) wid2=wids(kff,1)
23007 IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
23008 dzz=dzz*cmplx(xwrht,0d0)
23009 daz=daz*cmplx(sqrt(xwrht),0d0)
23010
23011 DO 1600 i=mmina,mmaxa
23012 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1600
23013 ei=kchg(iabs(i),1)/3d0
23014 ai=sign(1d0,ei+0.1d0)
23015 vi=ai-4d0*ei*xwv
23016 vali=0.5d0*(vi+ai)
23017 vari=0.5d0*(vi-ai)
23018 fcoi=fcof
23019 IF(iabs(i).LE.10) fcoi=fcoi/3d0
23020 difll=abs(ei*ef*daa+vali*valf*dzz+daz*(ei*valf+ef*vali))**2
23021 difrr=abs(ei*ef*daa+vari*varf*dzz+daz*(ei*varf+ef*vari))**2
23022 diflr=abs(ei*ef*daa+vali*varf*dzz+daz*(ei*varf+ef*vali))**2
23023 difrl=abs(ei*ef*daa+vari*valf*dzz+daz*(ei*valf+ef*vari))**2
23024 facsig=(difll+difrr)*((uh-sqm4)**2+sh*sqm4)+
23025 & (diflr+difrl)*((th-sqm3)**2+sh*sqm3)
23026 nchn=nchn+1
23027 isig(nchn,1)=i
23028 isig(nchn,2)=-i
23029 isig(nchn,3)=1
23030 sigh(nchn)=hp*fcoi*facsig*wid2
23031 1600 CONTINUE
23032
23033 ELSEIF(isub.EQ.195) THEN
23034C...f + fbar' -> f'' + fbar''' via s-channel rho_tech+
23035 kfa=kfpr(isubsv,1)
23036 kfb=kfa+1
23037 alprht=2.91d0*(3d0/parp(144))
23038 factc=comfac*(aem**2/12d0/xw**2)*(uh-sqm3)*(uh-sqm4)*3d0
23039
23040 fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
23041 CALL pywidt(24,sh,wdtp,wdte)
23042 ssmz=cmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
23043 CALL pywidt(55,sh,wdtp,wdte)
23044 ssmr=cmplx(1d0-pmas(54,1)**2/sh,wdtp(0)/shr)
23045
23046 fcof=1d0
23047 IF(kfa.LE.8) fcof=3d0
23048 detd=ssmz*ssmr-cmplx(fwr**2,0d0)
23049 hp=factc*abs(ssmr/detd)**2/sh**2*fcof
23050
23051 DO 1605 i=mmin1,mmax1
23052 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 1605
23053 ia=iabs(i)
23054 DO 1604 j=mmin2,mmax2
23055 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 1604
23056 ja=iabs(j)
23057 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1604
23058 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
23059 & GOTO 1604
23060 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
23061 hi=hp
23062 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
23063 nchn=nchn+1
23064 isig(nchn,1)=i
23065 isig(nchn,2)=j
23066 isig(nchn,3)=1
23067 sigh(nchn)=hi*wids(kfa,(5-kchr)/2)*wids(kfb,(5+kchr)/2)
23068 1604 CONTINUE
23069 1605 CONTINUE
23070
23071 ENDIF
23072
23073CMRENNA++
23074C...J: 2 -> 2, tree diagrams, SUSY processes
23075
23076 ELSEIF(isub.LE.210) THEN
23077 IF(isub.EQ.201) THEN
23078C...f + fbar -> e_L + e_Lbar
23079 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
23080 DO 1630 i=mmin1,mmax1
23081 ia=iabs(i)
23082 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1630
23083 ei=kchg(ia,1)/3d0
23084 tt3i=sign(1d0,ei+1d-6)/2d0
23085 ej=-1d0
23086 tt3j=-1d0/2d0
23087 fcol=1d0
23088C...Color factor for e+ e-
23089 IF(ia.GE.11) fcol=3d0
23090 IF(isubsv.EQ.301) THEN
23091 a1=1d0
23092 a2=0d0
23093 ELSEIF(ilr.EQ.1) THEN
23094 a1=sfmix(kfid,3)**2
23095 a2=sfmix(kfid,4)**2
23096 ELSEIF(ilr.EQ.0) THEN
23097 a1=sfmix(kfid,1)**2
23098 a2=sfmix(kfid,2)**2
23099 ENDIF
23100 xlq=(tt3j-ej*xw)*a1
23101 xrq=(-ej*xw)*a2
23102 xlf=(tt3i-ei*xw)
23103 xrf=(-ei*xw)
23104 taa=2d0*(ei*ej)**2
23105 tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/xw**2/xw1**2
23106 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*zwid/sh**2)
23107 taz=2d0*ei*ej*(xlq+xrq)*(xlf+xrf)/xw/xw1
23108 taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
23109 tnn=0.0d0
23110 tan=0.0d0
23111 tzn=0.0d0
23112 IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
23113 fac2=sqrt(2d0)
23114 tnn1=0d0
23115 tnn2=0d0
23116 tnn3=0d0
23117 DO 1620 ii=1,4
23118 dk=1d0/(th-smz(ii)**2)
23119 flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
23120 & zmix(ii,1))
23121 frek=fac2*tanw*ei*zmix(ii,1)
23122 tnn1=tnn1+flek**2*dk
23123 tnn2=tnn2+frek**2*dk
23124 DO 1610 jj=1,4
23125 dl=1d0/(th-smz(jj)**2)
23126 flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
23127 & zmix(jj,1))
23128 frel=fac2*tanw*ej*zmix(jj,1)
23129 tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
23130 1610 CONTINUE
23131 1620 CONTINUE
23132 tnn=(uh*th-sqm3*sqm4)*(a1**2*tnn1**2+a2**2*tnn2**2)
23133 tnn=(tnn+2d0*sh*a1*a2*tnn3)/4d0/xw**2
23134 tzn=(uh*th-sqm3*sqm4)*(xlq+xrq)*
23135 & (tnn1*xlf*a1+tnn2*xrf*a2)
23136 tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
23137 & (1d0-sqmz/sh)/sh
23138 tzn=tzn/xw**2/xw1
23139 tan=ei*ej*(uh*th-sqm3*sqm4)/sh*(a1*tnn1+a2*tnn2)/xw
23140 ENDIF
23141 facqq1=comfac*aem**2*(taa+tzz+taz)*fcol/3d0
23142 facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh**2
23143 facqq2=comfac*aem**2*(tnn+tzn+tan)*fcol/3d0
23144 nchn=nchn+1
23145 isig(nchn,1)=i
23146 isig(nchn,2)=-i
23147 isig(nchn,3)=1
23148 sigh(nchn)=facqq1+facqq2
23149 1630 CONTINUE
23150
23151 ELSEIF(isub.EQ.203) THEN
23152C...f + fbar -> e_L + e_Rbar
23153 DO 1660 i=mmin1,mmax1
23154 ia=iabs(i)
23155 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1660
23156 ei=kchg(iabs(i),1)/3d0
23157 tt3i=sign(1d0,ei)/2d0
23158 ej=-1
23159 tt3j=-1d0/2d0
23160 fcol=1d0
23161C...Color factor for e+ e-
23162 IF(ia.GE.11) fcol=3d0
23163 a1=sfmix(kfid,1)**2
23164 a2=sfmix(kfid,2)**2
23165 xlq=(tt3j-ej*xw)
23166 xrq=(-ej*xw)
23167 xlf=(tt3i-ei*xw)
23168 xrf=(-ei*xw)
23169 tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/xw**2/xw1**2*a1*a2
23170 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
23171 tnn=0.0d0
23172 tzn=0.0d0
23173 IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
23174 fac2=sqrt(2d0)
23175 tnn1=0d0
23176 tnn2=0d0
23177 tnn3=0d0
23178 DO 1650 ii=1,4
23179 dk=1d0/(th-smz(ii)**2)
23180 flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
23181 & zmix(ii,1))
23182 frek=fac2*tanw*ei*zmix(ii,1)
23183 tnn1=tnn1+flek**2*dk
23184 tnn2=tnn2+frek**2*dk
23185 DO 1640 jj=1,4
23186 dl=1d0/(th-smz(jj)**2)
23187 flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
23188 & zmix(jj,1))
23189 frel=fac2*tanw*ej*zmix(jj,1)
23190 tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
23191 1640 CONTINUE
23192 1650 CONTINUE
23193 tnn=(uh*th-sqm3*sqm4)*a1*a2*(tnn2**2+tnn1**2)
23194 tnn=(tnn+sh*(a2**2+a1**2)*tnn3)/4d0
23195 tzn=(uh*th-sqm3*sqm4)*a1*a2
23196 tzn=tzn*(xlq-xrq)*(xlf*tnn1-xrf*tnn2)/xw1
23197 tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
23198 & (1d0-sqmz/sh)/sh
23199 ENDIF
23200 facqq1=comfac*aem**2*tzz*fcol/3d0*(uh*th-sqm3*sqm4)/sh2
23201 facqq2=comfac*aem**2/xw**2*(tnn+tzn)*fcol/3d0
23202 facqq=(facqq1+facqq2)
23203 nchn=nchn+1
23204 isig(nchn,1)=i
23205 isig(nchn,2)=-i
23206 isig(nchn,3)=1
23207 sigh(nchn)=facqq*wids(pycomp(kfpr(isubsv,1)),2)*
23208 & wids(pycomp(kfpr(isubsv,2)),3)
23209 nchn=nchn+1
23210 isig(nchn,1)=i
23211 isig(nchn,2)=-i
23212 isig(nchn,3)=2
23213 sigh(nchn)=facqq*wids(pycomp(kfpr(isubsv,1)),3)*
23214 & wids(pycomp(kfpr(isubsv,2)),2)
23215 1660 CONTINUE
23216
23217 ELSEIF(isub.EQ.210) THEN
23218C...q + qbar' -> W*- > ~l_L + ~nu_L
23219 fac0=rkf*comfac*aem**2/xw**2/12d0
23220 fac1=(th*uh-sqm3*sqm4)/((sh-sqmw)**2+wwid**2*sqmw)
23221 DO 1680 i=mmin1,mmax1
23222 ia=iabs(i)
23223 IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 1680
23224 DO 1670 j=mmin2,mmax2
23225 ja=iabs(j)
23226 IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 1670
23227 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1670
23228 fckm=3d0
23229 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
23230 kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
23231 kchw=2
23232 IF(kchsum.LT.0) kchw=3
23233 nchn=nchn+1
23234 isig(nchn,1)=i
23235 isig(nchn,2)=j
23236 isig(nchn,3)=1
23237 IF(isubsv.EQ.297.OR.isubsv.EQ.298) THEN
23238 facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
23239 & wids(pycomp(kfpr(isubsv,2)),2)
23240 ELSE
23241 facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
23242 & wids(pycomp(kfpr(isubsv,2)),kchw)
23243 ENDIF
23244 sigh(nchn)=fac0*fac1*fckm*facr
23245 1670 CONTINUE
23246 1680 CONTINUE
23247 ENDIF
23248
23249 ELSEIF(isub.LE.220) THEN
23250 IF(isub.EQ.213) THEN
23251C...f + fbar -> ~nu_L + ~nu_Lbar
23252 IF(isubsv.EQ.299.OR.isubsv.EQ.300) THEN
23253 facr=wids(pycomp(kfpr(isubsv,1)),2)*
23254 & wids(pycomp(kfpr(isubsv,2)),2)
23255 ELSE
23256 facr=wids(pycomp(kfpr(isubsv,1)),1)
23257 ENDIF
23258 comfac=comfac*facr
23259 propz=(sh-sqmz)**2+zwid**2*sqmz
23260 xll=0.5d0
23261 xlr=0.0d0
23262 DO 1690 i=mmin1,mmax1
23263 ia=iabs(i)
23264 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1690
23265 ei=kchg(ia,1)/3d0
23266 fcol=1d0
23267C...Color factor for e+ e-
23268 IF(ia.GE.11) fcol=3d0
23269 xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
23270 xrq=-ei*xw
23271 tzc=0.0d0
23272 tcc=0.0d0
23273 IF(ia.GE.11.AND.kfid.EQ.ia+1) THEN
23274 tzc=vmix(1,1)**2/(th-smw(1)**2)+vmix(2,1)**2/
23275 & (th-smw(2)**2)
23276 tcc=tzc**2
23277 tzc=tzc/xw1*(sh-sqmz)/propz*xlq*xll
23278 ENDIF
23279 facqq1=(xlq**2+xrq**2)*(xll+xlr)**2/xw1**2/propz
23280 facqq2=tzc+tcc/4d0
23281 nchn=nchn+1
23282 isig(nchn,1)=i
23283 isig(nchn,2)=-i
23284 isig(nchn,3)=1
23285 sigh(nchn)=(facqq1+facqq2)*rkf*(uh*th-sqm3*sqm4)*comfac
23286 & *aem**2*fcol/3d0/xw**2
23287 1690 CONTINUE
23288
23289 ELSEIF(isub.EQ.216) THEN
23290C...q + qbar -> ~chi0_1 + ~chi0_1
23291 IF(izid1.EQ.izid2) THEN
23292 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
23293 ELSE
23294 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
23295 & wids(pycomp(kfpr(isubsv,2)),2)
23296 ENDIF
23297 facgg1=comfac*aem**2/3d0/xw**2
23298 IF(izid1.EQ.izid2) facgg1=facgg1/2d0
23299 zm12=sqm3
23300 zm22=sqm4
23301 wu2 = (uh-zm12)*(uh-zm22)/sh2
23302 wt2 = (th-zm12)*(th-zm22)/sh2
23303 xs2 = smz(izid1)*smz(izid2)/sh
23304 propz2 = (sh-sqmz)**2 + sqmz*zwid**2
23305 reprpz = (sh-sqmz)/propz2
23306 olpp=(-zmix(izid1,3)*zmix(izid2,3)+
23307 & zmix(izid1,4)*zmix(izid2,4))/2d0
23308 DO 1700 i=mmina,mmaxa
23309 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1700
23310 ei=kchg(iabs(i),1)/3d0
23311 fcol=1d0
23312 IF(abs(i).GE.11) fcol=3d0
23313 xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
23314 xrq=-ei*xw
23315 xlq=xlq/xw1
23316 xrq=xrq/xw1
23317C...Factored out sqrt(2)
23318 fr1=tanw*ei*zmix(izid1,1)
23319 fr2=tanw*ei*zmix(izid2,1)
23320 fl1=-(sign(1d0,ei)*zmix(izid1,2)-tanw*
23321 & (sign(1d0,ei)-2d0*ei)*zmix(izid1,1))/2d0
23322 fl2=-(sign(1d0,ei)*zmix(izid2,2)-tanw*
23323 & (sign(1d0,ei)-2d0*ei)*zmix(izid2,1))/2d0
23324 fr12=fr1**2
23325 fr22=fr2**2
23326 fl12=fl1**2
23327 fl22=fl2**2
23328 xml2=pmas(pycomp(ksusy1+iabs(i)),1)**2
23329 xmr2=pmas(pycomp(ksusy2+iabs(i)),1)**2
23330 facs=olpp**2*(xlq**2+xrq**2)*(wu2+wt2-2d0*xs2)*(sh2/propz2)
23331 fact=fl12*fl22*(wt2*sh2/(th-xml2)**2+wu2*sh2/(uh-xml2)**2-
23332 & 2d0*xs2*sh2/(th-xml2)/(uh-xml2))
23333 facu=fr12*fr22*(wt2*sh2/(th-xmr2)**2+wu2*sh2/(uh-xmr2)**2-
23334 & 2d0*xs2*sh2/(th-xmr2)/(uh-xmr2))
23335 facst=2d0*reprpz*olpp*xlq*fl1*fl2*( (wt2-xs2)*sh2/
23336 & (th-xml2) + (wu2-xs2)*sh2/(uh-xml2) )
23337 facsu=-2d0*reprpz*olpp*xrq*fr1*fr2*( (wt2-xs2)*sh2/
23338 & (th-xmr2) + (wu2-xs2)*sh2/(uh-xmr2) )
23339 nchn=nchn+1
23340 isig(nchn,1)=i
23341 isig(nchn,2)=-i
23342 isig(nchn,3)=1
23343 sigh(nchn)=facgg1*fcol*(facs+fact+facu+facst+facsu)
23344 1700 CONTINUE
23345 ENDIF
23346
23347 ELSEIF(isub.LE.230) THEN
23348 IF(isub.EQ.226) THEN
23349C...f + fbar -> ~chi+_1 + ~chi-_1
23350 facgg1=comfac*aem**2/3d0/xw**2
23351 zm12=sqm3
23352 zm22=sqm4
23353 wu2 = (uh-zm12)*(uh-zm22)/sh2
23354 wt2 = (th-zm12)*(th-zm22)/sh2
23355 ws2 = smw(izid1)*smw(izid2)/sh
23356 propz2 = (sh-sqmz)**2 + sqmz*zwid**2
23357 reprpz = (sh-sqmz)/propz2
23358 diff=0d0
23359 IF(izid1.EQ.izid2) diff=1d0
23360 DO 1710 i=mmina,mmaxa
23361 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1710
23362 ei=kchg(iabs(i),1)/3d0
23363 fcol=1d0
23364 IF(iabs(i).GE.11) fcol=3d0
23365 xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
23366 xrq=-ei*xw
23367 xlq=xlq/xw1
23368 xrq=xrq/xw1
23369 xlq2=xlq**2
23370 xrq2=xrq**2
23371 olp=-vmix(izid1,1)*vmix(izid2,1)-
23372 & vmix(izid1,2)*vmix(izid2,2)/2d0+xw*diff
23373 orp=-umix(izid1,1)*umix(izid2,1)-
23374 & umix(izid1,2)*umix(izid2,2)/2d0+xw*diff
23375 orp2=orp**2
23376 olp2=olp**2
23377C...u-type quark - d-type squark
23378 IF(mod(i,2).EQ.0) THEN
23379 fact0 = -umix(izid1,1)*umix(izid2,1)
23380 xml2=pmas(pycomp(ksusy1+iabs(i)-1),1)**2
23381C...d-type quark - u-type squark
23382 ELSE
23383 fact0 = vmix(izid1,1)*vmix(izid2,1)
23384 xml2=pmas(pycomp(ksusy1+iabs(i)+1),1)**2
23385 ENDIF
23386 faca=2d0*xw**2*diff*(wt2+wu2+2d0*abs(ws2))*ei**2
23387 facz=0.5d0*((xlq2+xrq2)*(olp2+orp2)*(wt2+wu2)+
23388 & 4d0*(xlq2+xrq2)*olp*orp*ws2-(xlq2-xrq2)*(olp2-orp2)*
23389 & (wu2-wt2))*sh2/propz2
23390 fact=fact0**2/4d0*wt2*sh2/(th-xml2)**2
23391 facaz=xw*reprpz*diff*( (xlq+xrq)*(olp+orp)*(wu2+
23392 & wt2+2d0*abs(ws2))-(xlq-xrq)*(olp-orp)*(wu2-wt2) )*sh*(-ei)
23393 facta=xw*diff/(th-xml2)*(wt2+abs(ws2))*sh*fact0*(-ei)
23394 factz=reprpz/(th-xml2)*xlq*fact0*(olp*wt2+orp*ws2)*sh2
23395 facsum=facgg1*(faca+facaz+facz+fact+facta+factz)*fcol
23396 nchn=nchn+1
23397 isig(nchn,1)=i
23398 isig(nchn,2)=-i
23399 isig(nchn,3)=1
23400 IF(izid1.EQ.izid2) THEN
23401 sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),1)
23402 ELSE
23403 sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),3)*
23404 & wids(pycomp(kfpr(isubsv,2)),2)
23405 nchn=nchn+1
23406 isig(nchn,1)=i
23407 isig(nchn,2)=-i
23408 isig(nchn,3)=2
23409 sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),2)*
23410 & wids(pycomp(kfpr(isubsv,2)),3)
23411 ENDIF
23412 1710 CONTINUE
23413
23414 ELSEIF(isub.EQ.229) THEN
23415C...q + qbar' -> ~chi0_1 + ~chi+-_1
23416 facgg1=comfac*aem**2/6d0/xw**2
23417 zm12=sqm3
23418 zm22=sqm4
23419 zmu2 = pmas(pycomp(ksusy1+2),1)**2
23420 zmd2 = pmas(pycomp(ksusy1+1),1)**2
23421 wu2 = (uh-zm12)*(uh-zm22)/sh2
23422 wt2 = (th-zm12)*(th-zm22)/sh2
23423 ws2 = smw(izid1)*smz(izid2)/sh
23424 rt2i = 1d0/sqrt(2d0)
23425 propw = ((sh-sqmw)**2+wwid**2*sqmw)
23426 ol=-rt2i*zmix(izid2,4)*vmix(izid1,2)+
23427 & zmix(izid2,2)*vmix(izid1,1)
23428 or= rt2i*zmix(izid2,3)*umix(izid1,2)+
23429 & zmix(izid2,2)*umix(izid1,1)
23430 ol2=ol**2
23431 or2=or**2
23432 cross=2d0*ol*or
23433 facst0=umix(izid1,1)
23434 facsu0=vmix(izid1,1)
23435 facsu0=facsu0*(0.5d0*zmix(izid2,2)+tanw*zmix(izid2,1)/6d0)
23436 facst0=facst0*(-0.5d0*zmix(izid2,2)+tanw*zmix(izid2,1)/6d0)
23437 fact0=facst0**2
23438 facu0=facsu0**2
23439 factu0=facsu0*facst0
23440 facst = -2d0*(sh-sqmw)/propw/(th-zmd2)*(wt2*sh2*or
23441 & + sh2*ws2*ol)*facst0
23442 facsu = 2d0*(sh-sqmw)/propw/(uh-zmu2)*(wu2*sh2*ol
23443 & + sh2*ws2*or)*facsu0
23444 fact = wt2*sh2/(th-zmd2)**2*fact0
23445 facu = wu2*sh2/(uh-zmu2)**2*facu0
23446 factu = -2d0*ws2*sh2/(th-zmd2)/(uh-zmu2)*factu0
23447 facw = (or2*wt2+ol2*wu2+cross*ws2)/propw*sh2
23448 facgg1=facgg1*(facw+fact+factu+facu+facsu+facst)
23449 DO 1730 i=mmin1,mmax1
23450 ia=iabs(i)
23451 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 1730
23452 DO 1720 j=mmin2,mmax2
23453 ja=iabs(j)
23454 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 1720
23455 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1720
23456 fckm=3d0
23457 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
23458 kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
23459 kchw=2
23460 IF(kchsum.LT.0) kchw=3
23461 nchn=nchn+1
23462 isig(nchn,1)=i
23463 isig(nchn,2)=j
23464 isig(nchn,3)=1
23465 sigh(nchn)=facgg1*fckm*wids(pycomp(kfpr(isubsv,1)),2)*
23466 & wids(pycomp(kfpr(isubsv,2)),kchw)
23467 1720 CONTINUE
23468 1730 CONTINUE
23469 ENDIF
23470
23471 ELSEIF(isub.LE.240) THEN
23472 IF(isub.EQ.237) THEN
23473C...q + qbar -> gluino + ~chi0_1
23474 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
23475 & wids(pycomp(kfpr(isubsv,2)),2)
23476 fac0=comfac*as*aem*4d0/9d0/xw
23477 gm2=sqm3
23478 zm2=sqm4
23479 DO 1740 i=mmina,mmaxa
23480 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 1740
23481 ei=kchg(iabs(i),1)/3d0
23482 ia=iabs(i)
23483 xlqc = -tanw*ei*zmix(izid,1)
23484 xrqc =(sign(1d0,ei)*zmix(izid,2)-tanw*
23485 & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
23486 xlq2=xlqc**2
23487 xrq2=xrqc**2
23488 xml2=pmas(pycomp(ksusy1+ia),1)**2
23489 xmr2=pmas(pycomp(ksusy2+ia),1)**2
23490 atkin=(th-gm2)*(th-zm2)/(th-xml2)**2
23491 aukin=(uh-gm2)*(uh-zm2)/(uh-xml2)**2
23492 atukin=smz(izid)*sqrt(gm2)*sh/(th-xml2)/(uh-xml2)
23493 sgchil=xlq2*(atkin+aukin-2d0*atukin)
23494 atkin=(th-gm2)*(th-zm2)/(th-xmr2)**2
23495 aukin=(uh-gm2)*(uh-zm2)/(uh-xmr2)**2
23496 atukin=smz(izid)*sqrt(gm2)*sh/(th-xmr2)/(uh-xmr2)
23497 sgchir=xrq2*(atkin+aukin-2d0*atukin)
23498 nchn=nchn+1
23499 isig(nchn,1)=i
23500 isig(nchn,2)=-i
23501 isig(nchn,3)=1
23502 sigh(nchn)=fac0*(sgchil+sgchir)
23503 1740 CONTINUE
23504 ENDIF
23505
23506 ELSEIF(isub.LE.250) THEN
23507 IF(isub.EQ.241) THEN
23508C...q + qbar' -> ~chi+-_1 + gluino
23509 facwg=comfac*as*aem/xw*2d0/9d0
23510 gm2=sqm3
23511 zm2=sqm4
23512 fac01=2d0*umix(izid,1)*vmix(izid,1)
23513 fac0=umix(izid,1)**2
23514 fac1=vmix(izid,1)**2
23515 DO 1760 i=mmin1,mmax1
23516 ia=iabs(i)
23517 IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 1760
23518 DO 1750 j=mmin2,mmax2
23519 ja=iabs(j)
23520 IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 1750
23521 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 1750
23522 fckm=1d0
23523 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
23524 kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
23525 kchw=2
23526 IF(kchsum.LT.0) kchw=3
23527 xmu2=pmas(pycomp(ksusy1+2),1)**2
23528 xmd2=pmas(pycomp(ksusy1+1),1)**2
23529 atkin=(th-gm2)*(th-zm2)/(th-xmu2)**2
23530 aukin=(uh-gm2)*(uh-zm2)/(uh-xmd2)**2
23531 atukin=smw(izid)*sqrt(gm2)*sh/(th-xmu2)/(uh-xmd2)
23532 xmu2=pmas(pycomp(ksusy2+2),1)**2
23533 xmd2=pmas(pycomp(ksusy2+1),1)**2
23534 atkin=(atkin+(th-gm2)*(th-zm2)/(th-xmu2)**2)/2d0
23535 aukin=(aukin+(uh-gm2)*(uh-zm2)/(uh-xmd2)**2)/2d0
23536 atukin=(atukin+smw(izid)*sqrt(gm2)*
23537 & sh/(th-xmu2)/(uh-xmd2))/2d0
23538 nchn=nchn+1
23539 isig(nchn,1)=i
23540 isig(nchn,2)=j
23541 isig(nchn,3)=1
23542 sigh(nchn)=facwg*fckm*(fac0*atkin+fac1*aukin-
23543 & fac01*atukin)*wids(pycomp(kfpr(isubsv,1)),2)*
23544 & wids(pycomp(kfpr(isubsv,2)),kchw)
23545 1750 CONTINUE
23546 1760 CONTINUE
23547
23548 ELSEIF(isub.EQ.243) THEN
23549C...q + qbar -> gluino + gluino
23550 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
23551 xmt=sqm3-th
23552 xmu=sqm3-uh
23553 DO 1770 i=mmina,mmaxa
23554 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
23555 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1770
23556 nchn=nchn+1
23557 xsu=pmas(pycomp(ksusy1+iabs(i)),1)**2-uh
23558 xst=pmas(pycomp(ksusy1+iabs(i)),1)**2-th
23559 facgg1=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
23560 & 2d0*sqm3*sh)/sh2 +4d0/9d0*(xmt**2/xst**2+
23561 & xmu**2/xsu**2) - (xmt**2+sh*sqm3)/sh/xst +
23562 & sqm3*sh/xst/xsu/9d0- (xmu**2+sh*sqm3)/sh/xsu )
23563 xsu=pmas(pycomp(ksusy2+iabs(i)),1)**2-uh
23564 xst=pmas(pycomp(ksusy2+iabs(i)),1)**2-th
23565 facgg2=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
23566 & 2d0*sqm3*sh)/sh2 +4d0/9d0*(xmt**2/xst**2+
23567 & xmu**2/xsu**2) - (xmt**2+sh*sqm3)/sh/xst +
23568 & sqm3*sh/xst/xsu/9d0- (xmu**2+sh*sqm3)/sh/xsu )
23569 isig(nchn,1)=i
23570 isig(nchn,2)=-i
23571 isig(nchn,3)=1
23572C...1/2 for identical particles
23573 sigh(nchn)=0.25d0*(facgg1+facgg2)
23574 1770 CONTINUE
23575
23576 ELSEIF(isub.EQ.244) THEN
23577C...g + g -> gluino + gluino
23578 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
23579 xmt=sqm3-th
23580 xmu=sqm3-uh
23581 facqq1=comfac*as**2*9d0/4d0*(
23582 & (xmt*xmu-2d0*sqm3*(th+sqm3))/xmt**2 -
23583 & (xmt*xmu+sqm3*(uh-th))/sh/xmt )
23584 facqq2=comfac*as**2*9d0/4d0*(
23585 & (xmu*xmt-2d0*sqm3*(uh+sqm3))/xmu**2 -
23586 & (xmu*xmt+sqm3*(th-uh))/sh/xmu )
23587 facqq3=comfac*as**2*9d0/4d0*(2d0*xmt*xmu/sh2 +
23588 & sqm3*(sh-4d0*sqm3)/xmt/xmu)
23589 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1780
23590 nchn=nchn+1
23591 isig(nchn,1)=21
23592 isig(nchn,2)=21
23593 isig(nchn,3)=1
23594 sigh(nchn)=facqq1/2d0
23595 nchn=nchn+1
23596 isig(nchn,1)=21
23597 isig(nchn,2)=21
23598 isig(nchn,3)=2
23599 sigh(nchn)=facqq2/2d0
23600 nchn=nchn+1
23601 isig(nchn,1)=21
23602 isig(nchn,2)=21
23603 isig(nchn,3)=3
23604 sigh(nchn)=facqq3/2d0
23605 1780 CONTINUE
23606
23607 ELSEIF(isub.EQ.246) THEN
23608C...g + q_j -> ~chi0_1 + ~q_j
23609 fac0=comfac*as*aem/6d0/xw
23610 zm2=sqm4
23611 qm2=sqm3
23612 faczq0=fac0*( (zm2-th)/sh +
23613 & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
23614 & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
23615 kfnsq=mod(kfpr(isubsv,1),ksusy1)
23616 DO 1800 i=-kfnsq,kfnsq,2*kfnsq
23617 IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 1800
23618 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 1800
23619 ei=kchg(iabs(i),1)/3d0
23620 ia=iabs(i)
23621 xrqz = -tanw*ei*zmix(izid,1)
23622 xlqz =(sign(1d0,ei)*zmix(izid,2)-tanw*
23623 & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
23624 IF(ilr.EQ.0) THEN
23625 bs=xlqz**2*sfmix(ia,1)**2+xrqz**2*sfmix(ia,2)**2
23626 ELSE
23627 bs=xlqz**2*sfmix(ia,3)**2+xrqz**2*sfmix(ia,4)**2
23628 ENDIF
23629 faczq=faczq0*bs
23630 kchq=2
23631 IF(i.LT.0) kchq=3
23632 DO 1790 isde=1,2
23633 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1790
23634 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 1790
23635 nchn=nchn+1
23636 isig(nchn,isde)=i
23637 isig(nchn,3-isde)=21
23638 isig(nchn,3)=1
23639 sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
23640 & wids(pycomp(kfpr(isubsv,2)),2)
23641 1790 CONTINUE
23642 1800 CONTINUE
23643 ENDIF
23644
23645 ELSEIF(isub.LE.260) THEN
23646 IF(isub.EQ.254) THEN
23647C...g + q_j -> ~chi1_1 + ~q_i
23648 fac0=comfac*as*aem/12d0/xw
23649 zm2=sqm4
23650 qm2=sqm3
23651 au=umix(izid,1)**2
23652 ad=vmix(izid,1)**2
23653 faczq0=fac0*( (zm2-th)/sh +
23654 & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
23655 & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
23656 kfnsq1=mod(kfpr(isubsv,1),ksusy1)
23657 IF(mod(kfnsq1,2).EQ.0) THEN
23658 kfnsq=kfnsq1-1
23659 kchw=2
23660 ELSE
23661 kfnsq=kfnsq1+1
23662 kchw=3
23663 ENDIF
23664 DO 1820 i=-kfnsq,kfnsq,2*kfnsq
23665 IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 1820
23666 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 1820
23667 ia=iabs(i)
23668 IF(mod(ia,2).EQ.0) THEN
23669 faczq=faczq0*au
23670 ELSE
23671 faczq=faczq0*ad
23672 ENDIF
23673 faczq=faczq*sfmix(kfnsq1,1+2*ilr)**2
23674 kchq=2
23675 IF(i.LT.0) kchq=3
23676 kchwq=kchw
23677 IF(i.LT.0) kchwq=5-kchw
23678 DO 1810 isde=1,2
23679 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1810
23680 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 1810
23681 nchn=nchn+1
23682 isig(nchn,isde)=i
23683 isig(nchn,3-isde)=21
23684 isig(nchn,3)=1
23685 sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
23686 & wids(pycomp(kfpr(isubsv,2)),kchwq)
23687 1810 CONTINUE
23688 1820 CONTINUE
23689
23690 ELSEIF(isub.EQ.258) THEN
23691C...g + q_j -> gluino + ~q_i
23692 xg2=sqm4
23693 xq2=sqm3
23694 xmt=xg2-th
23695 xmu=xg2-uh
23696 xst=xq2-th
23697 xsu=xq2-uh
23698 facqg1=0.5d0*4d0/9d0*xmt/sh + (xmt*sh+2d0*xg2*xst)/xmt**2 -
23699 & ( (sh-xq2+xg2)*(-xst)-sh*xg2 )/sh/(-xmt) +
23700 & 0.5d0*1d0/2d0*( xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst) +
23701 & (-xmu)*(th+xg2+2d0*xq2) )/2d0/xmt/xsu
23702 facqg2= 4d0/9d0*(-xmu)*(uh+xq2)/xsu**2 + 1d0/18d0*
23703 & (sh*(uh+xg2)
23704 & +2d0*(xq2-xg2)*xmu)/sh/(-xsu) + 0.5d0*4d0/9d0*xmt/sh +
23705 & 0.5d0*1d0/2d0*(xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst)+
23706 & (-xmu)*(th+xg2+2d0*xq2))/2d0/xmt/xsu
23707 facqg1=comfac*as**2*facqg1/2d0
23708 facqg2=comfac*as**2*facqg2/2d0
23709 kfnsq=mod(kfpr(isubsv,1),ksusy1)
23710 DO 1840 i=-kfnsq,kfnsq,2*kfnsq
23711 IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 1840
23712 IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 1840
23713 kchq=2
23714 IF(i.LT.0) kchq=3
23715 facsel=rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
23716 & wids(pycomp(kfpr(isubsv,2)),2)
23717 DO 1830 isde=1,2
23718 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 1830
23719 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 1830
23720 nchn=nchn+1
23721 isig(nchn,isde)=i
23722 isig(nchn,3-isde)=21
23723 isig(nchn,3)=1
23724 sigh(nchn)=facqg1*facsel
23725 nchn=nchn+1
23726 isig(nchn,isde)=i
23727 isig(nchn,3-isde)=21
23728 isig(nchn,3)=2
23729 sigh(nchn)=facqg2*facsel
23730 1830 CONTINUE
23731 1840 CONTINUE
23732 ENDIF
23733
23734 ELSEIF(isub.LE.270) THEN
23735 IF(isub.EQ.261) THEN
23736C...q_i + q_ibar -> ~t_1 + ~t_1bar
23737 facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )*
23738 & wids(pycomp(kfpr(isubsv,1)),1)
23739 kfnsq=mod(kfpr(isubsv,1),ksusy1)
23740 fac0=as**2*4d0/9d0
23741 DO 1850 i=mmin1,mmax1
23742 ia=iabs(i)
23743 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1850
23744 IF(ia.GE.11.AND.ia.LE.18) THEN
23745 ei=kchg(ia,1)/3d0
23746 ej=kchg(kfnsq,1)/3d0
23747 t3i=sign(1d0,ei)/2d0
23748 t3j=sign(1d0,ej)/2d0
23749 xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,2*ilr+1)**2
23750 xrq=2d0*(-ej*xw)*sfmix(kfnsq,2*ilr+2)**2
23751 xlf=2d0*(t3i-ei*xw)
23752 xrf=2d0*(-ei*xw)
23753 taa=0.5d0*(ei*ej)**2
23754 tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
23755 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
23756 taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
23757 taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
23758 fac0=aem**2*12d0*(taa+tzz+taz)
23759 ENDIF
23760 nchn=nchn+1
23761 isig(nchn,1)=i
23762 isig(nchn,2)=-i
23763 isig(nchn,3)=1
23764 sigh(nchn)=facqq1*fac0
23765 1850 CONTINUE
23766
23767 ELSEIF(isub.EQ.263) THEN
23768C...f + fbar -> ~t1 + ~t2bar
23769 DO 1860 i=mmin1,mmax1
23770 ia=iabs(i)
23771 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1860
23772 ei=kchg(iabs(i),1)/3d0
23773 tt3i=sign(1d0,ei)/2d0
23774 ej=2d0/3d0
23775 tt3j=1d0/2d0
23776 fcol=1d0
23777C...Color factor for e+ e-
23778 IF(ia.GE.11) fcol=3d0
23779 xlq=2d0*(tt3j-ej*xw)
23780 xrq=2d0*(-ej*xw)
23781 xlf=2d0*(tt3i-ei*xw)
23782 xrf=2d0*(-ei*xw)
23783 tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/64d0/xw**2/xw1**2
23784 tzz=tzz*(sfmix(6,1)*sfmix(6,2))**2
23785 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
23786C...Factor of 2 for t1 t2bar + t2 t1bar
23787 facqq1=2d0*comfac*aem**2*tzz*fcol*4d0
23788 facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh2
23789 nchn=nchn+1
23790 isig(nchn,1)=i
23791 isig(nchn,2)=-i
23792 isig(nchn,3)=1
23793 sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),2)*
23794 & wids(pycomp(kfpr(isubsv,2)),3)
23795 nchn=nchn+1
23796 isig(nchn,1)=i
23797 isig(nchn,2)=-i
23798 isig(nchn,3)=2
23799 sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),3)*
23800 & wids(pycomp(kfpr(isubsv,2)),2)
23801 1860 CONTINUE
23802
23803 ELSEIF(isub.EQ.264) THEN
23804C...g + g -> ~t_1 + ~t_1bar
23805 xsu=sqm3-uh
23806 xst=sqm3-th
23807 fac0=comfac*as**2*(7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )*0.5d0*
23808 & wids(pycomp(kfpr(isubsv,1)),1)
23809 facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
23810 facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
23811 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1870
23812 nchn=nchn+1
23813 isig(nchn,1)=21
23814 isig(nchn,2)=21
23815 isig(nchn,3)=1
23816 sigh(nchn)=facqq1
23817 nchn=nchn+1
23818 isig(nchn,1)=21
23819 isig(nchn,2)=21
23820 isig(nchn,3)=2
23821 sigh(nchn)=facqq2
23822 1870 CONTINUE
23823 ENDIF
23824
23825 ELSEIF(isub.LE.280) THEN
23826 IF(isub.EQ.271) THEN
23827C...q + q' -> ~q + ~q' (~g exchange)
23828 xmg2=pmas(pycomp(ksusy1+21),1)**2
23829 xmt=xmg2-th
23830 xmu=xmg2-uh
23831 xsu1=sqm3-uh
23832 xsu2=sqm4-uh
23833 xst1=sqm3-th
23834 xst2=sqm4-th
23835 IF(ilr.EQ.1) THEN
23836 facqq1=comfac*as**2*4d0/9d0*( -(xst1*xst2+sh*th)/xmt**2 )
23837 facqq2=comfac*as**2*4d0/9d0*( -(xsu1*xsu2+sh*uh)/xmu**2 )
23838 facqqb=0.0d0
23839 ELSE
23840 facqq1=0.5d0*comfac*as**2*4d0/9d0*( sh*xmg2/xmt**2 )
23841 facqq2=0.5d0*comfac*as**2*4d0/9d0*( sh*xmg2/xmu**2 )
23842 facqqb=0.5d0*comfac*as**2*4d0/9d0*( -2d0*sh*xmg2/3d0/
23843 & xmt/xmu )
23844 ENDIF
23845 kfnsqi=mod(kfpr(isubsv,1),ksusy1)
23846 kfnsqj=mod(kfpr(isubsv,2),ksusy1)
23847 DO 1890 i=-kfnsqi,kfnsqi,2*kfnsqi
23848 IF(i.LT.mmin1.OR.i.GT.mmax1) GOTO 1890
23849 ia=iabs(i)
23850 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 1890
23851 kchq=2
23852 IF(i.LT.0) kchq=3
23853 DO 1880 j=-kfnsqj,kfnsqj,2*kfnsqj
23854 IF(j.LT.mmin2.OR.j.GT.mmax2) GOTO 1880
23855 ja=iabs(j)
23856 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 1880
23857 IF(i*j.LT.0) GOTO 1880
23858 nchn=nchn+1
23859 isig(nchn,1)=i
23860 isig(nchn,2)=j
23861 isig(nchn,3)=1
23862 sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
23863 & wids(pycomp(kfpr(isubsv,2)),kchq)
23864 IF(i.EQ.j) THEN
23865 IF(ilr.EQ.0) THEN
23866 sigh(nchn)=0.5d0*(facqq1+0.5d0*facqqb)*rkf*
23867 & wids(pycomp(kfpr(isubsv,1)),kchq+2)
23868 ELSE
23869 sigh(nchn)=0.5d0*facqq1*rkf*
23870 & wids(pycomp(kfpr(isubsv,1)),kchq)*
23871 & wids(pycomp(kfpr(isubsv,2)),kchq)
23872 ENDIF
23873 nchn=nchn+1
23874 isig(nchn,1)=i
23875 isig(nchn,2)=j
23876 isig(nchn,3)=2
23877 IF(ilr.EQ.0) THEN
23878 sigh(nchn)=0.5d0*(facqq2+0.5d0*facqqb)*rkf*
23879 & wids(pycomp(kfpr(isubsv,1)),kchq+2)
23880 ELSE
23881 sigh(nchn)=0.5d0*facqq2*rkf*
23882 & wids(pycomp(kfpr(isubsv,1)),kchq)*
23883 & wids(pycomp(kfpr(isubsv,2)),kchq)
23884 ENDIF
23885 ENDIF
23886 1880 CONTINUE
23887 1890 CONTINUE
23888
23889 ELSEIF(isub.EQ.274) THEN
23890C...q + qbar' -> ~q + ~qbar'
23891 xmg2=pmas(pycomp(ksusy1+21),1)**2
23892 xmt=xmg2-th
23893 xmu=xmg2-uh
23894 IF(ilr.EQ.0) THEN
23895C...Mrenna...Normalization.and.1/XMT
23896 facqq1=comfac*as**2*2d0/9d0*(
23897 & (uh*th-sqm3*sqm4)/xmt**2 )
23898 facqqb=comfac*as**2*2d0/9d0*(
23899 & (uh*th-sqm3*sqm4)/sh2*(2d0-2d0/3d0*sh/xmt))
23900 facqqb=facqqb+facqq1
23901 ELSE
23902 facqq1=comfac*as**2*4d0/9d0*( xmg2*sh/xmt**2 )
23903 facqqb=facqq1
23904 ENDIF
23905 kfnsqi=mod(kfpr(isubsv,1),ksusy1)
23906 kfnsqj=mod(kfpr(isubsv,2),ksusy1)
23907 DO 1910 i=-kfnsqi,kfnsqi,2*kfnsqi
23908 IF(i.LT.mmin1.OR.i.GT.mmax1) GOTO 1910
23909 ia=iabs(i)
23910 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 1910
23911 kchq=2
23912 IF(i.LT.0) kchq=3
23913 DO 1900 j=-kfnsqj,kfnsqj,2*kfnsqj
23914 IF(j.LT.mmin2.OR.j.GT.mmax2) GOTO 1900
23915 ja=iabs(j)
23916 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 1900
23917 IF(i*j.GT.0) GOTO 1900
23918 nchn=nchn+1
23919 isig(nchn,1)=i
23920 isig(nchn,2)=j
23921 isig(nchn,3)=1
23922 sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
23923 & wids(pycomp(kfpr(isubsv,2)),5-kchq)
23924 IF(i.EQ.-j) sigh(nchn)=facqqb*rkf*
23925 & wids(pycomp(kfpr(isubsv,1)),1)
23926 1900 CONTINUE
23927 1910 CONTINUE
23928
23929 ELSEIF(isub.EQ.277) THEN
23930C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
23931C...if i .eq. j covered in 274
23932 facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )
23933 kfnsq=mod(kfpr(isubsv,1),ksusy1)
23934 fac0=0d0
23935 DO 1920 i=mmin1,mmax1
23936 ia=iabs(i)
23937 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.
23938 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 1920
23939 IF(ia.EQ.kfnsq) GOTO 1920
23940 IF(ia.EQ.11.OR.ia.EQ.13.OR.ia.EQ.15) THEN
23941 ei=kchg(ia,1)/3d0
23942 ej=kchg(kfnsq,1)/3d0
23943 t3j=sign(0.5d0,ej)
23944 t3i=sign(1d0,ei)/2d0
23945 IF(ilr.EQ.0) THEN
23946 xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,1)
23947 xrq=2d0*(-ej*xw)*sfmix(kfnsq,2)
23948 ELSE
23949 xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,3)
23950 xrq=2d0*(-ej*xw)*sfmix(kfnsq,4)
23951 ENDIF
23952 xlf=2d0*(t3i-ei*xw)
23953 xrf=2d0*(-ei*xw)
23954 IF(ilr.EQ.0) THEN
23955 xrq=0d0
23956 ELSE
23957 xlq=0d0
23958 ENDIF
23959 taa=0.5d0*(ei*ej)**2
23960 tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
23961 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
23962 taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
23963 taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
23964 fac0=aem**2*12d0*(taa+tzz+taz)
23965 ELSEIF(ia.LE.6) THEN
23966 fac0=as**2*8d0/9d0/2d0
23967 ENDIF
23968 nchn=nchn+1
23969 isig(nchn,1)=i
23970 isig(nchn,2)=-i
23971 isig(nchn,3)=1
23972 sigh(nchn)=facqq1*fac0*rkf*wids(pycomp(kfpr(isubsv,1)),1)
23973 1920 CONTINUE
23974
23975 ELSEIF(isub.EQ.279) THEN
23976C...g + g -> ~q_j + ~q_jbar
23977 xsu=sqm3-uh
23978 xst=sqm3-th
23979C...5=RKF because ~t ~tbar treated separately
23980 fac0=rkf*comfac*as**2*( 7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )
23981 facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
23982 facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
23983 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 1930
23984 nchn=nchn+1
23985 isig(nchn,1)=21
23986 isig(nchn,2)=21
23987 isig(nchn,3)=1
23988 sigh(nchn)=facqq1/2d0*wids(pycomp(kfpr(isubsv,1)),1)
23989 nchn=nchn+1
23990 isig(nchn,1)=21
23991 isig(nchn,2)=21
23992 isig(nchn,3)=2
23993 sigh(nchn)=facqq2/2d0*wids(pycomp(kfpr(isubsv,1)),1)
23994 1930 CONTINUE
23995
23996 ENDIF
23997CMRENNA--
23998
23999 ELSEIF(isub.LE.340) THEN
24000
24001 ELSEIF(isub.LE.360) THEN
24002
24003 IF(isub.EQ.341.OR.isub.EQ.342) THEN
24004C...l + l -> H_L++/-- or H_R++/--.
24005 kfres=kfpr(isub,1)
24006 CALL pywidt(kfres,sh,wdtp,wdte)
24007 hs=shr*wdtp(0)
24008 facbw=8d0*comfac/((sh-pmas(kfres,1)**2)**2+hs**2)
24009 DO 1950 i=mmin1,mmax1
24010 ia=iabs(i)
24011 IF((ia.NE.11.AND.ia.NE.13.AND.ia.NE.15).OR.kfac(1,i).EQ.0)
24012 & GOTO 1950
24013 DO 1940 j=mmin2,mmax2
24014 ja=iabs(j)
24015 IF((ja.NE.11.AND.ja.NE.13.AND.ja.NE.15).OR.kfac(2,j).EQ.0)
24016 & GOTO 1940
24017 IF(i*j.LT.0) GOTO 1940
24018 kchh=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
24019 nchn=nchn+1
24020 isig(nchn,1)=i
24021 isig(nchn,2)=j
24022 isig(nchn,3)=1
24023 hi=sh*parp(181+3*((ia-11)/2)+(ja-11)/2)**2/(8d0*paru(1))
24024 hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
24025 sigh(nchn)=hi*facbw*hf
24026 1940 CONTINUE
24027 1950 CONTINUE
24028
24029 ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
24030C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
24031 kfres=kfpr(isub,1)
24032C...Propagators: as simulated in PYOFSH and as desired
24033 hbw3=pmas(kfres,1)*pmas(kfres,2)/((sqm3-pmas(kfres,1)**2)**2+
24034 & (pmas(kfres,1)*pmas(kfres,2))**2)
24035 CALL pywidt(kfres,sqm3,wdtp,wdte)
24036 gmmc=sqrt(sqm3)*wdtp(0)
24037 hbw3c=gmmc/((sqm3-pmas(kfres,1)**2)**2+gmmc**2)
24038 fhcc=comfac*aem*hbw3c/hbw3
24039 DO 1980 i=mmina,mmaxa
24040 ia=iabs(i)
24041 IF(ia.NE.11.AND.ia.NE.13.AND.ia.NE.15) GOTO 1980
24042 sqml=pmas(ia,1)**2
24043 j=isign(kfpr(isub,2),-i)
24044 kchh=isign(2,kchg(ia,1)*isign(1,i))
24045 widsc=(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))/wdtp(0)
24046 smm1=8d0*(sh+th-sqm3)*(sh+th-2d0*sqm3-sqml-sqm4)/
24047 & (uh-sqm3)**2
24048 smm2=2d0*((2d0*sqm3-3d0*sqml)*sqm4+(sqml-2d0*sqm4)*th-
24049 & (th-sqm4)*sh)/(th-sqm4)**2
24050 smm3=2d0*((2d0*sqm3-3d0*sqm4+th)*sqml-(2d0*sqml-sqm4+th)*
24051 & sh)/(sh-sqml)**2
24052 smm12=4d0*((2d0*sqml-sqm4-2d0*sqm3+th)*sh+(th-3d0*sqm3-
24053 & 3d0*sqm4)*th+(2d0*sqm3-2d0*sqml+3d0*sqm4)*sqm3)/
24054 & ((uh-sqm3)*(th-sqm4))
24055 smm13=-4d0*((th+sqml-2d0*sqm4)*th-(sqm3+3d0*sqml-2d0*sqm4)*
24056 & sqm3+(sqm3+3d0*sqml+th)*sh-(th-sqm3+sh)**2)/
24057 & ((uh-sqm3)*(sh-sqml))
24058 smm23=-4d0*((sqml-sqm4+sqm3)*th-sqm3**2+sqm3*(sqml+sqm4)-
24059 & 3d0*sqml*sqm4-(sqml-sqm4-sqm3+th)*sh)/
24060 & ((sh-sqml)*(th-sqm4))
24061 smm=(sh/(sh-sqml))**2*(smm1+smm2+smm3+smm12+smm13+smm23)*
24062 & parp(181+3*((ia-11)/2)+(iabs(j)-11)/2)**2/(4d0*paru(1))
24063 DO 1960 isde=1,2
24064 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 1960
24065 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 1960
24066 nchn=nchn+1
24067 isig(nchn,isde)=i
24068 isig(nchn,3-isde)=22
24069 isig(nchn,3)=0
24070 sigh(nchn)=fhcc*smm*widsc
24071 1960 CONTINUE
24072 1980 CONTINUE
24073
24074 ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
24075C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
24076 kfres=kfpr(isub,1)
24077 sqmh=pmas(kfres,1)**2
24078 gmmh=pmas(kfres,1)*pmas(kfres,2)
24079C...Propagators: H++/-- as simulated in PYOFSH and as desired
24080 hbw3=gmmh/((sqm3-sqmh)**2+gmmh**2)
24081 CALL pywidt(kfres,sqm3,wdtp,wdte)
24082 gmmh3=sqrt(sqm3)*wdtp(0)
24083 hbw3c=gmmh3/((sqm3-sqmh)**2+gmmh3**2)
24084 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
24085 CALL pywidt(kfres,sqm4,wdtp,wdte)
24086 gmmh4=sqrt(sqm4)*wdtp(0)
24087 hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
24088C...Kinematical and coupling functions
24089 fachh=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*(th*uh-sqm3*sqm4)
24090 xwhh=(1d0-2d0*xwv)/(8d0*xwv*(1d0-xwv))
24091C...Loop over allowed flavours
24092 DO 2000 i=mmina,mmaxa
24093 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2000
24094 ei=kchg(iabs(i),1)/3d0
24095 ai=sign(1d0,ei+0.1d0)
24096 vi=ai-4d0*ei*xwv
24097 fcoi=1d0
24098 IF(iabs(i).LE.10) fcoi=faca/3d0
24099 IF(isub.EQ.349) THEN
24100 hbwz=1d0/((sh-sqmz)**2+gmmz**2)
24101 IF(iabs(i).LT.10) THEN
24102 dsighh=8d0*aem**2*(ei**2/sh2+
24103 & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
24104 & (vi**2+ai**2)*xwhh**2*hbwz)
24105 ELSE
24106 iaoff=181+3*((iabs(i)-11)/2)
24107 hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
24108 & (4d0*paru(1))
24109 dsighh=8d0*aem**2*(ei**2/sh2+
24110 & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
24111 & (vi**2+ai**2)*xwhh**2*hbwz)+
24112 & 8d0*aem*(ei*hsum/(sh*th)+
24113 & (vi+ai)*xwhh*hsum*(sh-sqmz)*hbwz/th)+
24114 & 4d0*hsum**2/th2
24115 ENDIF
24116 ELSE
24117 IF(iabs(i).LT.10) THEN
24118 dsighh=8d0*aem**2*ei**2/sh2
24119 ELSE
24120 iaoff=181+3*((iabs(i)-11)/2)
24121 hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
24122 & (4d0*paru(1))
24123 dsighh=8d0*aem**2*ei**2/sh2+8d0*aem*ei*hsum/(sh*th)+
24124 & 4d0*hsum**2/th2
24125 ENDIF
24126 ENDIF
24127 nchn=nchn+1
24128 isig(nchn,1)=i
24129 isig(nchn,2)=-i
24130 isig(nchn,3)=1
24131 sigh(nchn)=fachh*fcoi*dsighh
24132 2000 CONTINUE
24133
24134 ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
24135C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
24136 kfres=kfpr(isub,1)
24137 sqmh=pmas(kfres,1)**2
24138 IF(isub.EQ.351) facnor=parp(190)**8*parp(192)**2
24139 IF(isub.EQ.352) facnor=parp(191)**6*2d0*pmas(63,1)**2
24140 facww=comfac*facnor*taup*vint(2)*vint(219)
24141 facprt=1d0/((vint(204)**2-vint(215))*
24142 & (vint(209)**2-vint(216)))
24143 facpru=1d0/((vint(204)**2+2d0*vint(217))*
24144 & (vint(209)**2+2d0*vint(218)))
24145 CALL pywidt(kfres,sh,wdtp,wdte)
24146 hs=shr*wdtp(0)
24147 facbw=(1d0/paru(1))*vint(2)/((sh-sqmh)**2+hs**2)
24148 IF(abs(shr-pmas(kfres,1)).GT.parp(48)*pmas(kfres,2))
24149 & facbw=0d0
24150 DO 2020 i=mmin1,mmax1
24151 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 2020
24152 IF(isub.EQ.352.AND.iabs(i).GT.10) GOTO 2020
24153 kchwi=(1-2*mod(iabs(i),2))*isign(1,i)
24154 DO 2010 j=mmin2,mmax2
24155 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 2010
24156 IF(isub.EQ.352.AND.iabs(j).GT.10) GOTO 2010
24157 kchwj=(1-2*mod(iabs(j),2))*isign(1,j)
24158 kchh=kchwi+kchwj
24159 IF(iabs(kchh).NE.2) GOTO 2010
24160 faclr=vint(180+i)*vint(180+j)
24161 hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
24162 IF(i.EQ.j.AND.iabs(i).GT.10) THEN
24163 facprp=0.5d0*(facprt+facpru)**2
24164 ELSE
24165 facprp=facprt**2
24166 ENDIF
24167 nchn=nchn+1
24168 isig(nchn,1)=i
24169 isig(nchn,2)=j
24170 isig(nchn,3)=1
24171 sigh(nchn)=faclr*facww*facprp*facbw*hf
24172 2010 CONTINUE
24173 2020 CONTINUE
24174 ENDIF
24175
24176 ELSEIF(isub.LE.380) THEN
24177
24178 IF(isub.EQ.361) THEN
24179C...f + fbar -> W_L W_L, W_L pi_tech, pi_tech pi_tech
24180 faca=(sh**2*be34**2-(th-uh)**2)
24181 alprht=2.91d0*(3d0/parp(144))
24182 hp=(1d0/12d0)*aem*alprht*cab2*comfac*faca*3d0
24183 far=sqrt(aem/alprht)
24184 fao=far*qupd
24185 fzr=far*ct2w
24186 fzo=-fao*tanw
24187 sfar=far**2
24188 sfao=fao**2
24189 sfzr=fzr**2
24190 sfzo=fzo**2
24191 CALL pywidt(23,sh,wdtp,wdte)
24192 ssmz=cmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
24193 CALL pywidt(54,sh,wdtp,wdte)
24194 ssmr=cmplx(1d0-pmas(54,1)**2/sh,wdtp(0)/shr)
24195 CALL pywidt(56,sh,wdtp,wdte)
24196 ssmo=cmplx(1d0-pmas(56,1)**2/sh,wdtp(0)/shr)
24197 detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
24198 $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
24199 darho=(-far*sfzo+fao*fzo*fzr+far*ssmo*ssmz)/detd/sh
24200 dzrho=(-fzr*sfao+fao*fzo*far+fzr*ssmo)/detd/sh
24201
24202 DO 2040 i=mmina,mmaxa
24203 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2040
24204 ia=iabs(i)
24205 ei=kchg(iabs(i),1)/3d0
24206 ai=sign(1d0,ei+0.1d0)
24207 vi=ai-4d0*ei*xwv
24208 vali=0.25d0*(vi+ai)
24209 vari=0.25d0*(vi-ai)
24210 f2l=ei*darho+vali*dzrho/sqrt(xw*xw1)
24211 f2r=ei*darho+vari*dzrho/sqrt(xw*xw1)
24212 hi=abs(f2l)**2+abs(f2r)**2
24213 IF(ia.LE.10) hi=hi/3d0
24214 nchn=nchn+1
24215 isig(nchn,1)=i
24216 isig(nchn,2)=-i
24217 isig(nchn,3)=1
24218 IF(kfa.EQ.kfb) THEN
24219 sigh(nchn)=hi*hp*wids(kfa,1)
24220 ELSE
24221 sigh(nchn)=hi*hp*wids(kfa,2)*wids(kfb,3)
24222 nchn=nchn+1
24223 isig(nchn,1)=i
24224 isig(nchn,2)=-i
24225 isig(nchn,3)=2
24226 sigh(nchn)=hi*hp*wids(kfa,3)*wids(kfb,2)
24227 ENDIF
24228 2040 CONTINUE
24229
24230 ELSEIF(isub.EQ.364) THEN
24231C...f + fbar -> gamma pi_tech, gamma pi_tech', Z pi_tech, Z pi_tech',
24232C...W pi_tech
24233 vfac=(th**2+uh**2-2d0*sqm3*sqm4)/sqtv*sh
24234 afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)/sqta*sh
24235
24236 alprht=2.91d0*(3d0/parp(144))
24237 hp=(1d0/24d0)*aem**2*comfac*3d0
24238 far=sqrt(aem/alprht)
24239 fao=far*qupd
24240 fzr=far*ct2w
24241 fzo=-fao*tanw
24242 sfar=far**2
24243 sfao=fao**2
24244 sfzr=fzr**2
24245 sfzo=fzo**2
24246 CALL pywidt(23,sh,wdtp,wdte)
24247 ssmz=cmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
24248 CALL pywidt(54,sh,wdtp,wdte)
24249 ssmr=cmplx(1d0-pmas(54,1)**2/sh,wdtp(0)/shr)
24250 CALL pywidt(56,sh,wdtp,wdte)
24251 ssmo=cmplx(1d0-pmas(56,1)**2/sh,wdtp(0)/shr)
24252 detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
24253 $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
24254 darho=(-far*sfzo+fao*fzo*fzr+far*ssmo*ssmz)/detd/sh
24255 dzrho=(-fzr*sfao+fao*fzo*far+fzr*ssmo)/detd/sh
24256 daome=(-fao*sfzr+far*fzo*fzr+fao*ssmr*ssmz)/detd/sh
24257 dzome=(-fzo*sfar+far*fao*fzr+fzo*ssmr)/detd/sh
24258
24259 DO 2060 i=mmina,mmaxa
24260 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2060
24261 ia=iabs(i)
24262 ei=kchg(iabs(i),1)/3d0
24263 ai=sign(1d0,ei+0.1d0)
24264 vi=ai-4d0*ei*xwv
24265 vali=0.25d0*(vi+ai)
24266 vari=0.25d0*(vi-ai)
24267 f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*vrgp
24268 f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*vogp
24269 f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*vrgp
24270 f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*vogp
24271 hi=(abs(f2l)**2+abs(f2r)**2)*vfac
24272 f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*argp
24273 f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*aogp
24274 f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*argp
24275 f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*aogp
24276 hj=(abs(f2l)**2+abs(f2r)**2)*afac
24277 hi=hi+hj
24278 IF(ia.LE.10) hi=hi/3d0
24279 nchn=nchn+1
24280 isig(nchn,1)=i
24281 isig(nchn,2)=-i
24282 isig(nchn,3)=1
24283 IF(isubsv.NE.368) THEN
24284 sigh(nchn)=hi*hp*wids(kfa,2)*wids(kfb,2)
24285 ELSE
24286 sigh(nchn)=hi*hp*wids(kfa,2)*wids(kfb,3)
24287 nchn=nchn+1
24288 isig(nchn,1)=i
24289 isig(nchn,2)=-i
24290 isig(nchn,3)=2
24291 sigh(nchn)=hi*hp*wids(kfa,3)*wids(kfb,2)
24292 ENDIF
24293 2060 CONTINUE
24294
24295 ELSEIF(isub.EQ.370) THEN
24296C...f + fbar' -> W_L Z_L, W_L pi_tech, Z_L pi_tech, pi_tech pi_tech
24297
24298 faca=(sh**2*be34**2-(th-uh)**2)
24299 alprht=2.91d0*(3d0/parp(144))
24300 hp=(1d0/24d0)*aem*alprht*cab2*comfac*faca*3d0/xw
24301
24302 fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
24303 CALL pywidt(24,sh,wdtp,wdte)
24304 ssmz=cmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
24305 CALL pywidt(55,sh,wdtp,wdte)
24306 ssmr=cmplx(1d0-pmas(55,1)**2/sh,wdtp(0)/shr)
24307
24308 detd=ssmz*ssmr-cmplx(fwr**2,0d0)
24309 hp=hp*fwr**2/abs(detd)**2/sh**2
24310
24311 DO 2080 i=mmin1,mmax1
24312 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 2080
24313 ia=iabs(i)
24314 DO 2070 j=mmin2,mmax2
24315 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 2070
24316 ja=iabs(j)
24317 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 2070
24318 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
24319 & GOTO 2070
24320 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
24321 hi=hp
24322 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
24323 nchn=nchn+1
24324 isig(nchn,1)=i
24325 isig(nchn,2)=j
24326 isig(nchn,3)=1
24327 sigh(nchn)=hi*wids(kfa,(5-kchr)/2)*wids(kfb,2)
24328 2070 CONTINUE
24329 2080 CONTINUE
24330
24331 ELSEIF(isub.EQ.374) THEN
24332C...f + fbar' -> G pi_tech
24333 vfac=(th**2+uh**2-2d0*sqm3*sqm4)/sqtv*vrgp**2
24334 afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)/sqta*argp**2
24335
24336 alprht=2.91d0*(3d0/parp(144))
24337 hp=(1d0/48d0)*aem**2/xw*comfac*3d0*(vfac+afac)*sh
24338
24339 fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
24340 CALL pywidt(24,sh,wdtp,wdte)
24341 ssmz=cmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
24342 CALL pywidt(55,sh,wdtp,wdte)
24343 ssmr=cmplx(1d0-pmas(55,1)**2/sh,wdtp(0)/shr)
24344
24345 detd=ssmz*ssmr-cmplx(fwr**2,0d0)
24346 hp=hp*fwr**2/abs(detd)**2/sh**2
24347
24348 DO 2100 i=mmin1,mmax1
24349 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 2100
24350 ia=iabs(i)
24351 DO 2090 j=mmin2,mmax2
24352 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 2090
24353 ja=iabs(j)
24354 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 2090
24355 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
24356 & GOTO 2090
24357 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
24358 hi=hp
24359 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
24360 nchn=nchn+1
24361 isig(nchn,1)=i
24362 isig(nchn,2)=j
24363 isig(nchn,3)=1
24364 sigh(nchn)=hi*wids(kfa,(5-kchr)/2)*wids(kfb,2)
24365 2090 CONTINUE
24366 2100 CONTINUE
24367
24368 ENDIF
24369 ENDIF
24370
24371C...Multiply with parton distributions
24372 IF(isub.LE.90.OR.isub.GE.96) THEN
24373 DO 2200 ichn=1,nchn
24374 IF(mint(45).GE.2) THEN
24375 kfl1=isig(ichn,1)
24376 sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)
24377 ENDIF
24378 IF(mint(46).GE.2) THEN
24379 kfl2=isig(ichn,2)
24380 sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)
24381 ENDIF
24382 sigs=sigs+sigh(ichn)
24383 2200 CONTINUE
24384 ENDIF
24385
24386 RETURN
24387 END
24388
24389C*********************************************************************
24390
24391C...PYPDFU
24392C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
24393C...parton distributions according to a few different parametrizations.
24394C...Note that what is coded is x times the probability distribution,
24395C...i.e. xq(x,Q2) etc.
24396
24397 SUBROUTINE pypdfu(KF,X,Q2,XPQ)
24398
24399C...Double precision and integer declarations.
24400 IMPLICIT DOUBLE PRECISION(a-h, o-z)
24401 IMPLICIT INTEGER(I-N)
24402 INTEGER PYK,PYCHGE,PYCOMP
24403C...Commonblocks.
24404 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24405 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24406 common/pypars/mstp(200),parp(200),msti(200),pari(200)
24407 common/pyint1/mint(400),vint(400)
24408 common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
24409 &xpdir(-6:6)
24410 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint8/
24411C...Local arrays.
24412 dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),
24413 &xppi(-6:6),xppr(-6:6)
24414
24415C...Interface to PDFLIB.
24416 common/w50513/xmin,xmax,q2min,q2max
24417 SAVE /w50513/
24418 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
24419 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
24420 CHARACTER*20 PARM(20)
24421 DATA VALUE/20*0d0/,parm/20*' '/
24422
24423C...Data related to Schuler-Sjostrand photon distributions.
24424 DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/
24425
24426C...Reset parton distributions.
24427 mint(92)=0
24428 DO 100 kfl=-25,25
24429 xpq(kfl)=0d0
24430 100 CONTINUE
24431
24432C...Check x and particle species.
24433 IF(x.LE.0d0.OR.x.GE.1d0) THEN
24434 WRITE(mstu(11),5000) x
24435 RETURN
24436 ENDIF
24437 kfa=iabs(kf)
24438 IF(kfa.NE.11.AND.kfa.NE.13.AND.kfa.NE.15.AND.kfa.NE.22.AND.
24439 &kfa.NE.211.AND.kfa.NE.2112.AND.kfa.NE.2212.AND.kfa.NE.3122.AND.
24440 &kfa.NE.3112.AND.kfa.NE.3212.AND.kfa.NE.3222.AND.kfa.NE.3312.AND.
24441 &kfa.NE.3322.AND.kfa.NE.3334.AND.kfa.NE.111) THEN
24442 WRITE(mstu(11),5100) kf
24443 RETURN
24444 ENDIF
24445
24446C...Electron (or muon or tau) parton distribution call.
24447 IF(kfa.EQ.11.OR.kfa.EQ.13.OR.kfa.EQ.15) THEN
24448 CALL pypdel(kfa,x,q2,xpel)
24449 DO 110 kfl=-25,25
24450 xpq(kfl)=xpel(kfl)
24451 110 CONTINUE
24452
24453C...Photon parton distribution call (VDM+anomalous).
24454 ELSEIF(kfa.EQ.22.AND.mint(109).LE.1) THEN
24455 IF(mstp(56).EQ.1.AND.mstp(55).EQ.1) THEN
24456 CALL pypdga(x,q2,xpga)
24457 DO 120 kfl=-6,6
24458 xpq(kfl)=xpga(kfl)
24459 120 CONTINUE
24460 ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.5.AND.mstp(55).LE.8) THEN
24461 q2mx=q2
24462 p2mx=0.36d0
24463 IF(mstp(55).GE.7) p2mx=4.0d0
24464 IF(mstp(57).EQ.0) q2mx=p2mx
24465 p2=0d0
24466 IF(vint(120).LT.0d0) p2=vint(120)**2
24467 CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gam,xpga)
24468 DO 130 kfl=-6,6
24469 xpq(kfl)=xpga(kfl)
24470 130 CONTINUE
24471 vint(231)=p2mx
24472 ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.9.AND.mstp(55).LE.12) THEN
24473 q2mx=q2
24474 p2mx=0.36d0
24475 IF(mstp(55).GE.11) p2mx=4.0d0
24476 IF(mstp(57).EQ.0) q2mx=p2mx
24477 p2=0d0
24478 IF(vint(120).LT.0d0) p2=vint(120)**2
24479 CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gam,xpga)
24480 DO 140 kfl=-6,6
24481 xpq(kfl)=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
24482 140 CONTINUE
24483 vint(231)=p2mx
24484 ELSEIF(mstp(56).EQ.2) THEN
24485C...Call PDFLIB parton distributions.
24486 parm(1)='NPTYPE'
24487 value(1)=3
24488 parm(2)='NGROUP'
24489 value(2)=mstp(55)/1000
24490 parm(3)='NSET'
24491 value(3)=mod(mstp(55),1000)
24492 IF(mint(93).NE.3000000+mstp(55)) THEN
24493 CALL pdfset(parm,VALUE)
24494 mint(93)=3000000+mstp(55)
24495 ENDIF
24496 xx=x
24497 qq2=max(0d0,q2min,q2)
24498 IF(mstp(57).EQ.0) qq2=q2min
24499 p2=0d0
24500 IF(vint(120).LT.0d0) p2=vint(120)**2
24501 ip2=mstp(60)
24502 IF(mstp(55).EQ.5004) THEN
24503 IF(5d0*p2.LT.qq2.AND.
24504 & qq2.GT.0.6d0.AND.qq2.LT.5d4.AND.
24505 & p2.GE.0d0.AND.p2.LT.10d0.AND.
24506 & xx.GT.1d-4.AND.xx.LT.1d0) THEN
24507 CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
24508 & bot,top,glu)
24509 ELSE
24510 upv=0d0
24511 dnv=0d0
24512 usea=0d0
24513 dsea=0d0
24514 str=0d0
24515 chm=0d0
24516 bot=0d0
24517 top=0d0
24518 glu=0d0
24519 ENDIF
24520 ELSE
24521 IF(p2.LT.qq2) THEN
24522 CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
24523 & bot,top,glu)
24524 ELSE
24525 upv=0d0
24526 dnv=0d0
24527 usea=0d0
24528 dsea=0d0
24529 str=0d0
24530 chm=0d0
24531 bot=0d0
24532 top=0d0
24533 glu=0d0
24534 ENDIF
24535 ENDIF
24536 vint(231)=q2min
24537 xpq(0)=glu
24538 xpq(1)=dnv
24539 xpq(-1)=dnv
24540 xpq(2)=upv
24541 xpq(-2)=upv
24542 xpq(3)=str
24543 xpq(-3)=str
24544 xpq(4)=chm
24545 xpq(-4)=chm
24546 xpq(5)=bot
24547 xpq(-5)=bot
24548 xpq(6)=top
24549 xpq(-6)=top
24550 ELSE
24551 WRITE(mstu(11),5200) kf,mstp(56),mstp(55)
24552 ENDIF
24553
24554C...Pion/gammaVDM parton distribution call.
24555 ELSEIF(kfa.EQ.211.OR.kfa.EQ.111.OR.(kfa.EQ.22.AND.
24556 & mint(109).EQ.2)) THEN
24557 IF(kfa.EQ.22.AND.mstp(56).EQ.1.AND.mstp(55).GE.5.AND.
24558 & mstp(55).LE.12) THEN
24559 iset=1+mod(mstp(55)-1,4)
24560 q2mx=q2
24561 p2mx=0.36d0
24562 IF(iset.GE.3) p2mx=4.0d0
24563 IF(mstp(57).EQ.0) q2mx=p2mx
24564 p2=0d0
24565 IF(vint(120).LT.0d0) p2=vint(120)**2
24566 CALL pyggam(iset,x,q2mx,p2,mstp(60),f2gam,xpga)
24567 DO 150 kfl=-6,6
24568 xpq(kfl)=xpvmd(kfl)
24569 150 CONTINUE
24570 vint(231)=p2mx
24571 ELSEIF(mstp(54).EQ.1.AND.mstp(53).GE.1.AND.mstp(53).LE.3) THEN
24572 CALL pypdpi(x,q2,xppi)
24573 DO 160 kfl=-6,6
24574 xpq(kfl)=xppi(kfl)
24575 160 CONTINUE
24576 ELSEIF(mstp(54).EQ.2) THEN
24577C...Call PDFLIB parton distributions.
24578 parm(1)='NPTYPE'
24579 value(1)=2
24580 parm(2)='NGROUP'
24581 value(2)=mstp(53)/1000
24582 parm(3)='NSET'
24583 value(3)=mod(mstp(53),1000)
24584 IF(mint(93).NE.2000000+mstp(53)) THEN
24585 CALL pdfset(parm,VALUE)
24586 mint(93)=2000000+mstp(53)
24587 ENDIF
24588 xx=x
24589 qq=sqrt(max(0d0,q2min,q2))
24590 IF(mstp(57).EQ.0) qq=sqrt(q2min)
24591 CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
24592 vint(231)=q2min
24593 xpq(0)=glu
24594 xpq(1)=dsea
24595 xpq(-1)=upv+dsea
24596 xpq(2)=upv+usea
24597 xpq(-2)=usea
24598 xpq(3)=str
24599 xpq(-3)=str
24600 xpq(4)=chm
24601 xpq(-4)=chm
24602 xpq(5)=bot
24603 xpq(-5)=bot
24604 xpq(6)=top
24605 xpq(-6)=top
24606 ELSE
24607 WRITE(mstu(11),5200) kf,mstp(54),mstp(53)
24608 ENDIF
24609
24610C...Anomalous photon parton distribution call.
24611 ELSEIF(kfa.EQ.22.AND.mint(109).EQ.3) THEN
24612 q2mx=q2
24613 p2mx=parp(15)**2
24614 IF(mstp(56).EQ.1.AND.mstp(55).LE.8) THEN
24615 IF(mstp(55).EQ.5.OR.mstp(55).EQ.6) p2mx=0.36d0
24616 IF(mstp(55).EQ.7.OR.mstp(55).EQ.8) p2mx=4.0d0
24617 IF(mstp(57).EQ.0) q2mx=p2mx
24618 p2=0d0
24619 IF(vint(120).LT.0d0) p2=vint(120)**2
24620 CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gm,xpga)
24621 DO 170 kfl=-6,6
24622 xpq(kfl)=xpanl(kfl)+xpanh(kfl)
24623 170 CONTINUE
24624 vint(231)=p2mx
24625 ELSEIF(mstp(56).EQ.1) THEN
24626 IF(mstp(55).EQ.9.OR.mstp(55).EQ.10) p2mx=0.36d0
24627 IF(mstp(55).EQ.11.OR.mstp(55).EQ.12) p2mx=4.0d0
24628 IF(mstp(57).EQ.0) q2mx=p2mx
24629 p2=0d0
24630 IF(vint(120).LT.0d0) p2=vint(120)**2
24631 CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gm,xpga)
24632 DO 180 kfl=-6,6
24633 xpq(kfl)=max(0d0,xpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
24634 180 CONTINUE
24635 vint(231)=p2mx
24636 ELSEIF(mstp(56).EQ.2) THEN
24637 IF(mstp(57).EQ.0) q2mx=p2mx
24638 CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)
24639 DO 190 kfl=-6,6
24640 xpq(kfl)=xpga(kfl)
24641 190 CONTINUE
24642 vint(231)=p2mx
24643 ELSEIF(mstp(55).GE.1.AND.mstp(55).LE.5) THEN
24644 IF(mstp(57).EQ.0) q2mx=p2mx
24645 CALL pygvmd(0,mstp(55),x,q2mx,p2mx,parp(1),xpga,vxpga)
24646 DO 200 kfl=-6,6
24647 xpq(kfl)=xpga(kfl)
24648 200 CONTINUE
24649 vint(231)=p2mx
24650 ELSE
24651 210 rkf=11d0*pyr(0)
24652 kfr=1
24653 IF(rkf.GT.1d0) kfr=2
24654 IF(rkf.GT.5d0) kfr=3
24655 IF(rkf.GT.6d0) kfr=4
24656 IF(rkf.GT.10d0) kfr=5
24657 IF(kfr.EQ.4.AND.q2.LT.pmcga**2) GOTO 210
24658 IF(kfr.EQ.5.AND.q2.LT.pmbga**2) GOTO 210
24659 IF(mstp(57).EQ.0) q2mx=p2mx
24660 CALL pygvmd(0,kfr,x,q2mx,p2mx,parp(1),xpga,vxpga)
24661 DO 220 kfl=-6,6
24662 xpq(kfl)=xpga(kfl)
24663 220 CONTINUE
24664 vint(231)=p2mx
24665 ENDIF
24666
24667C...Proton parton distribution call.
24668 ELSE
24669 IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
24670 CALL pypdpr(x,q2,xppr)
24671 DO 230 kfl=-6,6
24672 xpq(kfl)=xppr(kfl)
24673 230 CONTINUE
24674 ELSEIF(mstp(52).EQ.2) THEN
24675C...Call PDFLIB parton distributions.
24676 parm(1)='NPTYPE'
24677 value(1)=1
24678 parm(2)='NGROUP'
24679 value(2)=mstp(51)/1000
24680 parm(3)='NSET'
24681 value(3)=mod(mstp(51),1000)
24682 IF(mint(93).NE.1000000+mstp(51)) THEN
24683 CALL pdfset(parm,VALUE)
24684 mint(93)=1000000+mstp(51)
24685 ENDIF
24686 xx=x
24687 qq=sqrt(max(0d0,q2min,q2))
24688 IF(mstp(57).EQ.0) qq=sqrt(q2min)
24689 CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
24690 vint(231)=q2min
24691 xpq(0)=glu
24692 xpq(1)=dnv+dsea
24693 xpq(-1)=dsea
24694 xpq(2)=upv+usea
24695 xpq(-2)=usea
24696 xpq(3)=str
24697 xpq(-3)=str
24698 xpq(4)=chm
24699 xpq(-4)=chm
24700 xpq(5)=bot
24701 xpq(-5)=bot
24702 xpq(6)=top
24703 xpq(-6)=top
24704 ELSE
24705 WRITE(mstu(11),5200) kf,mstp(52),mstp(51)
24706 ENDIF
24707 ENDIF
24708
24709C...Isospin average for pi0/gammaVDM.
24710 IF(kfa.EQ.111.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
24711 IF(kfa.EQ.22.AND.mstp(55).GE.5.AND.mstp(55).LE.12) THEN
24712 xpv=xpq(2)-xpq(1)
24713 xpq(2)=xpq(1)
24714 xpq(-2)=xpq(-1)
24715 ELSE
24716 xps=0.5d0*(xpq(1)+xpq(-2))
24717 xpv=0.5d0*(xpq(2)+xpq(-1))-xps
24718 xpq(2)=xps
24719 xpq(-1)=xps
24720 ENDIF
24721 IF(kfa.EQ.22.AND.mint(105).LE.223) THEN
24722 xpq(1)=xpq(1)+0.2d0*xpv
24723 xpq(-1)=xpq(-1)+0.2d0*xpv
24724 xpq(2)=xpq(2)+0.8d0*xpv
24725 xpq(-2)=xpq(-2)+0.8d0*xpv
24726 ELSEIF(kfa.EQ.22.AND.mint(105).EQ.333) THEN
24727 xpq(3)=xpq(3)+xpv
24728 xpq(-3)=xpq(-3)+xpv
24729 ELSEIF(kfa.EQ.22.AND.mint(105).EQ.443) THEN
24730 xpq(4)=xpq(4)+xpv
24731 xpq(-4)=xpq(-4)+xpv
24732 IF(mstp(55).GE.9) THEN
24733 DO 240 kfl=-6,6
24734 xpq(kfl)=0d0
24735 240 CONTINUE
24736 ENDIF
24737 ELSE
24738 xpq(1)=xpq(1)+0.5d0*xpv
24739 xpq(-1)=xpq(-1)+0.5d0*xpv
24740 xpq(2)=xpq(2)+0.5d0*xpv
24741 xpq(-2)=xpq(-2)+0.5d0*xpv
24742 ENDIF
24743
24744C...Rescale for gammaVDM by effective gamma -> rho coupling.
24745C+++Do not rescale?
24746 IF(kfa.EQ.22.AND.mint(109).EQ.2.AND..NOT.(mstp(56).EQ.1
24747 & .AND.mstp(55).GE.5.AND.mstp(55).LE.12)) THEN
24748 DO 250 kfl=-6,6
24749 xpq(kfl)=vint(281)*xpq(kfl)
24750 250 CONTINUE
24751 vint(232)=vint(281)*xpv
24752 ENDIF
24753
24754C...Isospin conjugation for neutron.
24755 ELSEIF(kfa.EQ.2112) THEN
24756 xps=xpq(1)
24757 xpq(1)=xpq(2)
24758 xpq(2)=xps
24759 xps=xpq(-1)
24760 xpq(-1)=xpq(-2)
24761 xpq(-2)=xps
24762
24763C...Simple recipes for hyperon (average valence parton distribution).
24764 ELSEIF(kfa.EQ.3122.OR.kfa.EQ.3112.OR.kfa.EQ.3212.OR.kfa.EQ.3222
24765 & .OR.kfa.EQ.3312.OR.kfa.EQ.3322.OR.kfa.EQ.3334) THEN
24766 xpval=(xpq(1)+xpq(2)-xpq(-1)-xpq(-2))/3d0
24767 xpsea=0.5d0*(xpq(-1)+xpq(-2))
24768 xpq(1)=xpsea
24769 xpq(2)=xpsea
24770 xpq(-1)=xpsea
24771 xpq(-2)=xpsea
24772 xpq(kfa/1000)=xpq(kfa/1000)+xpval
24773 xpq(mod(kfa/100,10))=xpq(mod(kfa/100,10))+xpval
24774 xpq(mod(kfa/10,10))=xpq(mod(kfa/10,10))+xpval
24775 ENDIF
24776
24777C...Charge conjugation for antiparticle.
24778 IF(kf.LT.0) THEN
24779 DO 260 kfl=1,25
24780 IF(kfl.EQ.21.OR.kfl.EQ.22.OR.kfl.EQ.23.OR.kfl.EQ.25) GOTO 260
24781 xps=xpq(kfl)
24782 xpq(kfl)=xpq(-kfl)
24783 xpq(-kfl)=xps
24784 260 CONTINUE
24785 ENDIF
24786
24787C...Allow gluon also in position 21.
24788 xpq(21)=xpq(0)
24789
24790C...Check positivity and reset above maximum allowed flavour.
24791 DO 270 kfl=-25,25
24792 xpq(kfl)=max(0d0,xpq(kfl))
24793 IF(iabs(kfl).GT.mstp(58).AND.iabs(kfl).LE.8) xpq(kfl)=0d0
24794 270 CONTINUE
24795
24796C...Formats for error printouts.
24797 5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
24798 5100 FORMAT(' Error: illegal particle code for parton distribution;',
24799 &' KF =',i5)
24800 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
24801 &3i5)
24802
24803 RETURN
24804 END
24805
24806C*********************************************************************
24807
24808C...PYPDFL
24809C...Gives proton parton distribution at small x and/or Q^2 according to
24810C...correct limiting behaviour.
24811
24812 SUBROUTINE pypdfl(KF,X,Q2,XPQ)
24813
24814C...Double precision and integer declarations.
24815 IMPLICIT DOUBLE PRECISION(a-h, o-z)
24816 IMPLICIT INTEGER(I-N)
24817 INTEGER PYK,PYCHGE,PYCOMP
24818C...Commonblocks.
24819 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24820 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24821 common/pypars/mstp(200),parp(200),msti(200),pari(200)
24822 common/pyint1/mint(400),vint(400)
24823 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
24824C...Local arrays.
24825 dimension xpq(-25:25),xpa(-25:25),xpb(-25:25),wtsb(-3:3)
24826 DATA rmr/0.92d0/,rmp/0.38d0/,wtsb/0.5d0,1d0,1d0,5d0,1d0,1d0,0.5d0/
24827
24828C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
24829 mint(92)=0
24830 kfa=iabs(kf)
24831 iacc=0
24832 IF((kfa.EQ.2212.OR.kfa.EQ.2112).AND.mstp(57).GE.2) iacc=1
24833 IF(kfa.EQ.211.AND.mstp(57).GE.3) iacc=1
24834 IF(kfa.EQ.22.AND.mint(109).EQ.2.AND.mstp(57).GE.3) iacc=1
24835 IF(iacc.EQ.0) THEN
24836 CALL pypdfu(kf,x,q2,xpq)
24837 RETURN
24838 ENDIF
24839
24840C...Reset. Check x.
24841 DO 100 kfl=-25,25
24842 xpq(kfl)=0d0
24843 100 CONTINUE
24844 IF(x.LE.0d0.OR.x.GE.1d0) THEN
24845 WRITE(mstu(11),5000) x
24846 RETURN
24847 ENDIF
24848
24849C...Define valence content.
24850 kfc=kf
24851 nv1=2
24852 nv2=1
24853 IF(kf.EQ.2212) THEN
24854 kfv1=2
24855 kfv2=1
24856 ELSEIF(kf.EQ.-2212) THEN
24857 kfv1=-2
24858 kfv2=-1
24859 ELSEIF(kf.EQ.2112) THEN
24860 kfv1=1
24861 kfv2=2
24862 ELSEIF(kf.EQ.-2112) THEN
24863 kfv1=-1
24864 kfv2=-2
24865 ELSEIF(kf.EQ.211) THEN
24866 nv1=1
24867 kfv1=2
24868 kfv2=-1
24869 ELSEIF(kf.EQ.-211) THEN
24870 nv1=1
24871 kfv1=-2
24872 kfv2=1
24873 ELSEIF(mint(105).LE.223) THEN
24874 kfv1=1
24875 wtv1=0.2d0
24876 kfv2=2
24877 wtv2=0.8d0
24878 ELSEIF(mint(105).EQ.333) THEN
24879 kfv1=3
24880 wtv1=1.0d0
24881 kfv2=1
24882 wtv2=0.0d0
24883 ELSEIF(mint(105).EQ.443) THEN
24884 kfv1=4
24885 wtv1=1.0d0
24886 kfv2=1
24887 wtv2=0.0d0
24888 ENDIF
24889
24890C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
24891 CALL pypdfu(kfc,x,q2,xpa)
24892 q2mn=max(3d0,vint(231))
24893 q2b=2d0+0.052d0**2*exp(3.56d0*sqrt(max(0d0,-log(3d0*x))))
24894 xmn=exp(-(log((q2mn-2d0)/0.052d0**2)/3.56d0)**2)/3d0
24895
24896C...Large Q2 and large x: naive call is enough.
24897 IF(q2.GT.q2mn.AND.q2.GT.q2b) THEN
24898 DO 110 kfl=-25,25
24899 xpq(kfl)=xpa(kfl)
24900 110 CONTINUE
24901 mint(92)=1
24902
24903C...Small Q2 and large x: dampen boundary value.
24904 ELSEIF(x.GT.xmn) THEN
24905
24906C...Evaluate at boundary and define dampening factors.
24907 CALL pypdfu(kfc,x,q2mn,xpa)
24908 fv=(q2*(q2mn+rmr)/(q2mn*(q2+rmr)))**(0.55d0*(1d0-x)/(1d0-xmn))
24909 fs=(q2*(q2mn+rmp)/(q2mn*(q2+rmp)))**1.08d0
24910
24911C...Separate valence and sea parts of parton distribution.
24912 IF(kfa.NE.22) THEN
24913 xfv1=xpa(kfv1)-xpa(-kfv1)
24914 xpa(kfv1)=xpa(-kfv1)
24915 xfv2=xpa(kfv2)-xpa(-kfv2)
24916 xpa(kfv2)=xpa(-kfv2)
24917 ELSE
24918 xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
24919 xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
24920 xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
24921 xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
24922 ENDIF
24923
24924C...Dampen valence and sea separately. Put back together.
24925 DO 120 kfl=-25,25
24926 xpq(kfl)=fs*xpa(kfl)
24927 120 CONTINUE
24928 IF(kfa.NE.22) THEN
24929 xpq(kfv1)=xpq(kfv1)+fv*xfv1
24930 xpq(kfv2)=xpq(kfv2)+fv*xfv2
24931 ELSE
24932 xpq(kfv1)=xpq(kfv1)+fv*wtv1*vint(232)
24933 xpq(-kfv1)=xpq(-kfv1)+fv*wtv1*vint(232)
24934 xpq(kfv2)=xpq(kfv2)+fv*wtv2*vint(232)
24935 xpq(-kfv2)=xpq(-kfv2)+fv*wtv2*vint(232)
24936 ENDIF
24937 mint(92)=2
24938
24939C...Large Q2 and small x: interpolate behaviour.
24940 ELSEIF(q2.GT.q2mn) THEN
24941
24942C...Evaluate at extremes and define coefficients for interpolation.
24943 CALL pypdfu(kfc,xmn,q2mn,xpa)
24944 vi232a=vint(232)
24945 CALL pypdfu(kfc,x,q2b,xpb)
24946 vi232b=vint(232)
24947 fla=log(q2b/q2)/log(q2b/q2mn)
24948 fva=(x/xmn)**0.45d0*fla
24949 fsa=(x/xmn)**(-0.08d0)*fla
24950 fb=1d0-fla
24951
24952C...Separate valence and sea parts of parton distribution.
24953 IF(kfa.NE.22) THEN
24954 xfva1=xpa(kfv1)-xpa(-kfv1)
24955 xpa(kfv1)=xpa(-kfv1)
24956 xfva2=xpa(kfv2)-xpa(-kfv2)
24957 xpa(kfv2)=xpa(-kfv2)
24958 xfvb1=xpb(kfv1)-xpb(-kfv1)
24959 xpb(kfv1)=xpb(-kfv1)
24960 xfvb2=xpb(kfv2)-xpb(-kfv2)
24961 xpb(kfv2)=xpb(-kfv2)
24962 ELSE
24963 xpa(kfv1)=xpa(kfv1)-wtv1*vi232a
24964 xpa(-kfv1)=xpa(-kfv1)-wtv1*vi232a
24965 xpa(kfv2)=xpa(kfv2)-wtv2*vi232a
24966 xpa(-kfv2)=xpa(-kfv2)-wtv2*vi232a
24967 xpb(kfv1)=xpb(kfv1)-wtv1*vi232b
24968 xpb(-kfv1)=xpb(-kfv1)-wtv1*vi232b
24969 xpb(kfv2)=xpb(kfv2)-wtv2*vi232b
24970 xpb(-kfv2)=xpb(-kfv2)-wtv2*vi232b
24971 ENDIF
24972
24973C...Interpolate for valence and sea. Put back together.
24974 DO 130 kfl=-25,25
24975 xpq(kfl)=fsa*xpa(kfl)+fb*xpb(kfl)
24976 130 CONTINUE
24977 IF(kfa.NE.22) THEN
24978 xpq(kfv1)=xpq(kfv1)+(fva*xfva1+fb*xfvb1)
24979 xpq(kfv2)=xpq(kfv2)+(fva*xfva2+fb*xfvb2)
24980 ELSE
24981 xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vi232a+fb*vi232b)
24982 xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vi232a+fb*vi232b)
24983 xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vi232a+fb*vi232b)
24984 xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vi232a+fb*vi232b)
24985 ENDIF
24986 mint(92)=3
24987
24988C...Small Q2 and small x: dampen boundary value and add term.
24989 ELSE
24990
24991C...Evaluate at boundary and define dampening factors.
24992 CALL pypdfu(kfc,xmn,q2mn,xpa)
24993 fb=(xmn-x)*(q2mn-q2)/(xmn*q2mn)
24994 fa=1d0-fb
24995 fvc=(x/xmn)**0.45d0*(q2/(q2+rmr))**0.55d0
24996 fva=fvc*fa*((q2mn+rmr)/q2mn)**0.55d0
24997 fvb=fvc*fb*1.10d0*xmn**0.45d0*0.11d0
24998 fsc=(x/xmn)**(-0.08d0)*(q2/(q2+rmp))**1.08d0
24999 fsa=fsc*fa*((q2mn+rmp)/q2mn)**1.08d0
25000 fsb=fsc*fb*0.21d0*xmn**(-0.08d0)*0.21d0
25001
25002C...Separate valence and sea parts of parton distribution.
25003 IF(kfa.NE.22) THEN
25004 xfv1=xpa(kfv1)-xpa(-kfv1)
25005 xpa(kfv1)=xpa(-kfv1)
25006 xfv2=xpa(kfv2)-xpa(-kfv2)
25007 xpa(kfv2)=xpa(-kfv2)
25008 ELSE
25009 xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
25010 xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
25011 xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
25012 xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
25013 ENDIF
25014
25015C...Dampen valence and sea separately. Add constant terms.
25016C...Put back together.
25017 DO 140 kfl=-25,25
25018 xpq(kfl)=fsa*xpa(kfl)
25019 140 CONTINUE
25020 IF(kfa.NE.22) THEN
25021 DO 150 kfl=-3,3
25022 xpq(kfl)=xpq(kfl)+fsb*wtsb(kfl)
25023 150 CONTINUE
25024 xpq(kfv1)=xpq(kfv1)+(fva*xfv1+fvb*nv1)
25025 xpq(kfv2)=xpq(kfv2)+(fva*xfv2+fvb*nv2)
25026 ELSE
25027 DO 160 kfl=-3,3
25028 xpq(kfl)=xpq(kfl)+vint(281)*fsb*wtsb(kfl)
25029 160 CONTINUE
25030 xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
25031 xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
25032 xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
25033 xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
25034 ENDIF
25035 xpq(21)=xpq(0)
25036 mint(92)=4
25037 ENDIF
25038
25039C...Format for error printout.
25040 5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
25041
25042 RETURN
25043 END
25044
25045C*********************************************************************
25046
25047C...PYPDEL
25048C...Gives electron (or muon, or tau) parton distribution.
25049
25050 SUBROUTINE pypdel(KFA,X,Q2,XPEL)
25051
25052C...Double precision and integer declarations.
25053 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25054 IMPLICIT INTEGER(I-N)
25055 INTEGER PYK,PYCHGE,PYCOMP
25056C...Commonblocks.
25057 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25058 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
25059 common/pypars/mstp(200),parp(200),msti(200),pari(200)
25060 common/pyint1/mint(400),vint(400)
25061 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
25062C...Local arrays.
25063 dimension xpel(-25:25),xpga(-6:6),sxp(0:6)
25064
25065C...Interface to PDFLIB.
25066 common/w50513/xmin,xmax,q2min,q2max
25067 SAVE /w50513/
25068 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
25069 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
25070 CHARACTER*20 PARM(20)
25071 DATA VALUE/20*0d0/,parm/20*' '/
25072
25073C...Some common constants.
25074 DO 100 kfl=-25,25
25075 xpel(kfl)=0d0
25076 100 CONTINUE
25077 aem=paru(101)
25078 pme=pmas(11,1)
25079 IF(kfa.EQ.13) pme=pmas(13,1)
25080 IF(kfa.EQ.15) pme=pmas(15,1)
25081 xl=log(max(1d-10,x))
25082 x1l=log(max(1d-10,1d0-x))
25083 hle=log(max(3d0,q2/pme**2))
25084 hbe2=(aem/paru(1))*(hle-1d0)
25085
25086C...Electron inside electron, see R. Kleiss et al., in Z physics at
25087C...LEP 1, CERN 89-08, p. 34
25088 IF(mstp(59).LE.1) THEN
25089 hde=1d0+(aem/paru(1))*(1.5d0*hle+1.289868d0)+(aem/paru(1))**2*
25090 & (-2.164868d0*hle**2+9.840808d0*hle-10.130464d0)
25091 hee=hbe2*(1d0-x)**(hbe2-1d0)*sqrt(max(0d0,hde))-
25092 & 0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*(-4d0*x1l+3d0*xl)-
25093 & 4d0*xl/(1d0-x)-5d0-x)
25094 ELSE
25095 hee=hbe2*(1d0-x)**(hbe2-1d0)*exp(0.172784d0*hbe2)/
25096 & pygamm(1d0+hbe2)-0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*
25097 & (-4d0*x1l+3d0*xl)-4d0*xl/(1d0-x)-5d0-x)
25098 ENDIF
25099C...Zero distribution for very large x and rescale it for intermediate.
25100 IF(x.GT.1d0-1d-10) THEN
25101 hee=0d0
25102 ELSEIF(x.GT.1d0-1d-7) THEN
25103 hee=hee*1000d0**hbe2/(1000d0**hbe2-1d0)
25104 ENDIF
25105 xpel(kfa)=x*hee
25106
25107C...Photon and (transverse) W- inside electron.
25108 aemp=pyalem(pme*sqrt(max(0d0,q2)))/paru(2)
25109 IF(mstp(13).LE.1) THEN
25110 hlg=hle
25111 ELSE
25112 hlg=log(max(1d0,(parp(13)/pme**2)*(1d0-x)/x**2))
25113 ENDIF
25114 xpel(22)=aemp*hlg*(1d0+(1d0-x)**2)
25115 hlw=log(1d0+q2/pmas(24,1)**2)/(4d0*paru(102))
25116 xpel(-24)=aemp*hlw*(1d0+(1d0-x)**2)
25117
25118C...Electron or positron inside photon inside electron.
25119 IF(kfa.EQ.11.AND.mstp(12).EQ.1) THEN
25120 xfsea=0.5d0*(aemp*(hle-1d0))**2*(4d0/3d0+x-x**2-4d0*x**3/3d0+
25121 & 2d0*x*(1d0+x)*xl)
25122 xpel(11)=xpel(11)+xfsea
25123 xpel(-11)=xfsea
25124
25125C...Initialize PDFLIB photon parton distributions.
25126 IF(mstp(56).EQ.2) THEN
25127 parm(1)='NPTYPE'
25128 value(1)=3
25129 parm(2)='NGROUP'
25130 value(2)=mstp(55)/1000
25131 parm(3)='NSET'
25132 value(3)=mod(mstp(55),1000)
25133 IF(mint(93).NE.3000000+mstp(55)) THEN
25134 CALL pdfset(parm,VALUE)
25135 mint(93)=3000000+mstp(55)
25136 ENDIF
25137 ENDIF
25138
25139C...Quarks and gluons inside photon inside electron:
25140C...numerical convolution required.
25141 DO 110 kfl=0,6
25142 sxp(kfl)=0d0
25143 110 CONTINUE
25144 sumxpp=0d0
25145 iter=-1
25146 120 iter=iter+1
25147 sumxp=sumxpp
25148 nstp=2**(iter-1)
25149 IF(iter.EQ.0) nstp=2
25150 DO 130 kfl=0,6
25151 sxp(kfl)=0.5d0*sxp(kfl)
25152 130 CONTINUE
25153 wtstp=0.5d0/nstp
25154 IF(iter.EQ.0) wtstp=0.5d0
25155C...Pick grid of x_{gamma} values logarithmically even.
25156 DO 150 istp=1,nstp
25157 IF(iter.EQ.0) THEN
25158 xle=xl*(istp-1)
25159 ELSE
25160 xle=xl*(istp-0.5d0)/nstp
25161 ENDIF
25162 xe=min(1d0-1d-10,exp(xle))
25163 xg=min(1d0-1d-10,x/xe)
25164C...Evaluate photon inside electron parton distribution for convolution.
25165 xpgp=1d0+(1d0-xe)**2
25166 IF(mstp(13).LE.1) THEN
25167 xpgp=xpgp*hle
25168 ELSE
25169 xpgp=xpgp*log(max(1d0,(parp(13)/pme**2)*(1d0-xe)/xe**2))
25170 ENDIF
25171C...Evaluate photon parton distributions for convolution.
25172 IF(mstp(56).EQ.1) THEN
25173 CALL pypdga(xg,q2,xpga)
25174 DO 140 kfl=0,5
25175 sxp(kfl)=sxp(kfl)+wtstp*xpgp*xpga(kfl)
25176 140 CONTINUE
25177 ELSEIF(mstp(56).EQ.2) THEN
25178C...Call PDFLIB parton distributions.
25179 xx=xg
25180 qq=sqrt(max(0d0,q2min,q2))
25181 IF(mstp(57).EQ.0) qq=sqrt(q2min)
25182 CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
25183 sxp(0)=sxp(0)+wtstp*xpgp*glu
25184 sxp(1)=sxp(1)+wtstp*xpgp*dnv
25185 sxp(2)=sxp(2)+wtstp*xpgp*upv
25186 sxp(3)=sxp(3)+wtstp*xpgp*str
25187 sxp(4)=sxp(4)+wtstp*xpgp*chm
25188 sxp(5)=sxp(5)+wtstp*xpgp*bot
25189 sxp(6)=sxp(6)+wtstp*xpgp*top
25190 ENDIF
25191 150 CONTINUE
25192 sumxpp=sxp(0)+2d0*sxp(1)+2d0*sxp(2)
25193 IF(iter.LE.2.OR.(iter.LE.7.AND.abs(sumxpp-sumxp).GT.
25194 & parp(14)*(sumxpp+sumxp))) GOTO 120
25195
25196C...Put convolution into output arrays.
25197 fconv=aemp*(-xl)
25198 xpel(0)=fconv*sxp(0)
25199 DO 160 kfl=1,6
25200 xpel(kfl)=fconv*sxp(kfl)
25201 xpel(-kfl)=xpel(kfl)
25202 160 CONTINUE
25203 ENDIF
25204
25205 RETURN
25206 END
25207
25208C*********************************************************************
25209
25210C...PYPDGA
25211C...Gives photon parton distribution.
25212
25213 SUBROUTINE pypdga(X,Q2,XPGA)
25214
25215C...Double precision and integer declarations.
25216 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25217 IMPLICIT INTEGER(I-N)
25218 INTEGER PYK,PYCHGE,PYCOMP
25219C...Commonblocks.
25220 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25221 common/pypars/mstp(200),parp(200),msti(200),pari(200)
25222 common/pyint1/mint(400),vint(400)
25223 SAVE /pydat1/,/pypars/,/pyint1/
25224C...Local arrays.
25225 dimension xpga(-6:6),dgag(4,3),dgbg(4,3),dgcg(4,3),dgan(4,3),
25226 &dgbn(4,3),dgcn(4,3),dgdn(4,3),dgen(4,3),dgas(4,3),dgbs(4,3),
25227 &dgcs(4,3),dgds(4,3),dges(4,3)
25228
25229C...The following data lines are coefficients needed in the
25230C...Drees and Grassie photon parton distribution parametrization.
25231 DATA dgag/-.207d0,.6158d0,1.074d0,0.d0,.8926d-2,.6594d0,
25232 &.4766d0,.1975d-1,.03197d0,1.018d0,.2461d0,.2707d-1/
25233 DATA dgbg/-.1987d0,.6257d0,8.352d0,5.024d0,.5085d-1,.2774d0,
25234 &-.3906d0,-.3212d0,-.618d-2,.9476d0,-.6094d0,-.1067d-1/
25235 DATA dgcg/5.119d0,-.2752d0,-6.993d0,2.298d0,-.2313d0,.1382d0,
25236 &6.542d0,.5162d0,-.1216d0,.9047d0,2.653d0,.2003d-2/
25237 DATA dgan/2.285d0,-.1526d-1,1330.d0,4.219d0,-.3711d0,1.061d0,
25238 &4.758d0,-.1503d-1,15.8d0,-.9464d0,-.5d0,-.2118d0/
25239 DATA dgbn/6.073d0,-.8132d0,-41.31d0,3.165d0,-.1717d0,.7815d0,
25240 &1.535d0,.7067d-2,2.742d0,-.7332d0,.7148d0,3.287d0/
25241 DATA dgcn/-.4202d0,.1778d-1,.9216d0,.18d0,.8766d-1,.2197d-1,
25242 &.1096d0,.204d0,.2917d-1,.4657d-1,.1785d0,.4811d-1/
25243 DATA dgdn/-.8083d-1,.6346d0,1.208d0,.203d0,-.8915d0,.2857d0,
25244 &2.973d0,.1185d0,-.342d-1,.7196d0,.7338d0,.8139d-1/
25245 DATA dgen/.5526d-1,1.136d0,.9512d0,.1163d-1,-.1816d0,.5866d0,
25246 &2.421d0,.4059d0,-.2302d-1,.9229d0,.5873d0,-.79d-4/
25247 DATA dgas/16.69d0,-.7916d0,1099.d0,4.428d0,-.1207d0,1.071d0,
25248 &1.977d0,-.8625d-2,6.734d0,-1.008d0,-.8594d-1,.7625d-1/
25249 DATA dgbs/.176d0,.4794d-1,1.047d0,.25d-1,25.d0,-1.648d0,
25250 &-.1563d-1,6.438d0,59.88d0,-2.983d0,4.48d0,.9686d0/
25251 DATA dgcs/-.208d-1,.3386d-2,4.853d0,.8404d0,-.123d-1,1.162d0,
25252 &.4824d0,-.11d-1,-.3226d-2,.8432d0,.3616d0,.1383d-2/
25253 DATA dgds/-.1685d-1,1.353d0,1.426d0,1.239d0,-.9194d-1,.7912d0,
25254 &.6397d0,2.327d0,-.3321d-1,.9475d0,-.3198d0,.2132d-1/
25255 DATA dges/-.1986d0,1.1d0,1.136d0,-.2779d0,.2015d-1,.9869d0,
25256 &-.7036d-1,.1694d-1,.1059d0,.6954d0,-.6663d0,.3683d0/
25257
25258C...Photon parton distribution from Drees and Grassie.
25259C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
25260 DO 100 kfl=-6,6
25261 xpga(kfl)=0d0
25262 100 CONTINUE
25263 vint(231)=1d0
25264 IF(mstp(57).LE.0) THEN
25265 t=log(1d0/0.16d0)
25266 ELSE
25267 t=log(min(1d4,max(1d0,q2))/0.16d0)
25268 ENDIF
25269 x1=1d0-x
25270 nf=3
25271 IF(q2.GT.25d0) nf=4
25272 IF(q2.GT.300d0) nf=5
25273 nfe=nf-2
25274 aem=paru(101)
25275
25276C...Evaluate gluon content.
25277 dga=dgag(1,nfe)*t**dgag(2,nfe)+dgag(3,nfe)*t**(-dgag(4,nfe))
25278 dgb=dgbg(1,nfe)*t**dgbg(2,nfe)+dgbg(3,nfe)*t**(-dgbg(4,nfe))
25279 dgc=dgcg(1,nfe)*t**dgcg(2,nfe)+dgcg(3,nfe)*t**(-dgcg(4,nfe))
25280 xpgl=dga*x**dgb*x1**dgc
25281
25282C...Evaluate up- and down-type quark content.
25283 dga=dgan(1,nfe)*t**dgan(2,nfe)+dgan(3,nfe)*t**(-dgan(4,nfe))
25284 dgb=dgbn(1,nfe)*t**dgbn(2,nfe)+dgbn(3,nfe)*t**(-dgbn(4,nfe))
25285 dgc=dgcn(1,nfe)*t**dgcn(2,nfe)+dgcn(3,nfe)*t**(-dgcn(4,nfe))
25286 dgd=dgdn(1,nfe)*t**dgdn(2,nfe)+dgdn(3,nfe)*t**(-dgdn(4,nfe))
25287 dge=dgen(1,nfe)*t**dgen(2,nfe)+dgen(3,nfe)*t**(-dgen(4,nfe))
25288 xpqn=x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
25289 dga=dgas(1,nfe)*t**dgas(2,nfe)+dgas(3,nfe)*t**(-dgas(4,nfe))
25290 dgb=dgbs(1,nfe)*t**dgbs(2,nfe)+dgbs(3,nfe)*t**(-dgbs(4,nfe))
25291 dgc=dgcs(1,nfe)*t**dgcs(2,nfe)+dgcs(3,nfe)*t**(-dgcs(4,nfe))
25292 dgd=dgds(1,nfe)*t**dgds(2,nfe)+dgds(3,nfe)*t**(-dgds(4,nfe))
25293 dge=dges(1,nfe)*t**dges(2,nfe)+dges(3,nfe)*t**(-dges(4,nfe))
25294 dgf=9d0
25295 IF(nf.EQ.4) dgf=10d0
25296 IF(nf.EQ.5) dgf=55d0/6d0
25297 xpqs=dgf*x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
25298 IF(nf.LE.3) THEN
25299 xpqu=(xpqs+9d0*xpqn)/6d0
25300 xpqd=(xpqs-4.5d0*xpqn)/6d0
25301 ELSEIF(nf.EQ.4) THEN
25302 xpqu=(xpqs+6d0*xpqn)/8d0
25303 xpqd=(xpqs-6d0*xpqn)/8d0
25304 ELSE
25305 xpqu=(xpqs+7.5d0*xpqn)/10d0
25306 xpqd=(xpqs-5d0*xpqn)/10d0
25307 ENDIF
25308
25309C...Put into output arrays.
25310 xpga(0)=aem*xpgl
25311 xpga(1)=aem*xpqd
25312 xpga(2)=aem*xpqu
25313 xpga(3)=aem*xpqd
25314 IF(nf.GE.4) xpga(4)=aem*xpqu
25315 IF(nf.GE.5) xpga(5)=aem*xpqd
25316 DO 110 kfl=1,6
25317 xpga(-kfl)=xpga(kfl)
25318 110 CONTINUE
25319
25320 RETURN
25321 END
25322
25323C*********************************************************************
25324
25325C...PYGGAM
25326C...Constructs the F2 and parton distributions of the photon
25327C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
25328C...For F2, c and b are included by the Bethe-Heitler formula;
25329C...in the 'MSbar' scheme additionally a Cgamma term is added.
25330C...Contains the SaS sets 1D, 1M, 2D and 2M.
25331C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25332
25333 SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
25334
25335C...Double precision and integer declarations.
25336 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25337 IMPLICIT INTEGER(I-N)
25338 INTEGER PYK,PYCHGE,PYCOMP
25339C...Commonblocks.
25340 common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
25341 &xpdir(-6:6)
25342 common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
25343 SAVE /pyint8/,/pyint9/
25344C...Local arrays.
25345 dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)
25346C...Charm and bottom masses (low to compensate for J/psi etc.).
25347 DATA pmc/1.3d0/, pmb/4.6d0/
25348C...alpha_em and alpha_em/(2*pi).
25349 DATA aem/0.007297d0/, aem2pi/0.0011614d0/
25350C...Lambda value for 4 flavours.
25351 DATA alam/0.20d0/
25352C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
25353 DATA fracu/0.8d0/
25354C...VMD couplings f_V**2/(4*pi).
25355 DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/
25356C...Masses for rho (=omega) and phi.
25357 DATA pmrho/0.770d0/, pmphi/1.020d0/
25358C...Number of points in integration for IP2=1.
25359 DATA nstep/100/
25360
25361C...Reset output.
25362 f2gm=0d0
25363 DO 100 kfl=-6,6
25364 xpdfgm(kfl)=0d0
25365 xpvmd(kfl)=0d0
25366 xpanl(kfl)=0d0
25367 xpanh(kfl)=0d0
25368 xpbeh(kfl)=0d0
25369 xpdir(kfl)=0d0
25370 vxpvmd(kfl)=0d0
25371 vxpanl(kfl)=0d0
25372 vxpanh(kfl)=0d0
25373 vxpdgm(kfl)=0d0
25374 100 CONTINUE
25375
25376C...Set Q0 cut-off parameter as function of set used.
25377 IF(iset.LE.2) THEN
25378 q0=0.6d0
25379 ELSE
25380 q0=2d0
25381 ENDIF
25382 q02=q0**2
25383
25384C...Scale choice for off-shell photon; common factors.
25385 q2a=q2
25386 facnor=1d0
25387 IF(ip2.EQ.1) THEN
25388 p2mx=p2+q02
25389 q2a=q2+p2*q02/max(q02,q2)
25390 facnor=log(q2/q02)/nstep
25391 ELSEIF(ip2.EQ.2) THEN
25392 p2mx=max(p2,q02)
25393 ELSEIF(ip2.EQ.3) THEN
25394 p2mx=p2+q02
25395 q2a=q2+p2*q02/max(q02,q2)
25396 ELSEIF(ip2.EQ.4) THEN
25397 p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
25398 & ((q2+p2)*(q02+p2)))
25399 ELSEIF(ip2.EQ.5) THEN
25400 p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
25401 & ((q2+p2)*(q02+p2)))
25402 p2mx=q0*sqrt(p2mxa)
25403 facnor=log(q2/p2mxa)/log(q2/p2mx)
25404 ELSEIF(ip2.EQ.6) THEN
25405 p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
25406 & ((q2+p2)*(q02+p2)))
25407 p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
25408 ELSE
25409 p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
25410 & ((q2+p2)*(q02+p2)))
25411 p2mx=q0*sqrt(p2mxa)
25412 p2mxb=p2mx
25413 p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
25414 p2mxb=max(0d0,1d0-p2/q2)*p2mxb+min(1d0,p2/q2)*p2mxa
25415 IF(abs(q2-q02).GT.1d-6) THEN
25416 facnor=log(q2/p2mxa)/log(q2/p2mxb)
25417 ELSEIF(p2.LT.q02) THEN
25418 facnor=q02**3/(q02+p2)/(q02**2-p2**2/2d0)
25419 ELSE
25420 facnor=1d0
25421 ENDIF
25422 ENDIF
25423
25424C...Call VMD parametrization for d quark and use to give rho, omega,
25425C...phi. Note dipole dampening for off-shell photon.
25426 CALL pygvmd(iset,1,x,q2a,p2mx,alam,xpga,vxpga)
25427 xfval=vxpga(1)
25428 xpga(1)=xpga(2)
25429 xpga(-1)=xpga(-2)
25430 facud=aem*(1d0/frho+1d0/fomega)*(pmrho**2/(pmrho**2+p2))**2
25431 facs=aem*(1d0/fphi)*(pmphi**2/(pmphi**2+p2))**2
25432 DO 110 kfl=-5,5
25433 xpvmd(kfl)=(facud+facs)*xpga(kfl)
25434 110 CONTINUE
25435 xpvmd(1)=xpvmd(1)+(1d0-fracu)*facud*xfval
25436 xpvmd(2)=xpvmd(2)+fracu*facud*xfval
25437 xpvmd(3)=xpvmd(3)+facs*xfval
25438 xpvmd(-1)=xpvmd(-1)+(1d0-fracu)*facud*xfval
25439 xpvmd(-2)=xpvmd(-2)+fracu*facud*xfval
25440 xpvmd(-3)=xpvmd(-3)+facs*xfval
25441 vxpvmd(1)=(1d0-fracu)*facud*xfval
25442 vxpvmd(2)=fracu*facud*xfval
25443 vxpvmd(3)=facs*xfval
25444 vxpvmd(-1)=(1d0-fracu)*facud*xfval
25445 vxpvmd(-2)=fracu*facud*xfval
25446 vxpvmd(-3)=facs*xfval
25447
25448 IF(ip2.NE.1) THEN
25449C...Anomalous parametrizations for different strategies
25450C...for off-shell photons; except full integration.
25451
25452C...Call anomalous parametrization for d + u + s.
25453 CALL pygano(-3,x,q2a,p2mx,alam,xpga,vxpga)
25454 DO 120 kfl=-5,5
25455 xpanl(kfl)=facnor*xpga(kfl)
25456 vxpanl(kfl)=facnor*vxpga(kfl)
25457 120 CONTINUE
25458
25459C...Call anomalous parametrization for c and b.
25460 CALL pygano(4,x,q2a,p2mx,alam,xpga,vxpga)
25461 DO 130 kfl=-5,5
25462 xpanh(kfl)=facnor*xpga(kfl)
25463 vxpanh(kfl)=facnor*vxpga(kfl)
25464 130 CONTINUE
25465 CALL pygano(5,x,q2a,p2mx,alam,xpga,vxpga)
25466 DO 140 kfl=-5,5
25467 xpanh(kfl)=xpanh(kfl)+facnor*xpga(kfl)
25468 vxpanh(kfl)=vxpanh(kfl)+facnor*vxpga(kfl)
25469 140 CONTINUE
25470
25471 ELSE
25472C...Special option: loop over flavours and integrate over k2.
25473 DO 170 kf=1,5
25474 DO 160 istep=1,nstep
25475 q2step=q02*(q2/q02)**((istep-0.5d0)/nstep)
25476 IF((kf.EQ.4.AND.q2step.LT.pmc**2).OR.
25477 & (kf.EQ.5.AND.q2step.LT.pmb**2)) GOTO 160
25478 CALL pygvmd(0,kf,x,q2,q2step,alam,xpga,vxpga)
25479 facq=aem2pi*(q2step/(q2step+p2))**2*facnor
25480 IF(mod(kf,2).EQ.0) facq=facq*(8d0/9d0)
25481 IF(mod(kf,2).EQ.1) facq=facq*(2d0/9d0)
25482 DO 150 kfl=-5,5
25483 IF(kf.LE.3) xpanl(kfl)=xpanl(kfl)+facq*xpga(kfl)
25484 IF(kf.GE.4) xpanh(kfl)=xpanh(kfl)+facq*xpga(kfl)
25485 IF(kf.LE.3) vxpanl(kfl)=vxpanl(kfl)+facq*vxpga(kfl)
25486 IF(kf.GE.4) vxpanh(kfl)=vxpanh(kfl)+facq*vxpga(kfl)
25487 150 CONTINUE
25488 160 CONTINUE
25489 170 CONTINUE
25490 ENDIF
25491
25492C...Call Bethe-Heitler term expression for charm and bottom.
25493 CALL pygbeh(4,x,q2,p2,pmc**2,xpbh)
25494 xpbeh(4)=xpbh
25495 xpbeh(-4)=xpbh
25496 CALL pygbeh(5,x,q2,p2,pmb**2,xpbh)
25497 xpbeh(5)=xpbh
25498 xpbeh(-5)=xpbh
25499
25500C...For MSbar subtraction call C^gamma term expression for d, u, s.
25501 IF(iset.EQ.2.OR.iset.EQ.4) THEN
25502 CALL pygdir(x,q2,p2,q02,xpga)
25503 DO 180 kfl=-5,5
25504 xpdir(kfl)=xpga(kfl)
25505 180 CONTINUE
25506 ENDIF
25507
25508C...Store result in output array.
25509 DO 190 kfl=-5,5
25510 chsq=1d0/9d0
25511 IF(iabs(kfl).EQ.2.OR.iabs(kfl).EQ.4) chsq=4d0/9d0
25512 xpf2=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
25513 IF(kfl.NE.0) f2gm=f2gm+chsq*xpf2
25514 xpdfgm(kfl)=xpvmd(kfl)+xpanl(kfl)+xpanh(kfl)
25515 vxpdgm(kfl)=vxpvmd(kfl)+vxpanl(kfl)+vxpanh(kfl)
25516 190 CONTINUE
25517
25518 RETURN
25519 END
25520
25521C*********************************************************************
25522
25523C...PYGVMD
25524C...Evaluates the VMD parton distributions of a photon,
25525C...evolved homogeneously from an initial scale P2 to Q2.
25526C...Does not include dipole suppression factor.
25527C...ISET is parton distribution set, see above;
25528C...additionally ISET=0 is used for the evolution of an anomalous photon
25529C...which branched at a scale P2 and then evolved homogeneously to Q2.
25530C...ALAM is the 4-flavour Lambda, which is automatically converted
25531C...to 3- and 5-flavour equivalents as needed.
25532C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25533
25534 SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25535
25536C...Double precision and integer declarations.
25537 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25538 IMPLICIT INTEGER(I-N)
25539 INTEGER PYK,PYCHGE,PYCOMP
25540C...Local arrays and data.
25541 dimension xpga(-6:6), vxpga(-6:6)
25542 DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
25543
25544C...Reset output.
25545 DO 100 kfl=-6,6
25546 xpga(kfl)=0d0
25547 vxpga(kfl)=0d0
25548 100 CONTINUE
25549 kfa=iabs(kf)
25550
25551C...Calculate Lambda; protect against unphysical Q2 and P2 input.
25552 alam3=alam*(pmc/alam)**(2d0/27d0)
25553 alam5=alam*(alam/pmb)**(2d0/23d0)
25554 p2eff=max(p2,1.2d0*alam3**2)
25555 IF(kfa.EQ.4) p2eff=max(p2eff,pmc**2)
25556 IF(kfa.EQ.5) p2eff=max(p2eff,pmb**2)
25557 q2eff=max(q2,p2eff)
25558
25559C...Find number of flavours at lower and upper scale.
25560 nfp=4
25561 IF(p2eff.LT.pmc**2) nfp=3
25562 IF(p2eff.GT.pmb**2) nfp=5
25563 nfq=4
25564 IF(q2eff.LT.pmc**2) nfq=3
25565 IF(q2eff.GT.pmb**2) nfq=5
25566
25567C...Find s as sum of 3-, 4- and 5-flavour parts.
25568 s=0d0
25569 IF(nfp.EQ.3) THEN
25570 q2div=pmc**2
25571 IF(nfq.EQ.3) q2div=q2eff
25572 s=s+(6d0/27d0)*log(log(q2div/alam3**2)/log(p2eff/alam3**2))
25573 ENDIF
25574 IF(nfp.LE.4.AND.nfq.GE.4) THEN
25575 p2div=p2eff
25576 IF(nfp.EQ.3) p2div=pmc**2
25577 q2div=q2eff
25578 IF(nfq.EQ.5) q2div=pmb**2
25579 s=s+(6d0/25d0)*log(log(q2div/alam**2)/log(p2div/alam**2))
25580 ENDIF
25581 IF(nfq.EQ.5) THEN
25582 p2div=pmb**2
25583 IF(nfp.EQ.5) p2div=p2eff
25584 s=s+(6d0/23d0)*log(log(q2eff/alam5**2)/log(p2div/alam5**2))
25585 ENDIF
25586
25587C...Calculate frequent combinations of x and s.
25588 x1=1d0-x
25589 xl=-log(x)
25590 s2=s**2
25591 s3=s**3
25592 s4=s**4
25593
25594C...Evaluate homogeneous anomalous parton distributions below or
25595C...above threshold.
25596 IF(iset.EQ.0) THEN
25597 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
25598 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
25599 xval = x * 1.5d0 * (x**2+x1**2)
25600 xglu = 0d0
25601 xsea = 0d0
25602 ELSE
25603 xval = (1.5d0/(1d0-0.197d0*s+4.33d0*s2)*x**2 +
25604 & (1.5d0+2.10d0*s)/(1d0+3.29d0*s)*x1**2 +
25605 & 5.23d0*s/(1d0+1.17d0*s+19.9d0*s3)*x*x1) *
25606 & x**(1d0/(1d0+1.5d0*s)) * (1d0-x**2)**(2.667d0*s)
25607 xglu = 4d0*s/(1d0+4.76d0*s+15.2d0*s2+29.3d0*s4) *
25608 & x**(-2.03d0*s/(1d0+2.44d0*s)) * (x1*xl)**(1.333d0*s) *
25609 & ((4d0*x**2+7d0*x+4d0)*x1/3d0 - 2d0*x*(1d0+x)*xl)
25610 xsea = s2/(1d0+4.54d0*s+8.19d0*s2+8.05d0*s3) *
25611 & x**(-1.54d0*s/(1d0+1.29d0*s)) * x1**(2.667d0*s) *
25612 & ((8d0-73d0*x+62d0*x**2)*x1/9d0 + (3d0-8d0*x**2/3d0)*x*xl +
25613 & (2d0*x-1d0)*x*xl**2)
25614 ENDIF
25615
25616C...Evaluate set 1D parton distributions below or above threshold.
25617 ELSEIF(iset.EQ.1) THEN
25618 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
25619 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
25620 xval = 1.294d0 * x**0.80d0 * x1**0.76d0
25621 xglu = 1.273d0 * x**0.40d0 * x1**1.76d0
25622 xsea = 0.100d0 * x1**3.76d0
25623 ELSE
25624 xval = 1.294d0/(1d0+0.252d0*s+3.079d0*s2) *
25625 & x**(0.80d0-0.13d0*s) * x1**(0.76d0+0.667d0*s) * xl**(2d0*s)
25626 xglu = 7.90d0*s/(1d0+5.50d0*s) * exp(-5.16d0*s) *
25627 & x**(-1.90d0*s/(1d0+3.60d0*s)) * x1**1.30d0 *
25628 & xl**(0.50d0+3d0*s) + 1.273d0 * exp(-10d0*s) *
25629 & x**0.40d0 * x1**(1.76d0+3d0*s)
25630 xsea = (0.1d0-0.397d0*s2+1.121d0*s3)/
25631 & (1d0+5.61d0*s2+5.26d0*s3) * x**(-7.32d0*s2/(1d0+10.3d0*s2)) *
25632 & x1**((3.76d0+15d0*s+12d0*s2)/(1d0+4d0*s))
25633 xsea0 = 0.100d0 * x1**3.76d0
25634 ENDIF
25635
25636C...Evaluate set 1M parton distributions below or above threshold.
25637 ELSEIF(iset.EQ.2) THEN
25638 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
25639 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
25640 xval = 0.8477d0 * x**0.51d0 * x1**1.37d0
25641 xglu = 3.42d0 * x**0.255d0 * x1**2.37d0
25642 xsea = 0d0
25643 ELSE
25644 xval = 0.8477d0/(1d0+1.37d0*s+2.18d0*s2+3.73d0*s3) *
25645 & x**(0.51d0+0.21d0*s) * x1**1.37d0 * xl**(2.667d0*s)
25646 xglu = 24d0*s/(1d0+9.6d0*s+0.92d0*s2+14.34d0*s3) *
25647 & exp(-5.94d0*s) * x**((-0.013d0-1.80d0*s)/(1d0+3.14d0*s)) *
25648 & x1**(2.37d0+0.4d0*s) * xl**(0.32d0+3.6d0*s) + 3.42d0 *
25649 & exp(-12d0*s) * x**0.255d0 * x1**(2.37d0+3d0*s)
25650 xsea = 0.842d0*s/(1d0+21.3d0*s-33.2d0*s2+229d0*s3) *
25651 & x**((0.13d0-2.90d0*s)/(1d0+5.44d0*s)) * x1**(3.45d0+0.5d0*s) *
25652 & xl**(2.8d0*s)
25653 xsea0 = 0d0
25654 ENDIF
25655
25656C...Evaluate set 2D parton distributions below or above threshold.
25657 ELSEIF(iset.EQ.3) THEN
25658 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
25659 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
25660 xval = x**0.46d0 * x1**0.64d0 + 0.76d0 * x
25661 xglu = 1.925d0 * x1**2
25662 xsea = 0.242d0 * x1**4
25663 ELSE
25664 xval = (1d0+0.186d0*s)/(1d0-0.209d0*s+1.495d0*s2) *
25665 & x**(0.46d0+0.25d0*s) *
25666 & x1**((0.64d0+0.14d0*s+5d0*s2)/(1d0+s)) * xl**(1.9d0*s) +
25667 & (0.76d0+0.4d0*s) * x * x1**(2.667d0*s)
25668 xglu = (1.925d0+5.55d0*s+147d0*s2)/(1d0-3.59d0*s+3.32d0*s2) *
25669 & exp(-18.67d0*s) *
25670 & x**((-5.81d0*s-5.34d0*s2)/(1d0+29d0*s-4.26d0*s2))
25671 & * x1**((2d0-5.9d0*s)/(1d0+1.7d0*s)) *
25672 & xl**(9.3d0*s/(1d0+1.7d0*s))
25673 xsea = (0.242d0-0.252d0*s+1.19d0*s2)/
25674 & (1d0-0.607d0*s+21.95d0*s2) *
25675 & x**(-12.1d0*s2/(1d0+2.62d0*s+16.7d0*s2)) * x1**4 * xl**s
25676 xsea0 = 0.242d0 * x1**4
25677 ENDIF
25678
25679C...Evaluate set 2M parton distributions below or above threshold.
25680 ELSEIF(iset.EQ.4) THEN
25681 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
25682 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
25683 xval = 1.168d0 * x**0.50d0 * x1**2.60d0 + 0.965d0 * x
25684 xglu = 1.808d0 * x1**2
25685 xsea = 0.209d0 * x1**4
25686 ELSE
25687 xval = (1.168d0+1.771d0*s+29.35d0*s2) * exp(-5.776d0*s) *
25688 & x**((0.5d0+0.208d0*s)/(1d0-0.794d0*s+1.516d0*s2)) *
25689 & x1**((2.6d0+7.6d0*s)/(1d0+5d0*s)) *
25690 & xl**(5.15d0*s/(1d0+2d0*s)) +
25691 & (0.965d0+22.35d0*s)/(1d0+18.4d0*s) * x * x1**(2.667d0*s)
25692 xglu = (1.808d0+29.9d0*s)/(1d0+26.4d0*s) * exp(-5.28d0*s) *
25693 & x**((-5.35d0*s-10.11d0*s2)/(1d0+31.71d0*s)) *
25694 & x1**((2d0-7.3d0*s+4d0*s2)/(1d0+2.5d0*s)) *
25695 & xl**(10.9d0*s/(1d0+2.5d0*s))
25696 xsea = (0.209d0+0.644d0*s2)/(1d0+0.319d0*s+17.6d0*s2) *
25697 & x**((-0.373d0*s-7.71d0*s2)/(1d0+0.815d0*s+11.0d0*s2)) *
25698 & x1**(4d0+s) * xl**(0.45d0*s)
25699 xsea0 = 0.209d0 * x1**4
25700 ENDIF
25701 ENDIF
25702
25703C...Threshold factors for c and b sea.
25704 sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
25705 xchm=0d0
25706 IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
25707 sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
25708 IF(iset.EQ.0) THEN
25709 xchm=xsea*(1d0-(sch/sll)**2)
25710 ELSE
25711 xchm=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sch/sll)
25712 ENDIF
25713 ENDIF
25714 xbot=0d0
25715 IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
25716 sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
25717 IF(iset.EQ.0) THEN
25718 xbot=xsea*(1d0-(sbt/sll)**2)
25719 ELSE
25720 xbot=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sbt/sll)
25721 ENDIF
25722 ENDIF
25723
25724C...Fill parton distributions.
25725 xpga(0)=xglu
25726 xpga(1)=xsea
25727 xpga(2)=xsea
25728 xpga(3)=xsea
25729 xpga(4)=xchm
25730 xpga(5)=xbot
25731 xpga(kfa)=xpga(kfa)+xval
25732 DO 110 kfl=1,5
25733 xpga(-kfl)=xpga(kfl)
25734 110 CONTINUE
25735 vxpga(kfa)=xval
25736 vxpga(-kfa)=xval
25737
25738 RETURN
25739 END
25740
25741C*********************************************************************
25742
25743C...PYGANO
25744C...Evaluates the parton distributions of the anomalous photon,
25745C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
25746C...KF=0 gives the sum over (up to) 5 flavours,
25747C...KF<0 limits to flavours up to abs(KF),
25748C...KF>0 is for flavour KF only.
25749C...ALAM is the 4-flavour Lambda, which is automatically converted
25750C...to 3- and 5-flavour equivalents as needed.
25751C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25752
25753 SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25754
25755C...Double precision and integer declarations.
25756 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25757 IMPLICIT INTEGER(I-N)
25758 INTEGER PYK,PYCHGE,PYCOMP
25759C...Local arrays and data.
25760 dimension xpga(-6:6), vxpga(-6:6), alamsq(3:5)
25761 DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
25762
25763C...Reset output.
25764 DO 100 kfl=-6,6
25765 xpga(kfl)=0d0
25766 vxpga(kfl)=0d0
25767 100 CONTINUE
25768 IF(q2.LE.p2) RETURN
25769 kfa=iabs(kf)
25770
25771C...Calculate Lambda; protect against unphysical Q2 and P2 input.
25772 alamsq(3)=(alam*(pmc/alam)**(2d0/27d0))**2
25773 alamsq(4)=alam**2
25774 alamsq(5)=(alam*(alam/pmb)**(2d0/23d0))**2
25775 p2eff=max(p2,1.2d0*alamsq(3))
25776 IF(kf.EQ.4) p2eff=max(p2eff,pmc**2)
25777 IF(kf.EQ.5) p2eff=max(p2eff,pmb**2)
25778 q2eff=max(q2,p2eff)
25779 xl=-log(x)
25780
25781C...Find number of flavours at lower and upper scale.
25782 nfp=4
25783 IF(p2eff.LT.pmc**2) nfp=3
25784 IF(p2eff.GT.pmb**2) nfp=5
25785 nfq=4
25786 IF(q2eff.LT.pmc**2) nfq=3
25787 IF(q2eff.GT.pmb**2) nfq=5
25788
25789C...Define range of flavour loop.
25790 IF(kf.EQ.0) THEN
25791 kflmn=1
25792 kflmx=5
25793 ELSEIF(kf.LT.0) THEN
25794 kflmn=1
25795 kflmx=kfa
25796 ELSE
25797 kflmn=kfa
25798 kflmx=kfa
25799 ENDIF
25800
25801C...Loop over flavours the photon can branch into.
25802 DO 110 kfl=kflmn,kflmx
25803
25804C...Light flavours: calculate t range and (approximate) s range.
25805 IF(kfl.LE.3.AND.(kfl.EQ.1.OR.kfl.EQ.kf)) THEN
25806 tdiff=log(q2eff/p2eff)
25807 s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
25808 & log(p2eff/alamsq(nfq)))
25809 IF(nfq.GT.nfp) THEN
25810 q2div=pmb**2
25811 IF(nfq.EQ.4) q2div=pmc**2
25812 snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
25813 & log(p2eff/alamsq(nfq)))
25814 snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
25815 & log(p2eff/alamsq(nfq-1)))
25816 s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
25817 ENDIF
25818 IF(nfq.EQ.5.AND.nfp.EQ.3) THEN
25819 q2div=pmc**2
25820 snf4=(6d0/(33d0-2d0*4))*log(log(q2div/alamsq(4))/
25821 & log(p2eff/alamsq(4)))
25822 snf3=(6d0/(33d0-2d0*3))*log(log(q2div/alamsq(3))/
25823 & log(p2eff/alamsq(3)))
25824 s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snf3-snf4)
25825 ENDIF
25826
25827C...u and s quark do not need a separate treatment when d has been done.
25828 ELSEIF(kfl.EQ.2.OR.kfl.EQ.3) THEN
25829
25830C...Charm: as above, but only include range above c threshold.
25831 ELSEIF(kfl.EQ.4) THEN
25832 IF(q2.LE.pmc**2) GOTO 110
25833 p2eff=max(p2eff,pmc**2)
25834 q2eff=max(q2eff,p2eff)
25835 tdiff=log(q2eff/p2eff)
25836 s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
25837 & log(p2eff/alamsq(nfq)))
25838 IF(nfq.EQ.5.AND.nfp.EQ.4) THEN
25839 q2div=pmb**2
25840 snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
25841 & log(p2eff/alamsq(nfq)))
25842 snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
25843 & log(p2eff/alamsq(nfq-1)))
25844 s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
25845 ENDIF
25846
25847C...Bottom: as above, but only include range above b threshold.
25848 ELSEIF(kfl.EQ.5) THEN
25849 IF(q2.LE.pmb**2) GOTO 110
25850 p2eff=max(p2eff,pmb**2)
25851 q2eff=max(q2,p2eff)
25852 tdiff=log(q2eff/p2eff)
25853 s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
25854 & log(p2eff/alamsq(nfq)))
25855 ENDIF
25856
25857C...Evaluate flavour-dependent prefactor (charge^2 etc.).
25858 chsq=1d0/9d0
25859 IF(kfl.EQ.2.OR.kfl.EQ.4) chsq=4d0/9d0
25860 fac=aem2pi*2d0*chsq*tdiff
25861
25862C...Evaluate parton distributions (normalized to unit momentum sum).
25863 IF(kfl.EQ.1.OR.kfl.EQ.4.OR.kfl.EQ.5.OR.kfl.EQ.kf) THEN
25864 xval= ((1.5d0+2.49d0*s+26.9d0*s**2)/(1d0+32.3d0*s**2)*x**2 +
25865 & (1.5d0-0.49d0*s+7.83d0*s**2)/(1d0+7.68d0*s**2)*(1d0-x)**2 +
25866 & 1.5d0*s/(1d0-3.2d0*s+7d0*s**2)*x*(1d0-x)) *
25867 & x**(1d0/(1d0+0.58d0*s)) * (1d0-x**2)**(2.5d0*s/(1d0+10d0*s))
25868 xglu= 2d0*s/(1d0+4d0*s+7d0*s**2) *
25869 & x**(-1.67d0*s/(1d0+2d0*s)) * (1d0-x**2)**(1.2d0*s) *
25870 & ((4d0*x**2+7d0*x+4d0)*(1d0-x)/3d0 - 2d0*x*(1d0+x)*xl)
25871 xsea= 0.333d0*s**2/(1d0+4.90d0*s+4.69d0*s**2+21.4d0*s**3) *
25872 & x**(-1.18d0*s/(1d0+1.22d0*s)) * (1d0-x)**(1.2d0*s) *
25873 & ((8d0-73d0*x+62d0*x**2)*(1d0-x)/9d0 +
25874 & (3d0-8d0*x**2/3d0)*x*xl + (2d0*x-1d0)*x*xl**2)
25875
25876C...Threshold factors for c and b sea.
25877 sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
25878 xchm=0d0
25879 IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
25880 sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
25881 xchm=xsea*(1d0-(sch/sll)**3)
25882 ENDIF
25883 xbot=0d0
25884 IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
25885 sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
25886 xbot=xsea*(1d0-(sbt/sll)**3)
25887 ENDIF
25888 ENDIF
25889
25890C...Add contribution of each valence flavour.
25891 xpga(0)=xpga(0)+fac*xglu
25892 xpga(1)=xpga(1)+fac*xsea
25893 xpga(2)=xpga(2)+fac*xsea
25894 xpga(3)=xpga(3)+fac*xsea
25895 xpga(4)=xpga(4)+fac*xchm
25896 xpga(5)=xpga(5)+fac*xbot
25897 xpga(kfl)=xpga(kfl)+fac*xval
25898 vxpga(kfl)=vxpga(kfl)+fac*xval
25899 110 CONTINUE
25900 DO 120 kfl=1,5
25901 xpga(-kfl)=xpga(kfl)
25902 vxpga(-kfl)=vxpga(kfl)
25903 120 CONTINUE
25904
25905 RETURN
25906 END
25907
25908C*********************************************************************
25909
25910C...PYGBEH
25911C...Evaluates the Bethe-Heitler cross section for heavy flavour
25912C...production.
25913C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25914
25915 SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)
25916
25917C...Double precision and integer declarations.
25918 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25919 IMPLICIT INTEGER(I-N)
25920 INTEGER PYK,PYCHGE,PYCOMP
25921
25922C...Local data.
25923 DATA aem2pi/0.0011614d0/
25924
25925C...Reset output.
25926 xpbh=0d0
25927 sigbh=0d0
25928
25929C...Check kinematics limits.
25930 IF(x.GE.q2/(4d0*pm2+q2+p2)) RETURN
25931 w2=q2*(1d0-x)/x-p2
25932 beta2=1d0-4d0*pm2/w2
25933 IF(beta2.LT.1d-10) RETURN
25934 beta=sqrt(beta2)
25935 rmq=4d0*pm2/q2
25936
25937C...Simple case: P2 = 0.
25938 IF(p2.LT.1d-4) THEN
25939 IF(beta.LT.0.99d0) THEN
25940 xbl=log((1d0+beta)/(1d0-beta))
25941 ELSE
25942 xbl=log((1d0+beta)**2*w2/(4d0*pm2))
25943 ENDIF
25944 sigbh=beta*(8d0*x*(1d0-x)-1d0-rmq*x*(1d0-x))+
25945 & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)
25946
25947C...Complicated case: P2 > 0, based on approximation of
25948C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
25949 ELSE
25950 rpq=1d0-4d0*x**2*p2/q2
25951 IF(rpq.GT.1d-10) THEN
25952 rpbe=sqrt(rpq*beta2)
25953 IF(rpbe.LT.0.99d0) THEN
25954 xbl=log((1d0+rpbe)/(1d0-rpbe))
25955 xbi=2d0*rpbe/(1d0-rpbe**2)
25956 ELSE
25957 rpbesn=4d0*pm2/w2+(4d0*x**2*p2/q2)*beta2
25958 xbl=log((1d0+rpbe)**2/rpbesn)
25959 xbi=2d0*rpbe/rpbesn
25960 ENDIF
25961 sigbh=beta*(6d0*x*(1d0-x)-1d0)+
25962 & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)+
25963 & xbi*(2d0*x/q2)*(pm2*x*(2d0-rmq)-p2*x)
25964 ENDIF
25965 ENDIF
25966
25967C...Multiply by charge-squared etc. to get parton distribution.
25968 chsq=1d0/9d0
25969 IF(iabs(kf).EQ.2.OR.iabs(kf).EQ.4) chsq=4d0/9d0
25970 xpbh=3d0*chsq*aem2pi*x*sigbh
25971
25972 RETURN
25973 END
25974
25975C*********************************************************************
25976
25977C...PYGDIR
25978C...Evaluates the direct contribution, i.e. the C^gamma term,
25979C...as needed in MSbar parametrizations.
25980C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25981
25982 SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)
25983
25984C...Double precision and integer declarations.
25985 IMPLICIT DOUBLE PRECISION(a-h, o-z)
25986 IMPLICIT INTEGER(I-N)
25987 INTEGER PYK,PYCHGE,PYCOMP
25988C...Local array and data.
25989 dimension xpga(-6:6)
25990 DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/
25991
25992C...Reset output.
25993 DO 100 kfl=-6,6
25994 xpga(kfl)=0d0
25995 100 CONTINUE
25996
25997C...Evaluate common x-dependent expression.
25998 xtmp = (x**2+(1d0-x)**2) * (-log(x)) - 1d0
25999 cgam = 3d0*aem2pi*x * (xtmp*(1d0+p2/(p2+q02)) + 6d0*x*(1d0-x))
26000
26001C...d, u, s part by simple charge factor.
26002 xpga(1)=(1d0/9d0)*cgam
26003 xpga(2)=(4d0/9d0)*cgam
26004 xpga(3)=(1d0/9d0)*cgam
26005
26006C...Also fill for antiquarks.
26007 DO 110 kf=1,5
26008 xpga(-kf)=xpga(kf)
26009 110 CONTINUE
26010
26011 RETURN
26012 END
26013
26014C*********************************************************************
26015
26016C...PYPDPI
26017C...Gives pi+ parton distribution according to two different
26018C...parametrizations.
26019
26020 SUBROUTINE pypdpi(X,Q2,XPPI)
26021
26022C...Double precision and integer declarations.
26023 IMPLICIT DOUBLE PRECISION(a-h, o-z)
26024 IMPLICIT INTEGER(I-N)
26025 INTEGER PYK,PYCHGE,PYCOMP
26026C...Commonblocks.
26027 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
26028 common/pypars/mstp(200),parp(200),msti(200),pari(200)
26029 common/pyint1/mint(400),vint(400)
26030 SAVE /pydat1/,/pypars/,/pyint1/
26031C...Local arrays.
26032 dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)
26033
26034C...The following data lines are coefficients needed in the
26035C...Owens pion parton distribution parametrizations, see below.
26036C...Expansion coefficients for up and down valence quark distributions.
26037 DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/
26038 &4.0000d-01, 7.0000d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
26039 &-6.2120d-02, 6.4780d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
26040 &-7.1090d-03, 1.3350d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
26041 DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/
26042 &4.0000d-01, 6.2800d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
26043 &-5.9090d-02, 6.4360d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
26044 &-6.5240d-03, 1.4510d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
26045C...Expansion coefficients for gluon distribution.
26046 DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/
26047 &8.8800d-01, 0.0000d+00, 3.1100d+00, 6.0000d+00, 0.0000d+00,
26048 &-1.8020d+00, -1.5760d+00, -1.3170d-01, 2.8010d+00, -1.7280d+01,
26049 &1.8120d+00, 1.2000d+00, 5.0680d-01, -1.2160d+01, 2.0490d+01/
26050 DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/
26051 &7.9400d-01, 0.0000d+00, 2.8900d+00, 6.0000d+00, 0.0000d+00,
26052 &-9.1440d-01, -1.2370d+00, 5.9660d-01, -3.6710d+00, -8.1910d+00,
26053 &5.9660d-01, 6.5820d-01, -2.5500d-01, -2.3040d+00, 7.7580d+00/
26054C...Expansion coefficients for (up+down+strange) quark sea distribution.
26055 DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/
26056 &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
26057 &-2.4280d-01, -2.1200d-01, 8.6730d-01, 1.2660d+00, 2.3820d+00,
26058 &1.3860d-01, 3.6710d-03, 4.7470d-02, -2.2150d+00, 3.4820d-01/
26059 DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/
26060 &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
26061 &-1.4170d-01, -1.6970d-01, -2.4740d+00, -2.5340d+00, 5.6210d-01,
26062 &-1.7400d-01, -9.6230d-02, 1.5750d+00, 1.3780d+00, -2.7010d-01/
26063C...Expansion coefficients for charm quark sea distribution.
26064 DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/
26065 &0.0000d+00, -2.2120d-02, 2.8940d+00, 0.0000d+00, 0.0000d+00,
26066 &7.9280d-02, -3.7850d-01, 9.4330d+00, 5.2480d+00, 8.3880d+00,
26067 &-6.1340d-02, -1.0880d-01, -1.0852d+01, -7.1870d+00, -1.1610d+01/
26068 DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/
26069 &0.0000d+00, -8.8200d-02, 1.9240d+00, 0.0000d+00, 0.0000d+00,
26070 &6.2290d-02, -2.8920d-01, 2.4240d-01, -4.4630d+00, -8.3670d-01,
26071 &-4.0990d-02, -1.0820d-01, 2.0360d+00, 5.2090d+00, -4.8400d-02/
26072
26073C...Euler's beta function, requires ordinary Gamma function
26074 eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
26075
26076C...Reset output array.
26077 DO 100 kfl=-6,6
26078 xppi(kfl)=0d0
26079 100 CONTINUE
26080
26081 IF(mstp(53).LE.2) THEN
26082C...Pion parton distributions from Owens.
26083C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
26084
26085C...Determine set, Lambda and s expansion variable.
26086 nset=mstp(53)
26087 IF(nset.EQ.1) alam=0.2d0
26088 IF(nset.EQ.2) alam=0.4d0
26089 vint(231)=4d0
26090 IF(mstp(57).LE.0) THEN
26091 sd=0d0
26092 ELSE
26093 q2in=min(2d3,max(4d0,q2))
26094 sd=log(log(q2in/alam**2)/log(4d0/alam**2))
26095 ENDIF
26096
26097C...Calculate parton distributions.
26098 DO 120 kfl=1,4
26099 DO 110 is=1,5
26100 ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+
26101 & cow(3,is,kfl,nset)*sd**2
26102 110 CONTINUE
26103 IF(kfl.EQ.1) THEN
26104 xq(kfl)=x**ts(1)*(1d0-x)**ts(2)/eulbet(ts(1),ts(2)+1d0)
26105 ELSE
26106 xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
26107 & ts(5)*x**2)
26108 ENDIF
26109 120 CONTINUE
26110
26111C...Put into output array.
26112 xppi(0)=xq(2)
26113 xppi(1)=xq(3)/6d0
26114 xppi(2)=xq(1)+xq(3)/6d0
26115 xppi(3)=xq(3)/6d0
26116 xppi(4)=xq(4)
26117 xppi(-1)=xq(1)+xq(3)/6d0
26118 xppi(-2)=xq(3)/6d0
26119 xppi(-3)=xq(3)/6d0
26120 xppi(-4)=xq(4)
26121
26122C...Leading order pion parton distributions from Gluck, Reya and Vogt.
26123C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
26124C...10^-5 < x < 1.
26125 ELSE
26126
26127C...Determine s expansion variable and some x expressions.
26128 vint(231)=0.25d0
26129 IF(mstp(57).LE.0) THEN
26130 sd=0d0
26131 ELSE
26132 q2in=min(1d8,max(0.25d0,q2))
26133 sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
26134 ENDIF
26135 sd2=sd**2
26136 xl=-log(x)
26137 xs=sqrt(x)
26138
26139C...Evaluate valence, gluon and sea distributions.
26140 xfval=(0.519d0+0.180d0*sd-0.011d0*sd2)*x**(0.499d0-0.027d0*sd)*
26141 & (1d0+(0.381d0-0.419d0*sd)*xs)*(1d0-x)**(0.367d0+0.563d0*sd)
26142 xfglu=(x**(0.482d0+0.341d0*sqrt(sd))*((0.678d0+0.877d0*
26143 & sd-0.175d0*sd2)+
26144 & (0.338d0-1.597d0*sd)*xs+(-0.233d0*sd+0.406d0*sd2)*x)+
26145 & sd**0.599d0*exp(-(0.618d0+2.070d0*sd)+sqrt(3.676d0*sd**1.263d0*
26146 & xl)))*
26147 & (1d0-x)**(0.390d0+1.053d0*sd)
26148 xfsea=sd**0.55d0*(1d0-0.748d0*xs+(0.313d0+0.935d0*sd)*x)*(1d0-
26149 & x)**3.359d0*
26150 & exp(-(4.433d0+1.301d0*sd)+sqrt((9.30d0-0.887d0*sd)*sd**0.56d0*
26151 & xl))/
26152 & xl**(2.538d0-0.763d0*sd)
26153 IF(sd.LE.0.888d0) THEN
26154 xfchm=0d0
26155 ELSE
26156 xfchm=(sd-0.888d0)**1.02d0*(1d0+1.008d0*x)*(1d0-x)**(1.208d0+
26157 & 0.771d0*sd)*
26158 & exp(-(4.40d0+1.493d0*sd)+sqrt((2.032d0+1.901d0*sd)*sd**0.39d0*
26159 & xl))
26160 ENDIF
26161 IF(sd.LE.1.351d0) THEN
26162 xfbot=0d0
26163 ELSE
26164 xfbot=(sd-1.351d0)**1.03d0*(1d0-x)**(0.697d0+0.855d0*sd)*
26165 & exp(-(4.51d0+1.490d0*sd)+sqrt((3.056d0+1.694d0*sd)*sd**0.39d0*
26166 & xl))
26167 ENDIF
26168
26169C...Put into output array.
26170 xppi(0)=xfglu
26171 xppi(1)=xfsea
26172 xppi(2)=xfsea
26173 xppi(3)=xfsea
26174 xppi(4)=xfchm
26175 xppi(5)=xfbot
26176 DO 130 kfl=1,5
26177 xppi(-kfl)=xppi(kfl)
26178 130 CONTINUE
26179 xppi(2)=xppi(2)+xfval
26180 xppi(-1)=xppi(-1)+xfval
26181 ENDIF
26182
26183 RETURN
26184 END
26185
26186C*********************************************************************
26187
26188C...PYPDPR
26189C...Gives proton parton distributions according to a few different
26190C...parametrizations.
26191
26192 SUBROUTINE pypdpr(X,Q2,XPPR)
26193
26194C...Double precision and integer declarations.
26195 IMPLICIT DOUBLE PRECISION(a-h, o-z)
26196 IMPLICIT INTEGER(I-N)
26197 INTEGER PYK,PYCHGE,PYCOMP
26198C...Commonblocks.
26199 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
26200 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
26201 common/pypars/mstp(200),parp(200),msti(200),pari(200)
26202 common/pyint1/mint(400),vint(400)
26203 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
26204C...Arrays and data.
26205 dimension xppr(-6:6),q2min(16)
26206 DATA q2min/ 2.56d0, 2.56d0, 2.56d0, 0.4d0, 0.4d0, 0.4d0,
26207 &1.0d0, 1.0d0, 2*0d0, 0.25d0, 5d0, 5d0, 4d0, 4d0, 0d0/
26208
26209C...Reset output array.
26210 DO 100 kfl=-6,6
26211 xppr(kfl)=0d0
26212 100 CONTINUE
26213
26214C...Common preliminaries.
26215 nset=max(1,min(16,mstp(51)))
26216 IF(nset.EQ.9.OR.nset.EQ.10) nset=6
26217 vint(231)=q2min(nset)
26218 IF(mstp(57).EQ.0) THEN
26219 q2l=q2min(nset)
26220 ELSE
26221 q2l=max(q2min(nset),q2)
26222 ENDIF
26223
26224 IF(nset.GE.1.AND.nset.LE.3) THEN
26225C...Interface to the CTEQ 3 parton distributions.
26226 qrt=sqrt(max(1d0,q2l))
26227
26228C...Loop over flavours.
26229 DO 110 i=-6,6
26230 IF(i.LE.0) THEN
26231 xppr(i)=pycteq(nset,i,x,qrt)
26232 ELSEIF(i.LE.2) THEN
26233 xppr(i)=pycteq(nset,i,x,qrt)+xppr(-i)
26234 ELSE
26235 xppr(i)=xppr(-i)
26236 ENDIF
26237 110 CONTINUE
26238
26239 ELSEIF(nset.GE.4.AND.nset.LE.6) THEN
26240C...Interface to the GRV 94 distributions.
26241 IF(nset.EQ.4) THEN
26242 CALL pygrvl (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
26243 ELSEIF(nset.EQ.5) THEN
26244 CALL pygrvm (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
26245 ELSE
26246 CALL pygrvd (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
26247 ENDIF
26248
26249C...Put into output array.
26250 xppr(0)=gl
26251 xppr(-1)=0.5d0*(udb+del)
26252 xppr(-2)=0.5d0*(udb-del)
26253 xppr(-3)=sb
26254 xppr(-4)=chm
26255 xppr(-5)=bot
26256 xppr(1)=dv+xppr(-1)
26257 xppr(2)=uv+xppr(-2)
26258 xppr(3)=sb
26259 xppr(4)=chm
26260 xppr(5)=bot
26261
26262 ELSEIF(nset.EQ.7) THEN
26263C...Interface to the CTEQ 5L parton distributions.
26264C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
26265C...freezing x*f(x,Q2) at borders.
26266 qrt=sqrt(max(1d0,min(1d4,q2l)))
26267 xin=max(1d-6,min(1d0,x))
26268
26269C...Loop over flavours (with u <-> d notation mismatch).
26270 sumudb=pyct5l(-1,xin,qrt)
26271 ratudb=pyct5l(-2,xin,qrt)
26272 DO 120 i=-5,2
26273 IF(i.EQ.1) THEN
26274 xppr(i)=xin*pyct5l(2,xin,qrt)
26275 ELSEIF(i.EQ.2) THEN
26276 xppr(i)=xin*pyct5l(1,xin,qrt)
26277 ELSEIF(i.EQ.-1) THEN
26278 xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
26279 ELSEIF(i.EQ.-2) THEN
26280 xppr(i)=xin*sumudb/(1d0+ratudb)
26281 ELSE
26282 xppr(i)=xin*pyct5l(i,xin,qrt)
26283 IF(i.LT.0) xppr(-i)=xppr(i)
26284 ENDIF
26285 120 CONTINUE
26286
26287 ELSEIF(nset.EQ.8) THEN
26288C...Interface to the CTEQ 5M1 parton distributions.
26289 qrt=sqrt(max(1d0,min(1d4,q2l)))
26290 xin=max(1d-6,min(1d0,x))
26291
26292C...Loop over flavours (with u <-> d notation mismatch).
26293 sumudb=pyct5m(-1,xin,qrt)
26294 ratudb=pyct5m(-2,xin,qrt)
26295 DO 130 i=-5,2
26296 IF(i.EQ.1) THEN
26297 xppr(i)=xin*pyct5m(2,xin,qrt)
26298 ELSEIF(i.EQ.2) THEN
26299 xppr(i)=xin*pyct5m(1,xin,qrt)
26300 ELSEIF(i.EQ.-1) THEN
26301 xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
26302 ELSEIF(i.EQ.-2) THEN
26303 xppr(i)=xin*sumudb/(1d0+ratudb)
26304 ELSE
26305 xppr(i)=xin*pyct5m(i,xin,qrt)
26306 IF(i.LT.0) xppr(-i)=xppr(i)
26307 ENDIF
26308 130 CONTINUE
26309
26310 ELSEIF(nset.GE.11.AND.nset.LE.15) THEN
26311C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
26312C...obsolete but offers backwards compatibility.
26313 CALL pypdpo(x,q2l,xppr)
26314
26315C...Symmetric choice for debugging only
26316 ELSEIF(nset.EQ.16) THEN
26317 xppr(0)=.5d0/x
26318 xppr(1)=.05d0/x
26319 xppr(2)=.05d0/x
26320 xppr(3)=.05d0/x
26321 xppr(4)=.05d0/x
26322 xppr(5)=.05d0/x
26323 xppr(-1)=.05d0/x
26324 xppr(-2)=.05d0/x
26325 xppr(-3)=.05d0/x
26326 xppr(-4)=.05d0/x
26327 xppr(-5)=.05d0/x
26328
26329 ENDIF
26330
26331 RETURN
26332 END
26333
26334C*********************************************************************
26335
26336C...PYCTEQ
26337C...Gives the CTEQ 3 parton distribution function sets in
26338C...parametrized form, of October 24, 1994.
26339C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
26340C...J. Qiu, W.K. Tung and H. Weerts.
26341
26342 FUNCTION pycteq (ISET, IPRT, X, Q)
26343
26344C...Double precision declaration.
26345 IMPLICIT DOUBLE PRECISION(a-h, o-z)
26346 IMPLICIT INTEGER(I-N)
26347
26348C...Data on Lambda values of fits, minimum Q and quark masses.
26349 dimension alm(3), qms(4:6)
26350 DATA alm / 0.177d0, 0.239d0, 0.247d0 /
26351 DATA qmn / 1.60d0 /, (qms(i), i=4,6) / 1.60d0, 5.00d0, 180.0d0 /
26352
26353C....Check flavour thresholds. Set up QI for SB.
26354 ip = iabs(iprt)
26355 IF(ip .GE. 4) THEN
26356 IF(q .LE. qms(ip)) THEN
26357 pycteq = 0d0
26358 RETURN
26359 ENDIF
26360 qi = qms(ip)
26361 ELSE
26362 qi = qmn
26363 ENDIF
26364
26365C...Use "standard lambda" of parametrization program for expansion.
26366 alam = alm(iset)
26367 sbl = log(q/alam) / log(qi/alam)
26368 sb = log(sbl)
26369 sb2 = sb*sb
26370 sb3 = sb2*sb
26371
26372C...Expansion for CTEQ3L.
26373 IF(iset .EQ. 1) THEN
26374 IF(iprt .EQ. 2) THEN
26375 a0=exp( 0.1907d+00+0.4205d-01*sb +0.2752d+00*sb2-
26376 & 0.3171d+00*sb3)
26377 a1= 0.4611d+00+0.2331d-01*sb -0.3403d-01*sb2+0.3174d-01*sb3
26378 a2= 0.3504d+01+0.5739d+00*sb +0.2676d+00*sb2-0.1553d+00*sb3
26379 a3= 0.7452d+01-0.6742d+01*sb +0.2849d+01*sb2-0.1964d+00*sb3
26380 a4= 0.1116d+01-0.3435d+00*sb +0.2865d+00*sb2-0.1288d+00*sb3
26381 a5= 0.6659d-01+0.2714d+00*sb -0.2688d+00*sb2+0.2763d+00*sb3
26382 ELSEIF(iprt .EQ. 1) THEN
26383 a0=exp( 0.1141d+00+0.4764d+00*sb -0.1745d+01*sb2+
26384 & 0.7728d+00*sb3)
26385 a1= 0.4275d+00-0.1290d+00*sb +0.3609d+00*sb2-0.1689d+00*sb3
26386 a2= 0.3000d+01+0.2946d+01*sb -0.4117d+01*sb2+0.1989d+01*sb3
26387 a3=-0.1302d+01+0.2322d+01*sb -0.4258d+01*sb2+0.2109d+01*sb3
26388 a4= 0.2586d+01-0.1920d+00*sb -0.3754d+00*sb2+0.2731d+00*sb3
26389 a5=-0.2251d+00-0.5374d+00*sb +0.2245d+01*sb2-0.1034d+01*sb3
26390 ELSEIF(iprt .EQ. 0) THEN
26391 a0=exp(-0.7631d+00-0.7241d+00*sb -0.1170d+01*sb2+
26392 & 0.5343d+00*sb3)
26393 a1=-0.3573d+00+0.3469d+00*sb -0.3396d+00*sb2+0.9188d-01*sb3
26394 a2= 0.5604d+01+0.7458d+00*sb -0.5082d+00*sb2+0.1844d+00*sb3
26395 a3= 0.1549d+02-0.1809d+02*sb +0.1162d+02*sb2-0.3483d+01*sb3
26396 a4= 0.9881d+00+0.1364d+00*sb -0.4421d+00*sb2+0.2051d+00*sb3
26397 a5=-0.9505d-01+0.3259d+01*sb -0.1547d+01*sb2+0.2918d+00*sb3
26398 ELSEIF(iprt .EQ. -1) THEN
26399 a0=exp(-0.2449d+01-0.3513d+01*sb +0.4529d+01*sb2-
26400 & 0.2031d+01*sb3)
26401 a1=-0.4050d+00+0.3411d+00*sb -0.3669d+00*sb2+0.1109d+00*sb3
26402 a2= 0.7470d+01-0.2982d+01*sb +0.5503d+01*sb2-0.2419d+01*sb3
26403 a3= 0.1503d+02+0.1638d+01*sb -0.8772d+01*sb2+0.3852d+01*sb3
26404 a4= 0.1137d+01-0.1006d+01*sb +0.1485d+01*sb2-0.6389d+00*sb3
26405 a5=-0.5299d+00+0.3160d+01*sb -0.3104d+01*sb2+0.1219d+01*sb3
26406 ELSEIF(iprt .EQ. -2) THEN
26407 a0=exp(-0.2740d+01-0.7987d-01*sb -0.9015d+00*sb2-
26408 & 0.9872d-01*sb3)
26409 a1=-0.3909d+00+0.1244d+00*sb -0.4487d-01*sb2+0.1277d-01*sb3
26410 a2= 0.9163d+01+0.2823d+00*sb -0.7720d+00*sb2-0.9360d-02*sb3
26411 a3= 0.1080d+02-0.3915d+01*sb -0.1153d+01*sb2+0.2649d+01*sb3
26412 a4= 0.9894d+00-0.1647d+00*sb -0.9426d-02*sb2+0.2945d-02*sb3
26413 a5=-0.3395d+00+0.6998d+00*sb +0.7000d+00*sb2-0.6730d-01*sb3
26414 ELSEIF(iprt .EQ. -3) THEN
26415 a0=exp(-0.3640d+01+0.1250d+01*sb -0.2914d+01*sb2+
26416 & 0.8390d+00*sb3)
26417 a1=-0.3595d+00-0.5259d-01*sb +0.3122d+00*sb2-0.1642d+00*sb3
26418 a2= 0.7305d+01+0.9727d+00*sb -0.9788d+00*sb2-0.5193d-01*sb3
26419 a3= 0.1198d+02-0.1799d+02*sb +0.2614d+02*sb2-0.1091d+02*sb3
26420 a4= 0.9882d+00-0.6101d+00*sb +0.9737d+00*sb2-0.4935d+00*sb3
26421 a5=-0.1186d+00-0.3231d+00*sb +0.3074d+01*sb2-0.1274d+01*sb3
26422 ELSEIF(iprt .EQ. -4) THEN
26423 a0=sb** 0.1122d+01*exp(-0.3718d+01-0.1335d+01*sb +
26424 & 0.1651d-01*sb2)
26425 a1=-0.4719d+00+0.7509d+00*sb -0.8420d+00*sb2+0.2901d+00*sb3
26426 a2= 0.6194d+01-0.1641d+01*sb +0.4907d+01*sb2-0.2523d+01*sb3
26427 a3= 0.4426d+01-0.4270d+01*sb +0.6581d+01*sb2-0.3474d+01*sb3
26428 a4= 0.2683d+00+0.9876d+00*sb -0.7612d+00*sb2+0.1780d+00*sb3
26429 a5=-0.4547d+00+0.4410d+01*sb -0.3712d+01*sb2+0.1245d+01*sb3
26430 ELSEIF(iprt .EQ. -5) THEN
26431 a0=sb** 0.9838d+00*exp(-0.2548d+01-0.7660d+01*sb +
26432 & 0.3702d+01*sb2)
26433 a1=-0.3122d+00-0.2120d+00*sb +0.5716d+00*sb2-0.3773d+00*sb3
26434 a2= 0.6257d+01-0.8214d-01*sb -0.2537d+01*sb2+0.2981d+01*sb3
26435 a3=-0.6723d+00+0.2131d+01*sb +0.9599d+01*sb2-0.7910d+01*sb3
26436 a4= 0.9169d-01+0.4295d-01*sb -0.5017d+00*sb2+0.3811d+00*sb3
26437 a5= 0.2402d+00+0.2656d+01*sb -0.1586d+01*sb2+0.2880d+00*sb3
26438 ELSEIF(iprt .EQ. -6) THEN
26439 a0=sb** 0.1001d+01*exp(-0.6934d+01+0.3050d+01*sb -
26440 & 0.6943d+00*sb2)
26441 a1=-0.1713d+00-0.5167d+00*sb +0.1241d+01*sb2-0.1703d+01*sb3
26442 a2= 0.6169d+01+0.3023d+01*sb -0.1972d+02*sb2+0.1069d+02*sb3
26443 a3= 0.4439d+01-0.1746d+02*sb +0.1225d+02*sb2+0.8350d+00*sb3
26444 a4= 0.5458d+00-0.4586d+00*sb +0.9089d+00*sb2-0.4049d+00*sb3
26445 a5= 0.3207d+01-0.3362d+01*sb +0.5877d+01*sb2-0.7659d+01*sb3
26446 ENDIF
26447
26448C...Expansion for CTEQ3M.
26449 ELSEIF(iset .EQ. 2) THEN
26450 IF(iprt .EQ. 2) THEN
26451 a0=exp( 0.2259d+00+0.1237d+00*sb +0.3035d+00*sb2-
26452 & 0.2935d+00*sb3)
26453 a1= 0.5085d+00+0.1651d-01*sb -0.3592d-01*sb2+0.2782d-01*sb3
26454 a2= 0.3732d+01+0.4901d+00*sb +0.2218d+00*sb2-0.1116d+00*sb3
26455 a3= 0.7011d+01-0.6620d+01*sb +0.2557d+01*sb2-0.1360d+00*sb3
26456 a4= 0.8969d+00-0.2429d+00*sb +0.1811d+00*sb2-0.6888d-01*sb3
26457 a5= 0.8636d-01+0.2558d+00*sb -0.3082d+00*sb2+0.2535d+00*sb3
26458 ELSEIF(iprt .EQ. 1) THEN
26459 a0=exp(-0.7266d+00-0.1584d+01*sb +0.1259d+01*sb2-
26460 & 0.4305d-01*sb3)
26461 a1= 0.5285d+00-0.3721d+00*sb +0.5150d+00*sb2-0.1697d+00*sb3
26462 a2= 0.4075d+01+0.8282d+00*sb -0.4496d+00*sb2+0.2107d+00*sb3
26463 a3= 0.3279d+01+0.5066d+01*sb -0.9134d+01*sb2+0.2897d+01*sb3
26464 a4= 0.4399d+00-0.5888d+00*sb +0.4802d+00*sb2-0.1664d+00*sb3
26465 a5= 0.3678d+00-0.8929d+00*sb +0.1592d+01*sb2-0.5713d+00*sb3
26466 ELSEIF(iprt .EQ. 0) THEN
26467 a0=exp(-0.2318d+00-0.9779d+00*sb -0.3783d+00*sb2+
26468 & 0.1037d-01*sb3)
26469 a1=-0.2916d+00+0.1754d+00*sb -0.1884d+00*sb2+0.6116d-01*sb3
26470 a2= 0.5349d+01+0.7460d+00*sb +0.2319d+00*sb2-0.2622d+00*sb3
26471 a3= 0.6920d+01-0.3454d+01*sb +0.2027d+01*sb2-0.7626d+00*sb3
26472 a4= 0.1013d+01+0.1423d+00*sb -0.1798d+00*sb2+0.1872d-01*sb3
26473 a5=-0.5465d-01+0.2303d+01*sb -0.9584d+00*sb2+0.3098d+00*sb3
26474 ELSEIF(iprt .EQ. -1) THEN
26475 a0=exp(-0.2328d+01-0.3061d+01*sb +0.3620d+01*sb2-
26476 & 0.1602d+01*sb3)
26477 a1=-0.3358d+00+0.3198d+00*sb -0.4210d+00*sb2+0.1571d+00*sb3
26478 a2= 0.8478d+01-0.3112d+01*sb +0.5243d+01*sb2-0.2255d+01*sb3
26479 a3= 0.1971d+02+0.3389d+00*sb -0.5268d+01*sb2+0.2099d+01*sb3
26480 a4= 0.1128d+01-0.4701d+00*sb +0.7779d+00*sb2-0.3506d+00*sb3
26481 a5=-0.4708d+00+0.3341d+01*sb -0.3375d+01*sb2+0.1353d+01*sb3
26482 ELSEIF(iprt .EQ. -2) THEN
26483 a0=exp(-0.2906d+01-0.1069d+00*sb -0.1055d+01*sb2+
26484 & 0.2496d+00*sb3)
26485 a1=-0.2875d+00+0.6571d-01*sb -0.1987d-01*sb2-0.1800d-02*sb3
26486 a2= 0.9854d+01-0.2715d+00*sb -0.7407d+00*sb2+0.2888d+00*sb3
26487 a3= 0.1583d+02-0.7687d+01*sb +0.3428d+01*sb2-0.3327d+00*sb3
26488 a4= 0.9763d+00+0.7599d-01*sb -0.2128d+00*sb2+0.6852d-01*sb3
26489 a5=-0.8444d-02+0.9434d+00*sb +0.4152d+00*sb2-0.1481d+00*sb3
26490 ELSEIF(iprt .EQ. -3) THEN
26491 a0=exp(-0.3780d+01+0.2499d+01*sb -0.4962d+01*sb2+
26492 & 0.1936d+01*sb3)
26493 a1=-0.2639d+00-0.1575d+00*sb +0.3584d+00*sb2-0.1646d+00*sb3
26494 a2= 0.8082d+01+0.2794d+01*sb -0.5438d+01*sb2+0.2321d+01*sb3
26495 a3= 0.1811d+02-0.2000d+02*sb +0.1951d+02*sb2-0.6904d+01*sb3
26496 a4= 0.9822d+00+0.4972d+00*sb -0.8690d+00*sb2+0.3415d+00*sb3
26497 a5= 0.1772d+00-0.6078d+00*sb +0.3341d+01*sb2-0.1473d+01*sb3
26498 ELSEIF(iprt .EQ. -4) THEN
26499 a0=sb** 0.1122d+01*exp(-0.4232d+01-0.1808d+01*sb +
26500 & 0.5348d+00*sb2)
26501 a1=-0.2824d+00+0.5846d+00*sb -0.7230d+00*sb2+0.2419d+00*sb3
26502 a2= 0.5683d+01-0.2948d+01*sb +0.5916d+01*sb2-0.2560d+01*sb3
26503 a3= 0.2051d+01+0.4795d+01*sb -0.4271d+01*sb2+0.4174d+00*sb3
26504 a4= 0.1737d+00+0.1717d+01*sb -0.1978d+01*sb2+0.6643d+00*sb3
26505 a5= 0.8689d+00+0.3500d+01*sb -0.3283d+01*sb2+0.1026d+01*sb3
26506 ELSEIF(iprt .EQ. -5) THEN
26507 a0=sb** 0.9906d+00*exp(-0.1496d+01-0.6576d+01*sb +
26508 & 0.1569d+01*sb2)
26509 a1=-0.2140d+00-0.6419d-01*sb -0.2741d-02*sb2+0.3185d-02*sb3
26510 a2= 0.5781d+01+0.1049d+00*sb -0.3930d+00*sb2+0.5174d+00*sb3
26511 a3=-0.9420d+00+0.5511d+00*sb +0.8817d+00*sb2+0.1903d+01*sb3
26512 a4= 0.2418d-01+0.4232d-01*sb -0.1244d-01*sb2-0.2365d-01*sb3
26513 a5= 0.7664d+00+0.1794d+01*sb -0.4917d+00*sb2-0.1284d+00*sb3
26514 ELSEIF(iprt .EQ. -6) THEN
26515 a0=sb** 0.1000d+01*exp(-0.8460d+01+0.1154d+01*sb +
26516 & 0.8838d+01*sb2)
26517 a1=-0.4316d-01-0.2976d+00*sb +0.3174d+00*sb2-0.1429d+01*sb3
26518 a2= 0.4910d+01+0.2273d+01*sb +0.5631d+01*sb2-0.1994d+02*sb3
26519 a3= 0.1190d+02-0.2000d+02*sb -0.2000d+02*sb2+0.1292d+02*sb3
26520 a4= 0.5771d+00-0.2552d+00*sb +0.7510d+00*sb2+0.6923d+00*sb3
26521 a5= 0.4402d+01-0.1627d+01*sb -0.2085d+01*sb2-0.6737d+01*sb3
26522 ENDIF
26523
26524C...Expansion for CTEQ3D.
26525 ELSEIF(iset .EQ. 3) THEN
26526 IF(iprt .EQ. 2) THEN
26527 a0=exp( 0.2148d+00+0.5814d-01*sb +0.2734d+00*sb2-
26528 & 0.2902d+00*sb3)
26529 a1= 0.4810d+00+0.1657d-01*sb -0.3800d-01*sb2+0.3125d-01*sb3
26530 a2= 0.3509d+01+0.3923d+00*sb +0.4010d+00*sb2-0.1932d+00*sb3
26531 a3= 0.7055d+01-0.6552d+01*sb +0.3466d+01*sb2-0.5657d+00*sb3
26532 a4= 0.1061d+01-0.3453d+00*sb +0.4089d+00*sb2-0.1817d+00*sb3
26533 a5= 0.8687d-01+0.2548d+00*sb -0.2967d+00*sb2+0.2647d+00*sb3
26534 ELSEIF(iprt .EQ. 1) THEN
26535 a0=exp( 0.3961d+00+0.4914d+00*sb -0.1728d+01*sb2+
26536 & 0.7257d+00*sb3)
26537 a1= 0.4162d+00-0.1419d+00*sb +0.3680d+00*sb2-0.1618d+00*sb3
26538 a2= 0.3248d+01+0.3028d+01*sb -0.4307d+01*sb2+0.1920d+01*sb3
26539 a3=-0.1100d+01+0.2184d+01*sb -0.3820d+01*sb2+0.1717d+01*sb3
26540 a4= 0.2082d+01-0.2756d+00*sb +0.3043d+00*sb2-0.1260d+00*sb3
26541 a5=-0.4822d+00-0.5706d+00*sb +0.2243d+01*sb2-0.9760d+00*sb3
26542 ELSEIF(iprt .EQ. 0) THEN
26543 a0=exp(-0.4665d+00-0.7554d+00*sb -0.3323d+00*sb2-
26544 & 0.2734d-04*sb3)
26545 a1=-0.3359d+00+0.2395d+00*sb -0.2377d+00*sb2+0.7059d-01*sb3
26546 a2= 0.5451d+01+0.6086d+00*sb +0.8606d-01*sb2-0.1425d+00*sb3
26547 a3= 0.1026d+02-0.9352d+01*sb +0.4879d+01*sb2-0.1150d+01*sb3
26548 a4= 0.9935d+00-0.5017d-01*sb -0.1707d-01*sb2-0.1464d-02*sb3
26549 a5=-0.4160d-01+0.2305d+01*sb -0.1063d+01*sb2+0.3211d+00*sb3
26550 ELSEIF(iprt .EQ. -1) THEN
26551 a0=exp(-0.2714d+01-0.2868d+01*sb +0.3700d+01*sb2-
26552 & 0.1671d+01*sb3)
26553 a1=-0.3893d+00+0.3341d+00*sb -0.3897d+00*sb2+0.1420d+00*sb3
26554 a2= 0.8359d+01-0.3267d+01*sb +0.5327d+01*sb2-0.2245d+01*sb3
26555 a3= 0.2359d+02-0.5669d+01*sb -0.4602d+01*sb2+0.3153d+01*sb3
26556 a4= 0.1106d+01-0.4745d+00*sb +0.7739d+00*sb2-0.3417d+00*sb3
26557 a5=-0.5557d+00+0.3433d+01*sb -0.3390d+01*sb2+0.1354d+01*sb3
26558 ELSEIF(iprt .EQ. -2) THEN
26559 a0=exp(-0.3323d+01+0.2296d+00*sb -0.1109d+01*sb2+
26560 & 0.2223d+00*sb3)
26561 a1=-0.3410d+00+0.8847d-01*sb -0.1111d-01*sb2-0.5927d-02*sb3
26562 a2= 0.9753d+01-0.5182d+00*sb -0.4670d+00*sb2+0.1921d+00*sb3
26563 a3= 0.1977d+02-0.1600d+02*sb +0.9481d+01*sb2-0.1864d+01*sb3
26564 a4= 0.9818d+00+0.2839d-02*sb -0.1188d+00*sb2+0.3584d-01*sb3
26565 a5=-0.7934d-01+0.1004d+01*sb +0.3704d+00*sb2-0.1220d+00*sb3
26566 ELSEIF(iprt .EQ. -3) THEN
26567 a0=exp(-0.3985d+01+0.2855d+01*sb -0.5208d+01*sb2+
26568 & 0.1937d+01*sb3)
26569 a1=-0.3337d+00-0.1150d+00*sb +0.3691d+00*sb2-0.1709d+00*sb3
26570 a2= 0.7968d+01+0.3641d+01*sb -0.6599d+01*sb2+0.2642d+01*sb3
26571 a3= 0.1873d+02-0.1999d+02*sb +0.1734d+02*sb2-0.5813d+01*sb3
26572 a4= 0.9731d+00+0.5082d+00*sb -0.8780d+00*sb2+0.3231d+00*sb3
26573 a5=-0.5542d-01-0.4189d+00*sb +0.3309d+01*sb2-0.1439d+01*sb3
26574 ELSEIF(iprt .EQ. -4) THEN
26575 a0=sb** 0.1105d+01*exp(-0.3952d+01-0.1901d+01*sb +
26576 & 0.5137d+00*sb2)
26577 a1=-0.3543d+00+0.6055d+00*sb -0.6941d+00*sb2+0.2278d+00*sb3
26578 a2= 0.5955d+01-0.2629d+01*sb +0.5337d+01*sb2-0.2300d+01*sb3
26579 a3= 0.1933d+01+0.4882d+01*sb -0.3810d+01*sb2+0.2290d+00*sb3
26580 a4= 0.1806d+00+0.1655d+01*sb -0.1893d+01*sb2+0.6395d+00*sb3
26581 a5= 0.4790d+00+0.3612d+01*sb -0.3152d+01*sb2+0.9684d+00*sb3
26582 ELSEIF(iprt .EQ. -5) THEN
26583 a0=sb** 0.9818d+00*exp(-0.1825d+01-0.7464d+01*sb +
26584 & 0.2143d+01*sb2)
26585 a1=-0.2604d+00-0.1400d+00*sb +0.1702d+00*sb2-0.8476d-01*sb3
26586 a2= 0.6005d+01+0.6275d+00*sb -0.2535d+01*sb2+0.2219d+01*sb3
26587 a3=-0.9067d+00+0.1149d+01*sb +0.1974d+01*sb2+0.4716d+01*sb3
26588 a4= 0.3915d-01+0.5945d-01*sb -0.9844d-01*sb2+0.2783d-01*sb3
26589 a5= 0.5500d+00+0.1994d+01*sb -0.6727d+00*sb2-0.1510d+00*sb3
26590 ELSEIF(iprt .EQ. -6) THEN
26591 a0=sb** 0.1002d+01*exp(-0.8553d+01+0.3793d+00*sb +
26592 & 0.9998d+01*sb2)
26593 a1=-0.5870d-01-0.2792d+00*sb +0.6526d+00*sb2-0.1984d+01*sb3
26594 a2= 0.4716d+01+0.4473d+00*sb +0.1128d+02*sb2-0.1937d+02*sb3
26595 a3= 0.1289d+02-0.1742d+02*sb -0.1983d+02*sb2-0.9274d+00*sb3
26596 a4= 0.5647d+00-0.2732d+00*sb +0.1074d+01*sb2+0.5981d+00*sb3
26597 a5= 0.4390d+01-0.1262d+01*sb -0.9026d+00*sb2-0.9394d+01*sb3
26598 ENDIF
26599 ENDIF
26600
26601C...Calculation of x * f(x, Q).
26602 pycteq = max(0d0, a0 *(x**a1) *((1d0-x)**a2) *(1d0+a3*(x**a4))
26603 & *(log(1d0+1d0/x))**a5 )
26604
26605 RETURN
26606 END
26607
26608C*********************************************************************
26609
26610C...PYGRVL
26611C...Gives the GRV 94 L (leading order) parton distribution function set
26612C...in parametrized form.
26613C...Authors: M. Glueck, E. Reya and A. Vogt.
26614
26615 SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26616
26617C...Double precision declaration.
26618 IMPLICIT DOUBLE PRECISION (a - z)
26619
26620C...Common expressions.
26621 mu2 = 0.23d0
26622 lam2 = 0.2322d0 * 0.2322d0
26623 s = log(log(q2/lam2) / log(mu2/lam2))
26624 ds = sqrt(s)
26625 s2 = s * s
26626 s3 = s2 * s
26627
26628C...uv :
26629 nu = 2.284d0 + 0.802d0 * s + 0.055d0 * s2
26630 aku = 0.590d0 - 0.024d0 * s
26631 bku = 0.131d0 + 0.063d0 * s
26632 au = -0.449d0 - 0.138d0 * s - 0.076d0 * s2
26633 bu = 0.213d0 + 2.669d0 * s - 0.728d0 * s2
26634 cu = 8.854d0 - 9.135d0 * s + 1.979d0 * s2
26635 du = 2.997d0 + 0.753d0 * s - 0.076d0 * s2
26636 uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
26637
26638C...dv :
26639 nd = 0.371d0 + 0.083d0 * s + 0.039d0 * s2
26640 akd = 0.376d0
26641 bkd = 0.486d0 + 0.062d0 * s
26642 ad = -0.509d0 + 3.310d0 * s - 1.248d0 * s2
26643 bd = 12.41d0 - 10.52d0 * s + 2.267d0 * s2
26644 cd = 6.373d0 - 6.208d0 * s + 1.418d0 * s2
26645 dd = 3.691d0 + 0.799d0 * s - 0.071d0 * s2
26646 dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
26647
26648C...del :
26649 ne = 0.082d0 + 0.014d0 * s + 0.008d0 * s2
26650 ake = 0.409d0 - 0.005d0 * s
26651 bke = 0.799d0 + 0.071d0 * s
26652 ae = -38.07d0 + 36.13d0 * s - 0.656d0 * s2
26653 be = 90.31d0 - 74.15d0 * s + 7.645d0 * s2
26654 ce = 0.0d0
26655 de = 7.486d0 + 1.217d0 * s - 0.159d0 * s2
26656 del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
26657
26658C...udb :
26659 alx = 1.451d0
26660 bex = 0.271d0
26661 akx = 0.410d0 - 0.232d0 * s
26662 bkx = 0.534d0 - 0.457d0 * s
26663 agx = 0.890d0 - 0.140d0 * s
26664 bgx = -0.981d0
26665 cx = 0.320d0 + 0.683d0 * s
26666 dx = 4.752d0 + 1.164d0 * s + 0.286d0 * s2
26667 ex = 4.119d0 + 1.713d0 * s
26668 esx = 0.682d0 + 2.978d0 * s
26669 udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
26670 & dx, ex, esx)
26671
26672C...sb :
26673 sts = 0d0
26674 als = 0.914d0
26675 bes = 0.577d0
26676 aks = 1.798d0 - 0.596d0 * s
26677 as = -5.548d0 + 3.669d0 * ds - 0.616d0 * s
26678 bs = 18.92d0 - 16.73d0 * ds + 5.168d0 * s
26679 dst = 6.379d0 - 0.350d0 * s + 0.142d0 * s2
26680 est = 3.981d0 + 1.638d0 * s
26681 ess = 6.402d0
26682 sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
26683
26684C...cb :
26685 stc = 0.888d0
26686 alc = 1.01d0
26687 bec = 0.37d0
26688 akc = 0d0
26689 ac = 0d0
26690 bc = 4.24d0 - 0.804d0 * s
26691 dct = 3.46d0 - 1.076d0 * s
26692 ect = 4.61d0 + 1.49d0 * s
26693 esc = 2.555d0 + 1.961d0 * s
26694 chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
26695
26696C...bb :
26697 stb = 1.351d0
26698 alb = 1.00d0
26699 beb = 0.51d0
26700 akb = 0d0
26701 ab = 0d0
26702 bb = 1.848d0
26703 dbt = 2.929d0 + 1.396d0 * s
26704 ebt = 4.71d0 + 1.514d0 * s
26705 esb = 4.02d0 + 1.239d0 * s
26706 bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
26707
26708C...gl :
26709 alg = 0.524d0
26710 beg = 1.088d0
26711 akg = 1.742d0 - 0.930d0 * s
26712 bkg = - 0.399d0 * s2
26713 ag = 7.486d0 - 2.185d0 * s
26714 bg = 16.69d0 - 22.74d0 * s + 5.779d0 * s2
26715 cg = -25.59d0 + 29.71d0 * s - 7.296d0 * s2
26716 dg = 2.792d0 + 2.215d0 * s + 0.422d0 * s2 - 0.104d0 * s3
26717 eg = 0.807d0 + 2.005d0 * s
26718 esg = 3.841d0 + 0.316d0 * s
26719 gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg,
26720 & dg, eg, esg)
26721
26722 RETURN
26723 END
26724
26725C*********************************************************************
26726
26727C...PYGRVM
26728C...Gives the GRV 94 M (MSbar) parton distribution function set
26729C...in parametrized form.
26730C...Authors: M. Glueck, E. Reya and A. Vogt.
26731
26732 SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26733
26734C...Double precision declaration.
26735 IMPLICIT DOUBLE PRECISION (a - z)
26736
26737C...Common expressions.
26738 mu2 = 0.34d0
26739 lam2 = 0.248d0 * 0.248d0
26740 s = log(log(q2/lam2) / log(mu2/lam2))
26741 ds = sqrt(s)
26742 s2 = s * s
26743 s3 = s2 * s
26744
26745C...uv :
26746 nu = 1.304d0 + 0.863d0 * s
26747 aku = 0.558d0 - 0.020d0 * s
26748 bku = 0.183d0 * s
26749 au = -0.113d0 + 0.283d0 * s - 0.321d0 * s2
26750 bu = 6.843d0 - 5.089d0 * s + 2.647d0 * s2 - 0.527d0 * s3
26751 cu = 7.771d0 - 10.09d0 * s + 2.630d0 * s2
26752 du = 3.315d0 + 1.145d0 * s - 0.583d0 * s2 + 0.154d0 * s3
26753 uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
26754
26755C...dv :
26756 nd = 0.102d0 - 0.017d0 * s + 0.005d0 * s2
26757 akd = 0.270d0 - 0.019d0 * s
26758 bkd = 0.260d0
26759 ad = 2.393d0 + 6.228d0 * s - 0.881d0 * s2
26760 bd = 46.06d0 + 4.673d0 * s - 14.98d0 * s2 + 1.331d0 * s3
26761 cd = 17.83d0 - 53.47d0 * s + 21.24d0 * s2
26762 dd = 4.081d0 + 0.976d0 * s - 0.485d0 * s2 + 0.152d0 * s3
26763 dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
26764
26765C...del :
26766 ne = 0.070d0 + 0.042d0 * s - 0.011d0 * s2 + 0.004d0 * s3
26767 ake = 0.409d0 - 0.007d0 * s
26768 bke = 0.782d0 + 0.082d0 * s
26769 ae = -29.65d0 + 26.49d0 * s + 5.429d0 * s2
26770 be = 90.20d0 - 74.97d0 * s + 4.526d0 * s2
26771 ce = 0.0d0
26772 de = 8.122d0 + 2.120d0 * s - 1.088d0 * s2 + 0.231d0 * s3
26773 del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
26774
26775C...udb :
26776 alx = 0.877d0
26777 bex = 0.561d0
26778 akx = 0.275d0
26779 bkx = 0.0d0
26780 agx = 0.997d0
26781 bgx = 3.210d0 - 1.866d0 * s
26782 cx = 7.300d0
26783 dx = 9.010d0 + 0.896d0 * ds + 0.222d0 * s2
26784 ex = 3.077d0 + 1.446d0 * s
26785 esx = 3.173d0 - 2.445d0 * ds + 2.207d0 * s
26786 udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
26787 & dx, ex, esx)
26788
26789C...sb :
26790 sts = 0d0
26791 als = 0.756d0
26792 bes = 0.216d0
26793 aks = 1.690d0 + 0.650d0 * ds - 0.922d0 * s
26794 as = -4.329d0 + 1.131d0 * s
26795 bs = 9.568d0 - 1.744d0 * s
26796 dst = 9.377d0 + 1.088d0 * ds - 1.320d0 * s + 0.130d0 * s2
26797 est = 3.031d0 + 1.639d0 * s
26798 ess = 5.837d0 + 0.815d0 * s
26799 sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
26800
26801C...cb :
26802 stc = 0.820d0
26803 alc = 0.98d0
26804 bec = 0d0
26805 akc = -0.625d0 - 0.523d0 * s
26806 ac = 0d0
26807 bc = 1.896d0 + 1.616d0 * s
26808 dct = 4.12d0 + 0.683d0 * s
26809 ect = 4.36d0 + 1.328d0 * s
26810 esc = 0.677d0 + 0.679d0 * s
26811 chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
26812
26813C...bb :
26814 stb = 1.297d0
26815 alb = 0.99d0
26816 beb = 0d0
26817 akb = - 0.193d0 * s
26818 ab = 0d0
26819 bb = 0d0
26820 dbt = 3.447d0 + 0.927d0 * s
26821 ebt = 4.68d0 + 1.259d0 * s
26822 esb = 1.892d0 + 2.199d0 * s
26823 bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
26824
26825C...gl :
26826 alg = 1.014d0
26827 beg = 1.738d0
26828 akg = 1.724d0 + 0.157d0 * s
26829 bkg = 0.800d0 + 1.016d0 * s
26830 ag = 7.517d0 - 2.547d0 * s
26831 bg = 34.09d0 - 52.21d0 * ds + 17.47d0 * s
26832 cg = 4.039d0 + 1.491d0 * s
26833 dg = 3.404d0 + 0.830d0 * s
26834 eg = -1.112d0 + 3.438d0 * s - 0.302d0 * s2
26835 esg = 3.256d0 - 0.436d0 * s
26836 gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
26837
26838 RETURN
26839 END
26840
26841C*********************************************************************
26842
26843C...PYGRVD
26844C...Gives the GRV 94 D (DIS) parton distribution function set
26845C...in parametrized form.
26846C...Authors: M. Glueck, E. Reya and A. Vogt.
26847
26848 SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26849
26850C...Double precision declaration.
26851 IMPLICIT DOUBLE PRECISION (a - z)
26852
26853C...Common expressions.
26854 mu2 = 0.34d0
26855 lam2 = 0.248d0 * 0.248d0
26856 s = log(log(q2/lam2) / log(mu2/lam2))
26857 ds = sqrt(s)
26858 s2 = s * s
26859 s3 = s2 * s
26860
26861C...uv :
26862 nu = 2.484d0 + 0.116d0 * s + 0.093d0 * s2
26863 aku = 0.563d0 - 0.025d0 * s
26864 bku = 0.054d0 + 0.154d0 * s
26865 au = -0.326d0 - 0.058d0 * s - 0.135d0 * s2
26866 bu = -3.322d0 + 8.259d0 * s - 3.119d0 * s2 + 0.291d0 * s3
26867 cu = 11.52d0 - 12.99d0 * s + 3.161d0 * s2
26868 du = 2.808d0 + 1.400d0 * s - 0.557d0 * s2 + 0.119d0 * s3
26869 uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
26870
26871C...dv :
26872 nd = 0.156d0 - 0.017d0 * s
26873 akd = 0.299d0 - 0.022d0 * s
26874 bkd = 0.259d0 - 0.015d0 * s
26875 ad = 3.445d0 + 1.278d0 * s + 0.326d0 * s2
26876 bd = -6.934d0 + 37.45d0 * s - 18.95d0 * s2 + 1.463d0 * s3
26877 cd = 55.45d0 - 69.92d0 * s + 20.78d0 * s2
26878 dd = 3.577d0 + 1.441d0 * s - 0.683d0 * s2 + 0.179d0 * s3
26879 dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
26880
26881C...del :
26882 ne = 0.099d0 + 0.019d0 * s + 0.002d0 * s2
26883 ake = 0.419d0 - 0.013d0 * s
26884 bke = 1.064d0 - 0.038d0 * s
26885 ae = -44.00d0 + 98.70d0 * s - 14.79d0 * s2
26886 be = 28.59d0 - 40.94d0 * s - 13.66d0 * s2 + 2.523d0 * s3
26887 ce = 84.57d0 - 108.8d0 * s + 31.52d0 * s2
26888 de = 7.469d0 + 2.480d0 * s - 0.866d0 * s2
26889 del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
26890
26891C...udb :
26892 alx = 1.215d0
26893 bex = 0.466d0
26894 akx = 0.326d0 + 0.150d0 * s
26895 bkx = 0.956d0 + 0.405d0 * s
26896 agx = 0.272d0
26897 bgx = 3.794d0 - 2.359d0 * ds
26898 cx = 2.014d0
26899 dx = 7.941d0 + 0.534d0 * ds - 0.940d0 * s + 0.410d0 * s2
26900 ex = 3.049d0 + 1.597d0 * s
26901 esx = 4.396d0 - 4.594d0 * ds + 3.268d0 * s
26902 udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
26903 & dx, ex, esx)
26904
26905C...sb :
26906 sts = 0d0
26907 als = 0.175d0
26908 bes = 0.344d0
26909 aks = 1.415d0 - 0.641d0 * ds
26910 as = 0.580d0 - 9.763d0 * ds + 6.795d0 * s - 0.558d0 * s2
26911 bs = 5.617d0 + 5.709d0 * ds - 3.972d0 * s
26912 dst = 13.78d0 - 9.581d0 * s + 5.370d0 * s2 - 0.996d0 * s3
26913 est = 4.546d0 + 0.372d0 * s2
26914 ess = 5.053d0 - 1.070d0 * s + 0.805d0 * s2
26915 sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
26916
26917C...cb :
26918 stc = 0.820d0
26919 alc = 0.98d0
26920 bec = 0d0
26921 akc = -0.625d0 - 0.523d0 * s
26922 ac = 0d0
26923 bc = 1.896d0 + 1.616d0 * s
26924 dct = 4.12d0 + 0.683d0 * s
26925 ect = 4.36d0 + 1.328d0 * s
26926 esc = 0.677d0 + 0.679d0 * s
26927 chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
26928
26929C...bb :
26930 stb = 1.297d0
26931 alb = 0.99d0
26932 beb = 0d0
26933 akb = - 0.193d0 * s
26934 ab = 0d0
26935 bb = 0d0
26936 dbt = 3.447d0 + 0.927d0 * s
26937 ebt = 4.68d0 + 1.259d0 * s
26938 esb = 1.892d0 + 2.199d0 * s
26939 bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
26940
26941C...gl :
26942 alg = 1.258d0
26943 beg = 1.846d0
26944 akg = 2.423d0
26945 bkg = 2.427d0 + 1.311d0 * s - 0.153d0 * s2
26946 ag = 25.09d0 - 7.935d0 * s
26947 bg = -14.84d0 - 124.3d0 * ds + 72.18d0 * s
26948 cg = 590.3d0 - 173.8d0 * s
26949 dg = 5.196d0 + 1.857d0 * s
26950 eg = -1.648d0 + 3.988d0 * s - 0.432d0 * s2
26951 esg = 3.232d0 - 0.542d0 * s
26952 gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
26953
26954 RETURN
26955 END
26956
26957C*********************************************************************
26958
26959C...PYGRVV
26960C...Auxiliary for the GRV 94 parton distribution functions
26961C...for u and d valence and d-u sea.
26962C...Authors: M. Glueck, E. Reya and A. Vogt.
26963
26964 FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)
26965
26966C...Double precision declaration.
26967 IMPLICIT DOUBLE PRECISION (a - z)
26968
26969C...Evaluation.
26970 dx = sqrt(x)
26971 pygrvv = n * x**ak * (1d0+ a*x**bk + x * (b + c*dx)) *
26972 & (1d0- x)**d
26973
26974 RETURN
26975 END
26976
26977C*********************************************************************
26978
26979C...PYGRVW
26980C...Auxiliary for the GRV 94 parton distribution functions
26981C...for d+u sea and gluon.
26982C...Authors: M. Glueck, E. Reya and A. Vogt.
26983
26984 FUNCTION pygrvw (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
26985
26986C...Double precision declaration.
26987 IMPLICIT DOUBLE PRECISION (a - z)
26988
26989C...Evaluation.
26990 lx = log(1d0/x)
26991 pygrvw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al
26992 & * exp(-e + sqrt(es * s**be * lx))) * (1d0- x)**d
26993
26994 RETURN
26995 END
26996
26997C*********************************************************************
26998
26999C...PYGRVS
27000C...Auxiliary for the GRV 94 parton distribution functions
27001C...for s, c and b sea.
27002C...Authors: M. Glueck, E. Reya and A. Vogt.
27003
27004 FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
27005
27006C...Double precision declaration.
27007 IMPLICIT DOUBLE PRECISION (a - z)
27008
27009C...Evaluation.
27010 IF(s.LE.sth) THEN
27011 pygrvs = 0d0
27012 ELSE
27013 dx = sqrt(x)
27014 lx = log(1d0/x)
27015 pygrvs = (s - sth)**al / lx**ak * (1d0+ ag*dx + b*x) *
27016 & (1d0- x)**d * exp(-e + sqrt(es * s**be * lx))
27017 ENDIF
27018
27019 RETURN
27020 END
27021
27022C*********************************************************************
27023
27024C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
27025C...in Parametrized Form
27026C... September 15, 1999
27027C
27028C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
27029C... CTEQ5 PPARTON DISTRIBUTIONS"
27030C...hep-ph/9903282
27031
27032C...The CTEQ5M1 set given here is an updated version of the original
27033C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
27034C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
27035C...almost all applications.
27036C...The improvement is in the QCD evolution which is now more
27037C...accurate, and which agrees completely with the benchmark work
27038C...of the HERA 96/97 Workshop.
27039C...The differences between the parametrized and the corresponding
27040C...table versions (on which it is based) are of similar order as
27041C...between the two version.
27042
27043C...!! Because accurate parametrizations over a wide range of (x,Q)
27044C...is hard to obtain, only the most widely used sets CTEQ5M and
27045C...CTEQ5L are available in parametrized form for now.
27046
27047C...These parametrizations were obtained by Jon Pumplin.
27048
27049C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
27050C -------------------------------------------------------------------
27051C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
27052C 3 CTEQ5L Leading Order 0.127 192 146
27053C -------------------------------------------------------------------
27054C...Note the Qcd-lambda values given for CTEQ5L is for the leading
27055C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
27056C...calibration.
27057
27058C...The two Iset value are adopted to agree with the standard table
27059C...versions.
27060
27061C...Range of validity:
27062C...The range of (x, Q) covered by this parametrization of the QCD
27063C...evolved parton distributions is 1E-6 < x < 1 ;
27064C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
27065C...data only in a subset of that region; and the assumed DGLAP
27066C...evolution is unlikely to be valid for all of it either.
27067
27068C...The range of (x, Q) used in the CTEQ5 round of global analysis is
27069C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
27070C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
27071C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
27072
27073C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
27074
27075C...PYCT5L
27076C...Auxiliary function for parametrization of CTEQ5L.
27077C...Author: J. Pumplin 9/99.
27078
27079 FUNCTION pyct5l(IFL,X,Q)
27080
27081C...Double precision declaration.
27082 IMPLICIT DOUBLE PRECISION(a-h, o-z)
27083 IMPLICIT INTEGER(I-N)
27084
27085 parameter(nex=8, nlf=2)
27086 dimension am(0:nex,0:nlf,-5:2)
27087 dimension alfvec(-5:2), qmavec(-5:2)
27088 dimension mexvec(-5:2), mlfvec(-5:2)
27089 dimension ut1vec(-5:2), ut2vec(-5:2)
27090 dimension af(0:nex)
27091
27092 DATA mexvec( 2) / 8 /
27093 DATA mlfvec( 2) / 2 /
27094 DATA ut1vec( 2) / 0.4971265e+01 /
27095 DATA ut2vec( 2) / -0.1105128e+01 /
27096 DATA alfvec( 2) / 0.2987216e+00 /
27097 DATA qmavec( 2) / 0.0000000e+00 /
27098 DATA (am( 0,k, 2),k=0, 2)
27099 & / 0.5292616e+01, -0.2751910e+01, -0.2488990e+01 /
27100 DATA (am( 1,k, 2),k=0, 2)
27101 & / 0.9714424e+00, 0.1011827e-01, -0.1023660e-01 /
27102 DATA (am( 2,k, 2),k=0, 2)
27103 & / -0.1651006e+02, 0.7959721e+01, 0.8810563e+01 /
27104 DATA (am( 3,k, 2),k=0, 2)
27105 & / -0.1643394e+02, 0.5892854e+01, 0.9348874e+01 /
27106 DATA (am( 4,k, 2),k=0, 2)
27107 & / 0.3067422e+02, 0.4235796e+01, -0.5112136e+00 /
27108 DATA (am( 5,k, 2),k=0, 2)
27109 & / 0.2352526e+02, -0.5305168e+01, -0.1169174e+02 /
27110 DATA (am( 6,k, 2),k=0, 2)
27111 & / -0.1095451e+02, 0.3006577e+01, 0.5638136e+01 /
27112 DATA (am( 7,k, 2),k=0, 2)
27113 & / -0.1172251e+02, -0.2183624e+01, 0.4955794e+01 /
27114 DATA (am( 8,k, 2),k=0, 2)
27115 & / 0.1662533e-01, 0.7622870e-02, -0.4895887e-03 /
27116
27117 DATA mexvec( 1) / 8 /
27118 DATA mlfvec( 1) / 2 /
27119 DATA ut1vec( 1) / 0.2612618e+01 /
27120 DATA ut2vec( 1) / -0.1258304e+06 /
27121 DATA alfvec( 1) / 0.3407552e+00 /
27122 DATA qmavec( 1) / 0.0000000e+00 /
27123 DATA (am( 0,k, 1),k=0, 2)
27124 & / 0.9905300e+00, -0.4502235e+00, 0.1624441e+00 /
27125 DATA (am( 1,k, 1),k=0, 2)
27126 & / 0.8867534e+00, 0.1630829e-01, -0.4049085e-01 /
27127 DATA (am( 2,k, 1),k=0, 2)
27128 & / 0.8547974e+00, 0.3336301e+00, 0.1371388e+00 /
27129 DATA (am( 3,k, 1),k=0, 2)
27130 & / 0.2941113e+00, -0.1527905e+01, 0.2331879e+00 /
27131 DATA (am( 4,k, 1),k=0, 2)
27132 & / 0.3384235e+02, 0.3715315e+01, 0.8276930e+00 /
27133 DATA (am( 5,k, 1),k=0, 2)
27134 & / 0.6230115e+01, 0.3134639e+01, -0.1729099e+01 /
27135 DATA (am( 6,k, 1),k=0, 2)
27136 & / -0.1186928e+01, -0.3282460e+00, 0.1052020e+00 /
27137 DATA (am( 7,k, 1),k=0, 2)
27138 & / -0.8545702e+01, -0.6247947e+01, 0.3692561e+01 /
27139 DATA (am( 8,k, 1),k=0, 2)
27140 & / 0.1724598e-01, 0.7120465e-02, 0.4003646e-04 /
27141
27142 DATA mexvec( 0) / 8 /
27143 DATA mlfvec( 0) / 2 /
27144 DATA ut1vec( 0) / -0.4656819e+00 /
27145 DATA ut2vec( 0) / -0.2742390e+03 /
27146 DATA alfvec( 0) / 0.4491863e+00 /
27147 DATA qmavec( 0) / 0.0000000e+00 /
27148 DATA (am( 0,k, 0),k=0, 2)
27149 & / 0.1193572e+03, -0.3886845e+01, -0.1133965e+01 /
27150 DATA (am( 1,k, 0),k=0, 2)
27151 & / -0.9421449e+02, 0.3995885e+01, 0.1607363e+01 /
27152 DATA (am( 2,k, 0),k=0, 2)
27153 & / 0.4206383e+01, 0.2485954e+00, 0.2497468e+00 /
27154 DATA (am( 3,k, 0),k=0, 2)
27155 & / 0.1210557e+03, -0.3015765e+01, -0.1423651e+01 /
27156 DATA (am( 4,k, 0),k=0, 2)
27157 & / -0.1013897e+03, -0.7113478e+00, 0.2621865e+00 /
27158 DATA (am( 5,k, 0),k=0, 2)
27159 & / -0.1312404e+01, -0.9297691e+00, -0.1562531e+00 /
27160 DATA (am( 6,k, 0),k=0, 2)
27161 & / 0.1627137e+01, 0.4954111e+00, -0.6387009e+00 /
27162 DATA (am( 7,k, 0),k=0, 2)
27163 & / 0.1537698e+00, -0.2487878e+00, 0.8305947e+00 /
27164 DATA (am( 8,k, 0),k=0, 2)
27165 & / 0.2496448e-01, 0.2457823e-02, 0.8234276e-03 /
27166
27167 DATA mexvec(-1) / 8 /
27168 DATA mlfvec(-1) / 2 /
27169 DATA ut1vec(-1) / 0.3862583e+01 /
27170 DATA ut2vec(-1) / -0.1265969e+01 /
27171 DATA alfvec(-1) / 0.2457668e+00 /
27172 DATA qmavec(-1) / 0.0000000e+00 /
27173 DATA (am( 0,k,-1),k=0, 2)
27174 & / 0.2647441e+02, 0.1059277e+02, -0.9176654e+00 /
27175 DATA (am( 1,k,-1),k=0, 2)
27176 & / 0.1990636e+01, 0.8558918e-01, 0.4248667e-01 /
27177 DATA (am( 2,k,-1),k=0, 2)
27178 & / -0.1476095e+02, -0.3276255e+02, 0.1558110e+01 /
27179 DATA (am( 3,k,-1),k=0, 2)
27180 & / -0.2966889e+01, -0.3649037e+02, 0.1195914e+01 /
27181 DATA (am( 4,k,-1),k=0, 2)
27182 & / -0.1000519e+03, -0.2464635e+01, 0.1964849e+00 /
27183 DATA (am( 5,k,-1),k=0, 2)
27184 & / 0.3718331e+02, 0.4700389e+02, -0.2772142e+01 /
27185 DATA (am( 6,k,-1),k=0, 2)
27186 & / -0.1872722e+02, -0.2291189e+02, 0.1089052e+01 /
27187 DATA (am( 7,k,-1),k=0, 2)
27188 & / -0.1628146e+02, -0.1823993e+02, 0.2537369e+01 /
27189 DATA (am( 8,k,-1),k=0, 2)
27190 & / -0.1156300e+01, -0.1280495e+00, 0.5153245e-01 /
27191
27192 DATA mexvec(-2) / 7 /
27193 DATA mlfvec(-2) / 2 /
27194 DATA ut1vec(-2) / 0.1895615e+00 /
27195 DATA ut2vec(-2) / -0.3069097e+01 /
27196 DATA alfvec(-2) / 0.5293999e+00 /
27197 DATA qmavec(-2) / 0.0000000e+00 /
27198 DATA (am( 0,k,-2),k=0, 2)
27199 & / -0.6556775e+00, 0.2490190e+00, 0.3966485e-01 /
27200 DATA (am( 1,k,-2),k=0, 2)
27201 & / 0.1305102e+01, -0.1188925e+00, -0.4600870e-02 /
27202 DATA (am( 2,k,-2),k=0, 2)
27203 & / -0.2371436e+01, 0.3566814e+00, -0.2834683e+00 /
27204 DATA (am( 3,k,-2),k=0, 2)
27205 & / -0.6152826e+01, 0.8339877e+00, -0.7233230e+00 /
27206 DATA (am( 4,k,-2),k=0, 2)
27207 & / -0.8346558e+01, 0.2892168e+01, 0.2137099e+00 /
27208 DATA (am( 5,k,-2),k=0, 2)
27209 & / 0.1279530e+02, 0.1021114e+00, 0.5787439e+00 /
27210 DATA (am( 6,k,-2),k=0, 2)
27211 & / 0.5858816e+00, -0.1940375e+01, -0.4029269e+00 /
27212 DATA (am( 7,k,-2),k=0, 2)
27213 & / -0.2795725e+02, -0.5263392e+00, 0.1290229e+01 /
27214
27215 DATA mexvec(-3) / 7 /
27216 DATA mlfvec(-3) / 2 /
27217 DATA ut1vec(-3) / 0.3753257e+01 /
27218 DATA ut2vec(-3) / -0.1113085e+01 /
27219 DATA alfvec(-3) / 0.3713141e+00 /
27220 DATA qmavec(-3) / 0.0000000e+00 /
27221 DATA (am( 0,k,-3),k=0, 2)
27222 & / 0.1580931e+01, -0.2273826e+01, -0.1822245e+01 /
27223 DATA (am( 1,k,-3),k=0, 2)
27224 & / 0.2702644e+01, 0.6763243e+00, 0.7231586e-02 /
27225 DATA (am( 2,k,-3),k=0, 2)
27226 & / -0.1857924e+02, 0.3907500e+01, 0.5850109e+01 /
27227 DATA (am( 3,k,-3),k=0, 2)
27228 & / -0.3044793e+02, 0.2639332e+01, 0.5566644e+01 /
27229 DATA (am( 4,k,-3),k=0, 2)
27230 & / -0.4258011e+01, -0.5429244e+01, 0.4418946e+00 /
27231 DATA (am( 5,k,-3),k=0, 2)
27232 & / 0.3465259e+02, -0.5532604e+01, -0.4904153e+01 /
27233 DATA (am( 6,k,-3),k=0, 2)
27234 & / -0.1658858e+02, 0.2923275e+01, 0.2266286e+01 /
27235 DATA (am( 7,k,-3),k=0, 2)
27236 & / -0.1149263e+02, 0.2877475e+01, -0.7999105e+00 /
27237
27238 DATA mexvec(-4) / 7 /
27239 DATA mlfvec(-4) / 2 /
27240 DATA ut1vec(-4) / 0.4400772e+01 /
27241 DATA ut2vec(-4) / -0.1356116e+01 /
27242 DATA alfvec(-4) / 0.3712017e-01 /
27243 DATA qmavec(-4) / 0.1300000e+01 /
27244 DATA (am( 0,k,-4),k=0, 2)
27245 & / -0.8293661e+00, -0.3982375e+01, -0.6494283e-01 /
27246 DATA (am( 1,k,-4),k=0, 2)
27247 & / 0.2754618e+01, 0.8338636e+00, -0.6885160e-01 /
27248 DATA (am( 2,k,-4),k=0, 2)
27249 & / -0.1657987e+02, 0.1439143e+02, -0.6887240e+00 /
27250 DATA (am( 3,k,-4),k=0, 2)
27251 & / -0.2800703e+02, 0.1535966e+02, -0.7377693e+00 /
27252 DATA (am( 4,k,-4),k=0, 2)
27253 & / -0.6460216e+01, -0.4783019e+01, 0.4913297e+00 /
27254 DATA (am( 5,k,-4),k=0, 2)
27255 & / 0.3141830e+02, -0.3178031e+02, 0.7136013e+01 /
27256 DATA (am( 6,k,-4),k=0, 2)
27257 & / -0.1802509e+02, 0.1862163e+02, -0.4632843e+01 /
27258 DATA (am( 7,k,-4),k=0, 2)
27259 & / -0.1240412e+02, 0.2565386e+02, -0.1066570e+02 /
27260
27261 DATA mexvec(-5) / 6 /
27262 DATA mlfvec(-5) / 2 /
27263 DATA ut1vec(-5) / 0.5562568e+01 /
27264 DATA ut2vec(-5) / -0.1801317e+01 /
27265 DATA alfvec(-5) / 0.4952010e-02 /
27266 DATA qmavec(-5) / 0.4500000e+01 /
27267 DATA (am( 0,k,-5),k=0, 2)
27268 & / -0.6031237e+01, 0.1992727e+01, -0.1076331e+01 /
27269 DATA (am( 1,k,-5),k=0, 2)
27270 & / 0.2933912e+01, 0.5839674e+00, 0.7509435e-01 /
27271 DATA (am( 2,k,-5),k=0, 2)
27272 & / -0.8284919e+01, 0.1488593e+01, -0.8251678e+00 /
27273 DATA (am( 3,k,-5),k=0, 2)
27274 & / -0.1925986e+02, 0.2805753e+01, -0.3015446e+01 /
27275 DATA (am( 4,k,-5),k=0, 2)
27276 & / -0.9480483e+01, -0.9767837e+00, -0.1165544e+01 /
27277 DATA (am( 5,k,-5),k=0, 2)
27278 & / 0.2193195e+02, -0.1788518e+02, 0.9460908e+01 /
27279 DATA (am( 6,k,-5),k=0, 2)
27280 & / -0.1327377e+02, 0.1201754e+02, -0.6277844e+01 /
27281
27282 IF(q .LE. qmavec(ifl)) THEN
27283 pyct5l = 0.d0
27284 RETURN
27285 ENDIF
27286
27287 IF(x .GE. 1.d0) THEN
27288 pyct5l = 0.d0
27289 RETURN
27290 ENDIF
27291
27292 tmp = log(q/alfvec(ifl))
27293 IF(tmp .LE. 0.d0) THEN
27294 pyct5l = 0.d0
27295 RETURN
27296 ENDIF
27297
27298 sb = log(tmp)
27299 sb1 = sb - 1.2d0
27300 sb2 = sb1*sb1
27301
27302 DO 110 i = 0, nex
27303 af(i) = 0.d0
27304 sbx = 1.d0
27305 DO 100 k = 0, mlfvec(ifl)
27306 af(i) = af(i) + sbx*am(i,k,ifl)
27307 sbx = sb1*sbx
27308 100 CONTINUE
27309 110 CONTINUE
27310
27311 y = -log(x)
27312 u = log(x/0.00001d0)
27313
27314 part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
27315 part2 = af(0)*(1.d0 - x) + af(3)*x
27316 part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
27317 part4 = ut1vec(ifl)*log(1.d0-x) +
27318 & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
27319
27320 pyct5l = exp(log(x) + part1 + part2 + part3 + part4)
27321
27322C...Include threshold factor.
27323 pyct5l = pyct5l * (1.d0 - qmavec(ifl)/q)
27324
27325 RETURN
27326 END
27327
27328C*********************************************************************
27329
27330C...PYCT5M
27331C...Auxiliary function for parametrization of CTEQ5M1.
27332C...Author: J. Pumplin 9/99.
27333
27334 FUNCTION pyct5m(IFL,X,Q)
27335
27336C...Double precision declaration.
27337 IMPLICIT DOUBLE PRECISION(a-h, o-z)
27338 IMPLICIT INTEGER(I-N)
27339
27340 parameter(nex=8, nlf=2)
27341 dimension am(0:nex,0:nlf,-5:2)
27342 dimension alfvec(-5:2), qmavec(-5:2)
27343 dimension mexvec(-5:2), mlfvec(-5:2)
27344 dimension ut1vec(-5:2), ut2vec(-5:2)
27345 dimension af(0:nex)
27346
27347 DATA mexvec( 2) / 8 /
27348 DATA mlfvec( 2) / 2 /
27349 DATA ut1vec( 2) / 0.5141718e+01 /
27350 DATA ut2vec( 2) / -0.1346944e+01 /
27351 DATA alfvec( 2) / 0.5260555e+00 /
27352 DATA qmavec( 2) / 0.0000000e+00 /
27353 DATA (am( 0,k, 2),k=0, 2)
27354 & / 0.4289071e+01, -0.2536870e+01, -0.1259948e+01 /
27355 DATA (am( 1,k, 2),k=0, 2)
27356 & / 0.9839410e+00, 0.4168426e-01, -0.5018952e-01 /
27357 DATA (am( 2,k, 2),k=0, 2)
27358 & / -0.1651961e+02, 0.9246261e+01, 0.5996400e+01 /
27359 DATA (am( 3,k, 2),k=0, 2)
27360 & / -0.2077936e+02, 0.9786469e+01, 0.7656465e+01 /
27361 DATA (am( 4,k, 2),k=0, 2)
27362 & / 0.3054926e+02, 0.1889536e+01, 0.1380541e+01 /
27363 DATA (am( 5,k, 2),k=0, 2)
27364 & / 0.3084695e+02, -0.1212303e+02, -0.1053551e+02 /
27365 DATA (am( 6,k, 2),k=0, 2)
27366 & / -0.1426778e+02, 0.6239537e+01, 0.5254819e+01 /
27367 DATA (am( 7,k, 2),k=0, 2)
27368 & / -0.1909811e+02, 0.3695678e+01, 0.5495729e+01 /
27369 DATA (am( 8,k, 2),k=0, 2)
27370 & / 0.1889751e-01, 0.5027193e-02, 0.6624896e-03 /
27371
27372 DATA mexvec( 1) / 8 /
27373 DATA mlfvec( 1) / 2 /
27374 DATA ut1vec( 1) / 0.4138426e+01 /
27375 DATA ut2vec( 1) / -0.3221374e+01 /
27376 DATA alfvec( 1) / 0.4960962e+00 /
27377 DATA qmavec( 1) / 0.0000000e+00 /
27378 DATA (am( 0,k, 1),k=0, 2)
27379 & / 0.1332497e+01, -0.3703718e+00, 0.1288638e+00 /
27380 DATA (am( 1,k, 1),k=0, 2)
27381 & / 0.7544687e+00, 0.3255075e-01, -0.4706680e-01 /
27382 DATA (am( 2,k, 1),k=0, 2)
27383 & / -0.7638814e+00, 0.5008313e+00, -0.9237374e-01 /
27384 DATA (am( 3,k, 1),k=0, 2)
27385 & / -0.3689889e+00, -0.1055098e+01, -0.4645065e+00 /
27386 DATA (am( 4,k, 1),k=0, 2)
27387 & / 0.3991610e+02, 0.1979881e+01, 0.1775814e+01 /
27388 DATA (am( 5,k, 1),k=0, 2)
27389 & / 0.6201080e+01, 0.2046288e+01, 0.3804571e+00 /
27390 DATA (am( 6,k, 1),k=0, 2)
27391 & / -0.8027900e+00, -0.7011688e+00, -0.8049612e+00 /
27392 DATA (am( 7,k, 1),k=0, 2)
27393 & / -0.8631305e+01, -0.3981200e+01, 0.6970153e+00 /
27394 DATA (am( 8,k, 1),k=0, 2)
27395 & / 0.2371230e-01, 0.5372683e-02, 0.1118701e-02 /
27396
27397 DATA mexvec( 0) / 8 /
27398 DATA mlfvec( 0) / 2 /
27399 DATA ut1vec( 0) / -0.1026789e+01 /
27400 DATA ut2vec( 0) / -0.9051707e+01 /
27401 DATA alfvec( 0) / 0.9462977e+00 /
27402 DATA qmavec( 0) / 0.0000000e+00 /
27403 DATA (am( 0,k, 0),k=0, 2)
27404 & / 0.1191990e+03, -0.8548739e+00, -0.1963040e+01 /
27405 DATA (am( 1,k, 0),k=0, 2)
27406 & / -0.9449972e+02, 0.1074771e+01, 0.2056055e+01 /
27407 DATA (am( 2,k, 0),k=0, 2)
27408 & / 0.3701064e+01, -0.1167947e-02, 0.1933573e+00 /
27409 DATA (am( 3,k, 0),k=0, 2)
27410 & / 0.1171345e+03, -0.1064540e+01, -0.1875312e+01 /
27411 DATA (am( 4,k, 0),k=0, 2)
27412 & / -0.1014453e+03, -0.5707427e+00, 0.4511242e-01 /
27413 DATA (am( 5,k, 0),k=0, 2)
27414 & / 0.6365168e+01, 0.1275354e+01, -0.4964081e+00 /
27415 DATA (am( 6,k, 0),k=0, 2)
27416 & / -0.3370693e+01, -0.1122020e+01, 0.5947751e-01 /
27417 DATA (am( 7,k, 0),k=0, 2)
27418 & / -0.5327270e+01, -0.9293556e+00, 0.6629940e+00 /
27419 DATA (am( 8,k, 0),k=0, 2)
27420 & / 0.2437513e-01, 0.1600939e-02, 0.6855336e-03 /
27421
27422 DATA mexvec(-1) / 8 /
27423 DATA mlfvec(-1) / 2 /
27424 DATA ut1vec(-1) / 0.5243571e+01 /
27425 DATA ut2vec(-1) / -0.2870513e+01 /
27426 DATA alfvec(-1) / 0.6701448e+00 /
27427 DATA qmavec(-1) / 0.0000000e+00 /
27428 DATA (am( 0,k,-1),k=0, 2)
27429 & / 0.2428863e+02, 0.1907035e+01, -0.4606457e+00 /
27430 DATA (am( 1,k,-1),k=0, 2)
27431 & / 0.2006810e+01, -0.1265915e+00, 0.7153556e-02 /
27432 DATA (am( 2,k,-1),k=0, 2)
27433 & / -0.1884546e+02, -0.2339471e+01, 0.5740679e+01 /
27434 DATA (am( 3,k,-1),k=0, 2)
27435 & / -0.2527892e+02, -0.2044124e+01, 0.1280470e+02 /
27436 DATA (am( 4,k,-1),k=0, 2)
27437 & / -0.1013824e+03, -0.1594199e+01, 0.2216401e+00 /
27438 DATA (am( 5,k,-1),k=0, 2)
27439 & / 0.8070930e+02, 0.1792072e+01, -0.2164364e+02 /
27440 DATA (am( 6,k,-1),k=0, 2)
27441 & / -0.4641050e+02, 0.1977338e+00, 0.1273014e+02 /
27442 DATA (am( 7,k,-1),k=0, 2)
27443 & / -0.3910568e+02, 0.1719632e+01, 0.1086525e+02 /
27444 DATA (am( 8,k,-1),k=0, 2)
27445 & / -0.1185496e+01, -0.1905847e+00, -0.8744118e-03 /
27446
27447 DATA mexvec(-2) / 7 /
27448 DATA mlfvec(-2) / 2 /
27449 DATA ut1vec(-2) / 0.4782210e+01 /
27450 DATA ut2vec(-2) / -0.1976856e+02 /
27451 DATA alfvec(-2) / 0.7558374e+00 /
27452 DATA qmavec(-2) / 0.0000000e+00 /
27453 DATA (am( 0,k,-2),k=0, 2)
27454 & / -0.6216935e+00, 0.2369963e+00, -0.7909949e-02 /
27455 DATA (am( 1,k,-2),k=0, 2)
27456 & / 0.1245440e+01, -0.1031510e+00, 0.4916523e-02 /
27457 DATA (am( 2,k,-2),k=0, 2)
27458 & / -0.7060824e+01, -0.3875283e-01, 0.1784981e+00 /
27459 DATA (am( 3,k,-2),k=0, 2)
27460 & / -0.7430595e+01, 0.1964572e+00, -0.1284999e+00 /
27461 DATA (am( 4,k,-2),k=0, 2)
27462 & / -0.6897810e+01, 0.2620543e+01, 0.8012553e-02 /
27463 DATA (am( 5,k,-2),k=0, 2)
27464 & / 0.1507713e+02, 0.2340307e-01, 0.2482535e+01 /
27465 DATA (am( 6,k,-2),k=0, 2)
27466 & / -0.1815341e+01, -0.1538698e+01, -0.2014208e+01 /
27467 DATA (am( 7,k,-2),k=0, 2)
27468 & / -0.2571932e+02, 0.2903941e+00, -0.2848206e+01 /
27469
27470 DATA mexvec(-3) / 7 /
27471 DATA mlfvec(-3) / 2 /
27472 DATA ut1vec(-3) / 0.4518239e+01 /
27473 DATA ut2vec(-3) / -0.2690590e+01 /
27474 DATA alfvec(-3) / 0.6124079e+00 /
27475 DATA qmavec(-3) / 0.0000000e+00 /
27476 DATA (am( 0,k,-3),k=0, 2)
27477 & / -0.2734458e+01, -0.7245673e+00, -0.6351374e+00 /
27478 DATA (am( 1,k,-3),k=0, 2)
27479 & / 0.2927174e+01, 0.4822709e+00, -0.1088787e-01 /
27480 DATA (am( 2,k,-3),k=0, 2)
27481 & / -0.1771017e+02, -0.1416635e+01, 0.8467622e+01 /
27482 DATA (am( 3,k,-3),k=0, 2)
27483 & / -0.4972782e+02, -0.3348547e+01, 0.1767061e+02 /
27484 DATA (am( 4,k,-3),k=0, 2)
27485 & / -0.7102770e+01, -0.3205337e+01, 0.4101704e+00 /
27486 DATA (am( 5,k,-3),k=0, 2)
27487 & / 0.7169698e+02, -0.2205985e+01, -0.2463931e+02 /
27488 DATA (am( 6,k,-3),k=0, 2)
27489 & / -0.4090347e+02, 0.2103486e+01, 0.1416507e+02 /
27490 DATA (am( 7,k,-3),k=0, 2)
27491 & / -0.2952639e+02, 0.5376136e+01, 0.7825585e+01 /
27492
27493 DATA mexvec(-4) / 7 /
27494 DATA mlfvec(-4) / 2 /
27495 DATA ut1vec(-4) / 0.2783230e+01 /
27496 DATA ut2vec(-4) / -0.1746328e+01 /
27497 DATA alfvec(-4) / 0.1115653e+01 /
27498 DATA qmavec(-4) / 0.1300000e+01 /
27499 DATA (am( 0,k,-4),k=0, 2)
27500 & / -0.1743872e+01, -0.1128921e+01, -0.2841969e+00 /
27501 DATA (am( 1,k,-4),k=0, 2)
27502 & / 0.3345755e+01, 0.3187765e+00, 0.1378124e+00 /
27503 DATA (am( 2,k,-4),k=0, 2)
27504 & / -0.2037615e+02, 0.4121687e+01, 0.2236520e+00 /
27505 DATA (am( 3,k,-4),k=0, 2)
27506 & / -0.4703104e+02, 0.5353087e+01, -0.1455347e+01 /
27507 DATA (am( 4,k,-4),k=0, 2)
27508 & / -0.1060230e+02, -0.1551122e+01, -0.1078863e+01 /
27509 DATA (am( 5,k,-4),k=0, 2)
27510 & / 0.5088892e+02, -0.8197304e+01, 0.8083451e+01 /
27511 DATA (am( 6,k,-4),k=0, 2)
27512 & / -0.2819070e+02, 0.4554086e+01, -0.5890995e+01 /
27513 DATA (am( 7,k,-4),k=0, 2)
27514 & / -0.1098238e+02, 0.2590096e+01, -0.8062879e+01 /
27515
27516 DATA mexvec(-5) / 6 /
27517 DATA mlfvec(-5) / 2 /
27518 DATA ut1vec(-5) / 0.1619654e+02 /
27519 DATA ut2vec(-5) / -0.3367346e+01 /
27520 DATA alfvec(-5) / 0.5109891e-02 /
27521 DATA qmavec(-5) / 0.4500000e+01 /
27522 DATA (am( 0,k,-5),k=0, 2)
27523 & / -0.6800138e+01, 0.2493627e+01, -0.1075724e+01 /
27524 DATA (am( 1,k,-5),k=0, 2)
27525 & / 0.3036555e+01, 0.3324733e+00, 0.2008298e+00 /
27526 DATA (am( 2,k,-5),k=0, 2)
27527 & / -0.5203879e+01, -0.8493476e+01, -0.4523208e+01 /
27528 DATA (am( 3,k,-5),k=0, 2)
27529 & / -0.1524239e+01, -0.3411912e+01, -0.1771867e+02 /
27530 DATA (am( 4,k,-5),k=0, 2)
27531 & / -0.1099444e+02, 0.1320930e+01, -0.2353831e+01 /
27532 DATA (am( 5,k,-5),k=0, 2)
27533 & / 0.1699299e+02, -0.3565802e+02, 0.3566872e+02 /
27534 DATA (am( 6,k,-5),k=0, 2)
27535 & / -0.1465793e+02, 0.2703365e+02, -0.2176372e+02 /
27536
27537 IF(q .LE. qmavec(ifl)) THEN
27538 pyct5m = 0.d0
27539 RETURN
27540 ENDIF
27541
27542 IF(x .GE. 1.d0) THEN
27543 pyct5m = 0.d0
27544 RETURN
27545 ENDIF
27546
27547 tmp = log(q/alfvec(ifl))
27548 IF(tmp .LE. 0.d0) THEN
27549 pyct5m = 0.d0
27550 RETURN
27551 ENDIF
27552
27553 sb = log(tmp)
27554 sb1 = sb - 1.2d0
27555 sb2 = sb1*sb1
27556
27557 DO 110 i = 0, nex
27558 af(i) = 0.d0
27559 sbx = 1.d0
27560 DO 100 k = 0, mlfvec(ifl)
27561 af(i) = af(i) + sbx*am(i,k,ifl)
27562 sbx = sb1*sbx
27563 100 CONTINUE
27564 110 CONTINUE
27565
27566 y = -log(x)
27567 u = log(x/0.00001d0)
27568
27569 part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
27570 part2 = af(0)*(1.d0 - x) + af(3)*x
27571 part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
27572 part4 = ut1vec(ifl)*log(1.d0-x) +
27573 & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
27574
27575 pyct5m = exp(log(x) + part1 + part2 + part3 + part4)
27576
27577C...Include threshold factor.
27578 pyct5m = pyct5m * (1.d0 - qmavec(ifl)/q)
27579
27580 RETURN
27581 END
27582
27583C*********************************************************************
27584
27585C...PYPDPO
27586C...Auxiliary to PYPDPR. Gives proton parton distributions according to
27587C...a few older parametrizations, now obsolete but convenient for
27588C...backwards checks.
27589
27590 SUBROUTINE pypdpo(X,Q2,XPPR)
27591
27592C...Double precision and integer declarations.
27593 IMPLICIT DOUBLE PRECISION(a-h, o-z)
27594 IMPLICIT INTEGER(I-N)
27595 INTEGER PYK,PYCHGE,PYCOMP
27596C...Commonblocks.
27597 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27598 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27599 common/pypars/mstp(200),parp(200),msti(200),pari(200)
27600 common/pyint1/mint(400),vint(400)
27601 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
27602 dimension xppr(-6:6),xq(9),tx(6),tt(6),ts(6),nehlq(8,2),
27603 &cehlq(6,6,2,8,2),cdo(3,6,5,2)
27604
27605
27606C...The following data lines are coefficients needed in the
27607C...Eichten, Hinchliffe, Lane, Quigg proton structure function
27608C...parametrizations, see below.
27609C...Powers of 1-x in different cases.
27610 DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
27611C...Expansion coefficients for up valence quark distribution.
27612 DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/
27613 1 7.677d-01,-2.087d-01,-3.303d-01,-2.517d-02,-1.570d-02,-1.000d-04,
27614 2-5.326d-01,-2.661d-01, 3.201d-01, 1.192d-01, 2.434d-02, 7.620d-03,
27615 3 2.162d-01, 1.881d-01,-8.375d-02,-6.515d-02,-1.743d-02,-5.040d-03,
27616 4-9.211d-02,-9.952d-02, 1.373d-02, 2.506d-02, 8.770d-03, 2.550d-03,
27617 5 3.670d-02, 4.409d-02, 9.600d-04,-7.960d-03,-3.420d-03,-1.050d-03,
27618 6-1.549d-02,-2.026d-02,-3.060d-03, 2.220d-03, 1.240d-03, 4.100d-04,
27619 1 2.395d-01, 2.905d-01, 9.778d-02, 2.149d-02, 3.440d-03, 5.000d-04,
27620 2 1.751d-02,-6.090d-03,-2.687d-02,-1.916d-02,-7.970d-03,-2.750d-03,
27621 3-5.760d-03,-5.040d-03, 1.080d-03, 2.490d-03, 1.530d-03, 7.500d-04,
27622 4 1.740d-03, 1.960d-03, 3.000d-04,-3.400d-04,-2.900d-04,-1.800d-04,
27623 5-5.300d-04,-6.400d-04,-1.700d-04, 4.000d-05, 6.000d-05, 4.000d-05,
27624 6 1.700d-04, 2.200d-04, 8.000d-05, 1.000d-05,-1.000d-05,-1.000d-05/
27625 DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/
27626 1 7.237d-01,-2.189d-01,-2.995d-01,-1.909d-02,-1.477d-02, 2.500d-04,
27627 2-5.314d-01,-2.425d-01, 3.283d-01, 1.119d-01, 2.223d-02, 7.070d-03,
27628 3 2.289d-01, 1.890d-01,-9.859d-02,-6.900d-02,-1.747d-02,-5.080d-03,
27629 4-1.041d-01,-1.084d-01, 2.108d-02, 2.975d-02, 9.830d-03, 2.830d-03,
27630 5 4.394d-02, 5.116d-02,-1.410d-03,-1.055d-02,-4.230d-03,-1.270d-03,
27631 6-1.991d-02,-2.539d-02,-2.780d-03, 3.430d-03, 1.720d-03, 5.500d-04,
27632 1 2.410d-01, 2.884d-01, 9.369d-02, 1.900d-02, 2.530d-03, 2.400d-04,
27633 2 1.765d-02,-9.220d-03,-3.037d-02,-2.085d-02,-8.440d-03,-2.810d-03,
27634 3-6.450d-03,-5.260d-03, 1.720d-03, 3.110d-03, 1.830d-03, 8.700d-04,
27635 4 2.120d-03, 2.320d-03, 2.600d-04,-4.900d-04,-3.900d-04,-2.300d-04,
27636 5-6.900d-04,-8.200d-04,-2.000d-04, 7.000d-05, 9.000d-05, 6.000d-05,
27637 6 2.400d-04, 3.100d-04, 1.100d-04, 0.000d+00,-2.000d-05,-2.000d-05/
27638C...Expansion coefficients for down valence quark distribution.
27639 DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/
27640 1 3.813d-01,-8.090d-02,-1.634d-01,-2.185d-02,-8.430d-03,-6.200d-04,
27641 2-2.948d-01,-1.435d-01, 1.665d-01, 6.638d-02, 1.473d-02, 4.080d-03,
27642 3 1.252d-01, 1.042d-01,-4.722d-02,-3.683d-02,-1.038d-02,-2.860d-03,
27643 4-5.478d-02,-5.678d-02, 8.900d-03, 1.484d-02, 5.340d-03, 1.520d-03,
27644 5 2.220d-02, 2.567d-02,-3.000d-05,-4.970d-03,-2.160d-03,-6.500d-04,
27645 6-9.530d-03,-1.204d-02,-1.510d-03, 1.510d-03, 8.300d-04, 2.700d-04,
27646 1 1.261d-01, 1.354d-01, 3.958d-02, 8.240d-03, 1.660d-03, 4.500d-04,
27647 2 3.890d-03,-1.159d-02,-1.625d-02,-9.610d-03,-3.710d-03,-1.260d-03,
27648 3-1.910d-03,-5.600d-04, 1.590d-03, 1.590d-03, 8.400d-04, 3.900d-04,
27649 4 6.400d-04, 4.900d-04,-1.500d-04,-2.900d-04,-1.800d-04,-1.000d-04,
27650 5-2.000d-04,-1.900d-04, 0.000d+00, 6.000d-05, 4.000d-05, 3.000d-05,
27651 6 7.000d-05, 8.000d-05, 2.000d-05,-1.000d-05,-1.000d-05,-1.000d-05/
27652 DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/
27653 1 3.578d-01,-8.622d-02,-1.480d-01,-1.840d-02,-7.820d-03,-4.500d-04,
27654 2-2.925d-01,-1.304d-01, 1.696d-01, 6.243d-02, 1.353d-02, 3.750d-03,
27655 3 1.318d-01, 1.041d-01,-5.486d-02,-3.872d-02,-1.038d-02,-2.850d-03,
27656 4-6.162d-02,-6.143d-02, 1.303d-02, 1.740d-02, 5.940d-03, 1.670d-03,
27657 5 2.643d-02, 2.957d-02,-1.490d-03,-6.450d-03,-2.630d-03,-7.700d-04,
27658 6-1.218d-02,-1.497d-02,-1.260d-03, 2.240d-03, 1.120d-03, 3.500d-04,
27659 1 1.263d-01, 1.334d-01, 3.732d-02, 7.070d-03, 1.260d-03, 3.400d-04,
27660 2 3.660d-03,-1.357d-02,-1.795d-02,-1.031d-02,-3.880d-03,-1.280d-03,
27661 3-2.100d-03,-3.600d-04, 2.050d-03, 1.920d-03, 9.800d-04, 4.400d-04,
27662 4 7.700d-04, 5.400d-04,-2.400d-04,-3.900d-04,-2.400d-04,-1.300d-04,
27663 5-2.600d-04,-2.300d-04, 2.000d-05, 9.000d-05, 6.000d-05, 4.000d-05,
27664 6 9.000d-05, 1.000d-04, 2.000d-05,-2.000d-05,-2.000d-05,-1.000d-05/
27665C...Expansion coefficients for up and down sea quark distributions.
27666 DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/
27667 1 6.870d-02,-6.861d-02, 2.973d-02,-5.400d-03, 3.780d-03,-9.700d-04,
27668 2-1.802d-02, 1.400d-04, 6.490d-03,-8.540d-03, 1.220d-03,-1.750d-03,
27669 3-4.650d-03, 1.480d-03,-5.930d-03, 6.000d-04,-1.030d-03,-8.000d-05,
27670 4 6.440d-03, 2.570d-03, 2.830d-03, 1.150d-03, 7.100d-04, 3.300d-04,
27671 5-3.930d-03,-2.540d-03,-1.160d-03,-7.700d-04,-3.600d-04,-1.900d-04,
27672 6 2.340d-03, 1.930d-03, 5.300d-04, 3.700d-04, 1.600d-04, 9.000d-05,
27673 1 1.014d+00,-1.106d+00, 3.374d-01,-7.444d-02, 8.850d-03,-8.700d-04,
27674 2 9.233d-01,-1.285d+00, 4.475d-01,-9.786d-02, 1.419d-02,-1.120d-03,
27675 3 4.888d-02,-1.271d-01, 8.606d-02,-2.608d-02, 4.780d-03,-6.000d-04,
27676 4-2.691d-02, 4.887d-02,-1.771d-02, 1.620d-03, 2.500d-04,-6.000d-05,
27677 5 7.040d-03,-1.113d-02, 1.590d-03, 7.000d-04,-2.000d-04, 0.000d+00,
27678 6-1.710d-03, 2.290d-03, 3.800d-04,-3.500d-04, 4.000d-05, 1.000d-05/
27679 DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/
27680 1 1.008d-01,-7.100d-02, 1.973d-02,-5.710d-03, 2.930d-03,-9.900d-04,
27681 2-5.271d-02,-1.823d-02, 1.792d-02,-6.580d-03, 1.750d-03,-1.550d-03,
27682 3 1.220d-02, 1.763d-02,-8.690d-03,-8.800d-04,-1.160d-03,-2.100d-04,
27683 4-1.190d-03,-7.180d-03, 2.360d-03, 1.890d-03, 7.700d-04, 4.100d-04,
27684 5-9.100d-04, 2.040d-03,-3.100d-04,-1.050d-03,-4.000d-04,-2.400d-04,
27685 6 1.190d-03,-1.700d-04,-2.000d-04, 4.200d-04, 1.700d-04, 1.000d-04,
27686 1 1.081d+00,-1.189d+00, 3.868d-01,-8.617d-02, 1.115d-02,-1.180d-03,
27687 2 9.917d-01,-1.396d+00, 4.998d-01,-1.159d-01, 1.674d-02,-1.720d-03,
27688 3 5.099d-02,-1.338d-01, 9.173d-02,-2.885d-02, 5.890d-03,-6.500d-04,
27689 4-3.178d-02, 5.703d-02,-2.070d-02, 2.440d-03, 1.100d-04,-9.000d-05,
27690 5 8.970d-03,-1.392d-02, 2.050d-03, 6.500d-04,-2.300d-04, 2.000d-05,
27691 6-2.340d-03, 3.010d-03, 5.000d-04,-3.900d-04, 6.000d-05, 1.000d-05/
27692C...Expansion coefficients for gluon distribution.
27693 DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/
27694 1 9.482d-01,-9.578d-01, 1.009d-01,-1.051d-01, 3.456d-02,-3.054d-02,
27695 2-9.627d-01, 5.379d-01, 3.368d-01,-9.525d-02, 1.488d-02,-2.051d-02,
27696 3 4.300d-01,-8.306d-02,-3.372d-01, 4.902d-02,-9.160d-03, 1.041d-02,
27697 4-1.925d-01,-1.790d-02, 2.183d-01, 7.490d-03, 4.140d-03,-1.860d-03,
27698 5 8.183d-02, 1.926d-02,-1.072d-01,-1.944d-02,-2.770d-03,-5.200d-04,
27699 6-3.884d-02,-1.234d-02, 5.410d-02, 1.879d-02, 3.350d-03, 1.040d-03,
27700 1 2.948d+01,-3.902d+01, 1.464d+01,-3.335d+00, 5.054d-01,-5.915d-02,
27701 2 2.559d+01,-3.955d+01, 1.661d+01,-4.299d+00, 6.904d-01,-8.243d-02,
27702 3-1.663d+00, 1.176d+00, 1.118d+00,-7.099d-01, 1.948d-01,-2.404d-02,
27703 4-2.168d-01, 8.170d-01,-7.169d-01, 1.851d-01,-1.924d-02,-3.250d-03,
27704 5 2.088d-01,-4.355d-01, 2.239d-01,-2.446d-02,-3.620d-03, 1.910d-03,
27705 6-9.097d-02, 1.601d-01,-5.681d-02,-2.500d-03, 2.580d-03,-4.700d-04/
27706 DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/
27707 1 2.367d+00, 4.453d-01, 3.660d-01, 9.467d-02, 1.341d-01, 1.661d-02,
27708 2-3.170d+00,-1.795d+00, 3.313d-02,-2.874d-01,-9.827d-02,-7.119d-02,
27709 3 1.823d+00, 1.457d+00,-2.465d-01, 3.739d-02, 6.090d-03, 1.814d-02,
27710 4-1.033d+00,-9.827d-01, 2.136d-01, 1.169d-01, 5.001d-02, 1.684d-02,
27711 5 5.133d-01, 5.259d-01,-1.173d-01,-1.139d-01,-4.988d-02,-2.021d-02,
27712 6-2.881d-01,-3.145d-01, 5.667d-02, 9.161d-02, 4.568d-02, 1.951d-02,
27713 1 3.036d+01,-4.062d+01, 1.578d+01,-3.699d+00, 6.020d-01,-7.031d-02,
27714 2 2.700d+01,-4.167d+01, 1.770d+01,-4.804d+00, 7.862d-01,-1.060d-01,
27715 3-1.909d+00, 1.357d+00, 1.127d+00,-7.181d-01, 2.232d-01,-2.481d-02,
27716 4-2.488d-01, 9.781d-01,-8.127d-01, 2.094d-01,-2.997d-02,-4.710d-03,
27717 5 2.506d-01,-5.427d-01, 2.672d-01,-3.103d-02,-1.800d-03, 2.870d-03,
27718 6-1.128d-01, 2.087d-01,-6.972d-02,-2.480d-03, 2.630d-03,-8.400d-04/
27719C...Expansion coefficients for strange sea quark distribution.
27720 DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/
27721 1 4.968d-02,-4.173d-02, 2.102d-02,-3.270d-03, 3.240d-03,-6.700d-04,
27722 2-6.150d-03,-1.294d-02, 6.740d-03,-6.890d-03, 9.000d-04,-1.510d-03,
27723 3-8.580d-03, 5.050d-03,-4.900d-03,-1.600d-04,-9.400d-04,-1.500d-04,
27724 4 7.840d-03, 1.510d-03, 2.220d-03, 1.400d-03, 7.000d-04, 3.500d-04,
27725 5-4.410d-03,-2.220d-03,-8.900d-04,-8.500d-04,-3.600d-04,-2.000d-04,
27726 6 2.520d-03, 1.840d-03, 4.100d-04, 3.900d-04, 1.600d-04, 9.000d-05,
27727 1 9.235d-01,-1.085d+00, 3.464d-01,-7.210d-02, 9.140d-03,-9.100d-04,
27728 2 9.315d-01,-1.274d+00, 4.512d-01,-9.775d-02, 1.380d-02,-1.310d-03,
27729 3 4.739d-02,-1.296d-01, 8.482d-02,-2.642d-02, 4.760d-03,-5.700d-04,
27730 4-2.653d-02, 4.953d-02,-1.735d-02, 1.750d-03, 2.800d-04,-6.000d-05,
27731 5 6.940d-03,-1.132d-02, 1.480d-03, 6.500d-04,-2.100d-04, 0.000d+00,
27732 6-1.680d-03, 2.340d-03, 4.200d-04,-3.400d-04, 5.000d-05, 1.000d-05/
27733 DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/
27734 1 6.478d-02,-4.537d-02, 1.643d-02,-3.490d-03, 2.710d-03,-6.700d-04,
27735 2-2.223d-02,-2.126d-02, 1.247d-02,-6.290d-03, 1.120d-03,-1.440d-03,
27736 3-1.340d-03, 1.362d-02,-6.130d-03,-7.900d-04,-9.000d-04,-2.000d-04,
27737 4 5.080d-03,-3.610d-03, 1.700d-03, 1.830d-03, 6.800d-04, 4.000d-04,
27738 5-3.580d-03, 6.000d-05,-2.600d-04,-1.050d-03,-3.800d-04,-2.300d-04,
27739 6 2.420d-03, 9.300d-04,-1.000d-04, 4.500d-04, 1.700d-04, 1.100d-04,
27740 1 9.868d-01,-1.171d+00, 3.940d-01,-8.459d-02, 1.124d-02,-1.250d-03,
27741 2 1.001d+00,-1.383d+00, 5.044d-01,-1.152d-01, 1.658d-02,-1.830d-03,
27742 3 4.928d-02,-1.368d-01, 9.021d-02,-2.935d-02, 5.800d-03,-6.600d-04,
27743 4-3.133d-02, 5.785d-02,-2.023d-02, 2.630d-03, 1.600d-04,-8.000d-05,
27744 5 8.840d-03,-1.416d-02, 1.900d-03, 5.800d-04,-2.500d-04, 1.000d-05,
27745 6-2.300d-03, 3.080d-03, 5.500d-04,-3.700d-04, 7.000d-05, 1.000d-05/
27746C...Expansion coefficients for charm sea quark distribution.
27747 DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/
27748 1 9.270d-03,-1.817d-02, 9.590d-03,-6.390d-03, 1.690d-03,-1.540d-03,
27749 2 5.710d-03,-1.188d-02, 6.090d-03,-4.650d-03, 1.240d-03,-1.310d-03,
27750 3-3.960d-03, 7.100d-03,-3.590d-03, 1.840d-03,-3.900d-04, 3.400d-04,
27751 4 1.120d-03,-1.960d-03, 1.120d-03,-4.800d-04, 1.000d-04,-4.000d-05,
27752 5 4.000d-05,-3.000d-05,-1.800d-04, 9.000d-05,-5.000d-05,-2.000d-05,
27753 6-4.200d-04, 7.300d-04,-1.600d-04, 5.000d-05, 5.000d-05, 5.000d-05,
27754 1 8.098d-01,-1.042d+00, 3.398d-01,-6.824d-02, 8.760d-03,-9.000d-04,
27755 2 8.961d-01,-1.217d+00, 4.339d-01,-9.287d-02, 1.304d-02,-1.290d-03,
27756 3 3.058d-02,-1.040d-01, 7.604d-02,-2.415d-02, 4.600d-03,-5.000d-04,
27757 4-2.451d-02, 4.432d-02,-1.651d-02, 1.430d-03, 1.200d-04,-1.000d-04,
27758 5 1.122d-02,-1.457d-02, 2.680d-03, 5.800d-04,-1.200d-04, 3.000d-05,
27759 6-7.730d-03, 7.330d-03,-7.600d-04,-2.400d-04, 1.000d-05, 0.000d+00/
27760 DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/
27761 1 9.980d-03,-1.945d-02, 1.055d-02,-6.870d-03, 1.860d-03,-1.560d-03,
27762 2 5.700d-03,-1.203d-02, 6.250d-03,-4.860d-03, 1.310d-03,-1.370d-03,
27763 3-4.490d-03, 7.990d-03,-4.170d-03, 2.050d-03,-4.400d-04, 3.300d-04,
27764 4 1.470d-03,-2.480d-03, 1.460d-03,-5.700d-04, 1.200d-04,-1.000d-05,
27765 5-9.000d-05, 1.500d-04,-3.200d-04, 1.200d-04,-6.000d-05,-4.000d-05,
27766 6-4.200d-04, 7.600d-04,-1.400d-04, 4.000d-05, 7.000d-05, 5.000d-05,
27767 1 8.698d-01,-1.131d+00, 3.836d-01,-8.111d-02, 1.048d-02,-1.300d-03,
27768 2 9.626d-01,-1.321d+00, 4.854d-01,-1.091d-01, 1.583d-02,-1.700d-03,
27769 3 3.057d-02,-1.088d-01, 8.022d-02,-2.676d-02, 5.590d-03,-5.600d-04,
27770 4-2.845d-02, 5.164d-02,-1.918d-02, 2.210d-03,-4.000d-05,-1.500d-04,
27771 5 1.311d-02,-1.751d-02, 3.310d-03, 5.100d-04,-1.200d-04, 5.000d-05,
27772 6-8.590d-03, 8.380d-03,-9.200d-04,-2.600d-04, 1.000d-05,-1.000d-05/
27773C...Expansion coefficients for bottom sea quark distribution.
27774 DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/
27775 1 9.010d-03,-1.401d-02, 7.150d-03,-4.130d-03, 1.260d-03,-1.040d-03,
27776 2 6.280d-03,-9.320d-03, 4.780d-03,-2.890d-03, 9.100d-04,-8.200d-04,
27777 3-2.930d-03, 4.090d-03,-1.890d-03, 7.600d-04,-2.300d-04, 1.400d-04,
27778 4 3.900d-04,-1.200d-03, 4.400d-04,-2.500d-04, 2.000d-05,-2.000d-05,
27779 5 2.600d-04, 1.400d-04,-8.000d-05, 1.000d-04, 1.000d-05, 1.000d-05,
27780 6-2.600d-04, 3.200d-04, 1.000d-05,-1.000d-05, 1.000d-05,-1.000d-05,
27781 1 8.029d-01,-1.075d+00, 3.792d-01,-7.843d-02, 1.007d-02,-1.090d-03,
27782 2 7.903d-01,-1.099d+00, 4.153d-01,-9.301d-02, 1.317d-02,-1.410d-03,
27783 3-1.704d-02,-1.130d-02, 2.882d-02,-1.341d-02, 3.040d-03,-3.600d-04,
27784 4-7.200d-04, 7.230d-03,-5.160d-03, 1.080d-03,-5.000d-05,-4.000d-05,
27785 5 3.050d-03,-4.610d-03, 1.660d-03,-1.300d-04,-1.000d-05, 1.000d-05,
27786 6-4.360d-03, 5.230d-03,-1.610d-03, 2.000d-04,-2.000d-05, 0.000d+00/
27787 DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/
27788 1 8.980d-03,-1.459d-02, 7.510d-03,-4.410d-03, 1.310d-03,-1.070d-03,
27789 2 5.970d-03,-9.440d-03, 4.800d-03,-3.020d-03, 9.100d-04,-8.500d-04,
27790 3-3.050d-03, 4.440d-03,-2.100d-03, 8.500d-04,-2.400d-04, 1.400d-04,
27791 4 5.300d-04,-1.300d-03, 5.600d-04,-2.700d-04, 3.000d-05,-2.000d-05,
27792 5 2.000d-04, 1.400d-04,-1.100d-04, 1.000d-04, 0.000d+00, 0.000d+00,
27793 6-2.600d-04, 3.200d-04, 0.000d+00,-3.000d-05, 1.000d-05,-1.000d-05,
27794 1 8.672d-01,-1.174d+00, 4.265d-01,-9.252d-02, 1.244d-02,-1.460d-03,
27795 2 8.500d-01,-1.194d+00, 4.630d-01,-1.083d-01, 1.614d-02,-1.830d-03,
27796 3-2.241d-02,-5.630d-03, 2.815d-02,-1.425d-02, 3.520d-03,-4.300d-04,
27797 4-7.300d-04, 8.030d-03,-5.780d-03, 1.380d-03,-1.300d-04,-4.000d-05,
27798 5 3.460d-03,-5.380d-03, 1.960d-03,-2.100d-04, 1.000d-05, 1.000d-05,
27799 6-4.850d-03, 5.950d-03,-1.890d-03, 2.600d-04,-3.000d-05, 0.000d+00/
27800C...Expansion coefficients for top sea quark distribution.
27801 DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/
27802 1 4.410d-03,-7.480d-03, 3.770d-03,-2.580d-03, 7.300d-04,-7.100d-04,
27803 2 3.840d-03,-6.050d-03, 3.030d-03,-2.030d-03, 5.800d-04,-5.900d-04,
27804 3-8.800d-04, 1.660d-03,-7.500d-04, 4.700d-04,-1.000d-04, 1.000d-04,
27805 4-8.000d-05,-1.500d-04, 1.200d-04,-9.000d-05, 3.000d-05, 0.000d+00,
27806 5 1.300d-04,-2.200d-04,-2.000d-05,-2.000d-05,-2.000d-05,-2.000d-05,
27807 6-7.000d-05, 1.900d-04,-4.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
27808 1 6.623d-01,-9.248d-01, 3.519d-01,-7.930d-02, 1.110d-02,-1.180d-03,
27809 2 6.380d-01,-9.062d-01, 3.582d-01,-8.479d-02, 1.265d-02,-1.390d-03,
27810 3-2.581d-02, 2.125d-02, 4.190d-03,-4.980d-03, 1.490d-03,-2.100d-04,
27811 4 7.100d-04, 5.300d-04,-1.270d-03, 3.900d-04,-5.000d-05,-1.000d-05,
27812 5 3.850d-03,-5.060d-03, 1.860d-03,-3.500d-04, 4.000d-05, 0.000d+00,
27813 6-3.530d-03, 4.460d-03,-1.500d-03, 2.700d-04,-3.000d-05, 0.000d+00/
27814 DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/
27815 1 4.260d-03,-7.530d-03, 3.830d-03,-2.680d-03, 7.600d-04,-7.300d-04,
27816 2 3.640d-03,-6.050d-03, 3.030d-03,-2.090d-03, 5.900d-04,-6.000d-04,
27817 3-9.200d-04, 1.710d-03,-8.200d-04, 5.000d-04,-1.200d-04, 1.000d-04,
27818 4-5.000d-05,-1.600d-04, 1.300d-04,-9.000d-05, 3.000d-05, 0.000d+00,
27819 5 1.300d-04,-2.100d-04,-1.000d-05,-2.000d-05,-2.000d-05,-1.000d-05,
27820 6-8.000d-05, 1.800d-04,-5.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
27821 1 7.146d-01,-1.007d+00, 3.932d-01,-9.246d-02, 1.366d-02,-1.540d-03,
27822 2 6.856d-01,-9.828d-01, 3.977d-01,-9.795d-02, 1.540d-02,-1.790d-03,
27823 3-3.053d-02, 2.758d-02, 2.150d-03,-4.880d-03, 1.640d-03,-2.500d-04,
27824 4 9.200d-04, 4.200d-04,-1.340d-03, 4.600d-04,-8.000d-05,-1.000d-05,
27825 5 4.230d-03,-5.660d-03, 2.140d-03,-4.300d-04, 6.000d-05, 0.000d+00,
27826 6-3.890d-03, 5.000d-03,-1.740d-03, 3.300d-04,-4.000d-05, 0.000d+00/
27827
27828C...The following data lines are coefficients needed in the
27829C...Duke, Owens proton structure function parametrizations, see below.
27830C...Expansion coefficients for (up+down) valence quark distribution.
27831 DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/
27832 1 4.190d-01, 3.460d+00, 4.400d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27833 2 4.000d-03, 7.240d-01,-4.860d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27834 3-7.000d-03,-6.600d-02, 1.330d+00, 0.000d+00, 0.000d+00, 0.000d+00/
27835 DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/
27836 1 3.740d-01, 3.330d+00, 6.030d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27837 2 1.400d-02, 7.530d-01,-6.220d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27838 3 0.000d+00,-7.600d-02, 1.560d+00, 0.000d+00, 0.000d+00, 0.000d+00/
27839C...Expansion coefficients for down valence quark distribution.
27840 DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/
27841 1 7.630d-01, 4.000d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27842 2-2.370d-01, 6.270d-01,-4.210d-01, 0.000d+00, 0.000d+00, 0.000d+00,
27843 3 2.600d-02,-1.900d-02, 3.300d-02, 0.000d+00, 0.000d+00, 0.000d+00/
27844 DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/
27845 1 7.610d-01, 3.830d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27846 2-2.320d-01, 6.270d-01,-4.180d-01, 0.000d+00, 0.000d+00, 0.000d+00,
27847 3 2.300d-02,-1.900d-02, 3.600d-02, 0.000d+00, 0.000d+00, 0.000d+00/
27848C...Expansion coefficients for (up+down+strange) sea quark distribution.
27849 DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/
27850 1 1.265d+00, 0.000d+00, 8.050d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27851 2-1.132d+00,-3.720d-01, 1.590d+00, 6.310d+00,-1.050d+01, 1.470d+01,
27852 3 2.930d-01,-2.900d-02,-1.530d-01,-2.730d-01,-3.170d+00, 9.800d+00/
27853 DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/
27854 1 1.670d+00, 0.000d+00, 9.150d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27855 2-1.920d+00,-2.730d-01, 5.300d-01, 1.570d+01,-1.010d+02, 2.230d+02,
27856 3 5.820d-01,-1.640d-01,-7.630d-01,-2.830d+00, 4.470d+01,-1.170d+02/
27857C...Expansion coefficients for charm sea quark distribution.
27858 DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/
27859 1 0.000d+00,-3.600d-02, 6.350d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27860 2 1.350d-01,-2.220d-01, 3.260d+00,-3.030d+00, 1.740d+01,-1.790d+01,
27861 3-7.500d-02,-5.800d-02,-9.090d-01, 1.500d+00,-1.130d+01, 1.560d+01/
27862 DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/
27863 1 0.000d+00,-1.200d-01, 3.510d+00, 0.000d+00, 0.000d+00, 0.000d+00,
27864 2 6.700d-02,-2.330d-01, 3.660d+00,-4.740d-01, 9.500d+00,-1.660d+01,
27865 3-3.100d-02,-2.300d-02,-4.530d-01, 3.580d-01,-5.430d+00, 1.550d+01/
27866C...Expansion coefficients for gluon distribution.
27867 DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/
27868 1 1.560d+00, 0.000d+00, 6.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
27869 2-1.710d+00,-9.490d-01, 1.440d+00,-7.190d+00,-1.650d+01, 1.530d+01,
27870 3 6.380d-01, 3.250d-01,-1.050d+00, 2.550d-01, 1.090d+01,-1.010d+01/
27871 DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/
27872 1 8.790d-01, 0.000d+00, 4.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
27873 2-9.710d-01,-1.160d+00, 1.230d+00,-5.640d+00,-7.540d+00,-5.960d-01,
27874 3 4.340d-01, 4.760d-01,-2.540d-01,-8.170d-01, 5.500d+00, 1.260d-01/
27875
27876C...Euler's beta function, requires ordinary Gamma function
27877 eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
27878
27879C...Leading order proton parton distributions from Gluck, Reya and Vogt.
27880C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
27881C...10^-5 < x < 1.
27882 IF(mstp(51).EQ.11) THEN
27883
27884C...Determine s expansion variable and some x expressions.
27885 q2in=min(1d8,max(0.25d0,q2))
27886 sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
27887 sd2=sd**2
27888 xl=-log(x)
27889 xs=sqrt(x)
27890
27891C...Evaluate valence, gluon and sea distributions.
27892 xfvud=(0.663d0+0.191d0*sd-0.041d0*sd2+0.031d0*sd**3)*
27893 & x**0.326d0*(1d0+(-1.97d0+6.74d0*sd-1.96d0*sd2)*xs+
27894 & (24.4d0-20.7d0*sd+4.08d0*sd2)*x)*
27895 & (1d0-x)**(2.86d0+0.70d0*sd-0.02d0*sd2)
27896 xfvdd=(0.579d0+0.283d0*sd+0.047d0*sd2)*x**(0.523d0-0.015d0*sd)*
27897 & (1d0+(2.22d0-0.59d0*sd-0.27d0*sd2)*xs+(5.95d0-6.19d0*sd+
27898 & 1.55d0*sd2)*x)*(1d0-x)**(3.57d0+0.94d0*sd-0.16d0*sd2)
27899 xfglu=(x**(1.00d0-0.17d0*sd)*((4.879d0*sd-1.383d0*sd2)+
27900 & (25.92d0-28.97d0*sd+5.596d0*sd2)*x+(-25.69d0+23.68d0*sd-
27901 & 1.975d0*sd2)*x**2)+sd**0.558d0*exp(-(0.595d0+2.138d0*sd)+
27902 & sqrt(4.066d0*sd**1.218d0*xl)))*
27903 & (1d0-x)**(2.537d0+1.718d0*sd+0.353d0*sd2)
27904 xfsea=(x**(0.412d0-0.171d0*sd)*(0.363d0-1.196d0*x+(1.029d0+
27905 & 1.785d0*sd-0.459d0*sd2)*x**2)*xl**(0.566d0-0.496d0*sd)+
27906 & sd**1.396d0*exp(-(3.838d0+1.944d0*sd)+sqrt(2.845d0*sd**1.331d0*
27907 & xl)))*(1d0-x)**(4.696d0+2.109d0*sd)
27908 xfstr=sd**0.803d0*(1d0+(-3.055d0+1.024d0*sd**0.67d0)*xs+
27909 & (27.4d0-20.0d0*sd**0.154d0)*x)*(1d0-x)**6.22d0*
27910 & exp(-(4.33d0+1.408d0*sd)+sqrt((8.27d0-0.437d0*sd)*
27911 & sd**0.563d0*xl))/xl**(2.082d0-0.577d0*sd)
27912 IF(sd.LE.0.888d0) THEN
27913 xfchm=0d0
27914 ELSE
27915 xfchm=(sd-0.888d0)**1.01d0*(1.+(4.24d0-0.804d0*sd)*x)*
27916 & (1d0-x)**(3.46d0+1.076d0*sd)*exp(-(4.61d0+1.49d0*sd)+
27917 & sqrt((2.555d0+1.961d0*sd)*sd**0.37d0*xl))
27918 ENDIF
27919 IF(sd.LE.1.351d0) THEN
27920 xfbot=0d0
27921 ELSE
27922 xfbot=(sd-1.351d0)*(1d0+1.848d0*x)*(1d0-x)**(2.929d0+
27923 & 1.396d0*sd)*exp(-(4.71d0+1.514d0*sd)+
27924 & sqrt((4.02d0+1.239d0*sd)*sd**0.51d0*xl))
27925 ENDIF
27926
27927C...Put into output array.
27928 xppr(0)=xfglu
27929 xppr(1)=xfvdd+xfsea
27930 xppr(2)=xfvud-xfvdd+xfsea
27931 xppr(3)=xfstr
27932 xppr(4)=xfchm
27933 xppr(5)=xfbot
27934 xppr(-1)=xfsea
27935 xppr(-2)=xfsea
27936 xppr(-3)=xfstr
27937 xppr(-4)=xfchm
27938 xppr(-5)=xfbot
27939
27940C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
27941C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
27942 ELSEIF(mstp(51).EQ.12.OR.mstp(51).EQ.13) THEN
27943
27944C...Determine set, Lambda and x and t expansion variables.
27945 nset=mstp(51)-11
27946 IF(nset.EQ.1) alam=0.2d0
27947 IF(nset.EQ.2) alam=0.29d0
27948 tmin=log(5d0/alam**2)
27949 tmax=log(1d8/alam**2)
27950 t=log(max(1d0,q2/alam**2))
27951 vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
27952 nx=1
27953 IF(x.LE.0.1d0) nx=2
27954 IF(nx.EQ.1) vx=(2d0*x-1.1d0)/0.9d0
27955 IF(nx.EQ.2) vx=max(-1d0,(2d0*log(x)+11.51293d0)/6.90776d0)
27956
27957C...Chebyshev polynomials for x and t expansion.
27958 tx(1)=1d0
27959 tx(2)=vx
27960 tx(3)=2d0*vx**2-1d0
27961 tx(4)=4d0*vx**3-3d0*vx
27962 tx(5)=8d0*vx**4-8d0*vx**2+1d0
27963 tx(6)=16d0*vx**5-20d0*vx**3+5d0*vx
27964 tt(1)=1d0
27965 tt(2)=vt
27966 tt(3)=2d0*vt**2-1d0
27967 tt(4)=4d0*vt**3-3d0*vt
27968 tt(5)=8d0*vt**4-8d0*vt**2+1d0
27969 tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
27970
27971C...Calculate structure functions.
27972 DO 130 kfl=1,6
27973 xqsum=0d0
27974 DO 120 it=1,6
27975 DO 110 ix=1,6
27976 xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)
27977 110 CONTINUE
27978 120 CONTINUE
27979 xq(kfl)=xqsum*(1d0-x)**nehlq(kfl,nset)
27980 130 CONTINUE
27981
27982C...Put into output array.
27983 xppr(0)=xq(4)
27984 xppr(1)=xq(2)+xq(3)
27985 xppr(2)=xq(1)+xq(3)
27986 xppr(3)=xq(5)
27987 xppr(4)=xq(6)
27988 xppr(-1)=xq(3)
27989 xppr(-2)=xq(3)
27990 xppr(-3)=xq(5)
27991 xppr(-4)=xq(6)
27992
27993C...Special expansion for bottom (threshold effects).
27994 IF(mstp(58).GE.5) THEN
27995 IF(nset.EQ.1) tmin=8.1905d0
27996 IF(nset.EQ.2) tmin=7.4474d0
27997 IF(t.GT.tmin) THEN
27998 vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
27999 tt(1)=1d0
28000 tt(2)=vt
28001 tt(3)=2d0*vt**2-1d0
28002 tt(4)=4d0*vt**3-3d0*vt
28003 tt(5)=8d0*vt**4-8d0*vt**2+1d0
28004 tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
28005 xqsum=0d0
28006 DO 150 it=1,6
28007 DO 140 ix=1,6
28008 xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)
28009 140 CONTINUE
28010 150 CONTINUE
28011 xppr(5)=xqsum*(1d0-x)**nehlq(7,nset)
28012 xppr(-5)=xppr(5)
28013 ENDIF
28014 ENDIF
28015
28016C...Special expansion for top (threshold effects).
28017 IF(mstp(58).GE.6) THEN
28018 IF(nset.EQ.1) tmin=11.5528d0
28019 IF(nset.EQ.2) tmin=10.8097d0
28020 tmin=tmin+2d0*log(pmas(6,1)/30d0)
28021 tmax=tmax+2d0*log(pmas(6,1)/30d0)
28022 IF(t.GT.tmin) THEN
28023 vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
28024 tt(1)=1d0
28025 tt(2)=vt
28026 tt(3)=2d0*vt**2-1d0
28027 tt(4)=4d0*vt**3-3d0*vt
28028 tt(5)=8d0*vt**4-8d0*vt**2+1d0
28029 tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
28030 xqsum=0d0
28031 DO 170 it=1,6
28032 DO 160 ix=1,6
28033 xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)
28034 160 CONTINUE
28035 170 CONTINUE
28036 xppr(6)=xqsum*(1d0-x)**nehlq(8,nset)
28037 xppr(-6)=xppr(6)
28038 ENDIF
28039 ENDIF
28040
28041C...Proton parton distributions from Duke, Owens.
28042C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
28043 ELSEIF(mstp(51).EQ.14.OR.mstp(51).EQ.15) THEN
28044
28045C...Determine set, Lambda and s expansion parameter.
28046 nset=mstp(51)-13
28047 IF(nset.EQ.1) alam=0.2d0
28048 IF(nset.EQ.2) alam=0.4d0
28049 q2in=min(1d6,max(4d0,q2))
28050 sd=log(log(q2in/alam**2)/log(4d0/alam**2))
28051
28052C...Calculate structure functions.
28053 DO 190 kfl=1,5
28054 DO 180 is=1,6
28055 ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+
28056 & cdo(3,is,kfl,nset)*sd**2
28057 180 CONTINUE
28058 IF(kfl.LE.2) THEN
28059 xq(kfl)=x**ts(1)*(1d0-x)**ts(2)*(1d0+ts(3)*x)/(eulbet(ts(1),
28060 & ts(2)+1d0)*(1d0+ts(3)*ts(1)/(ts(1)+ts(2)+1d0)))
28061 ELSE
28062 xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
28063 & ts(5)*x**2+ts(6)*x**3)
28064 ENDIF
28065 190 CONTINUE
28066
28067C...Put into output arrays.
28068 xppr(0)=xq(5)
28069 xppr(1)=xq(2)+xq(3)/6d0
28070 xppr(2)=3d0*xq(1)-xq(2)+xq(3)/6d0
28071 xppr(3)=xq(3)/6d0
28072 xppr(4)=xq(4)
28073 xppr(-1)=xq(3)/6d0
28074 xppr(-2)=xq(3)/6d0
28075 xppr(-3)=xq(3)/6d0
28076 xppr(-4)=xq(4)
28077
28078 ENDIF
28079
28080 RETURN
28081 END
28082
28083C*********************************************************************
28084
28085C...PYHFTH
28086C...Gives threshold attractive/repulsive factor for heavy flavour
28087C...production.
28088
28089 FUNCTION pyhfth(SH,SQM,FRATT)
28090
28091C...Double precision and integer declarations.
28092 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28093 IMPLICIT INTEGER(I-N)
28094 INTEGER PYK,PYCHGE,PYCOMP
28095C...Commonblocks.
28096 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28097 common/pypars/mstp(200),parp(200),msti(200),pari(200)
28098 common/pyint1/mint(400),vint(400)
28099 SAVE /pydat1/,/pypars/,/pyint1/
28100
28101C...Value for alpha_strong.
28102 IF(mstp(35).LE.1) THEN
28103 alssg=parp(35)
28104 ELSE
28105 mst115=mstu(115)
28106 mstu(115)=mstp(36)
28107 q2bn=sqrt(max(1d0,sqm*((sqrt(sh)-2d0*sqrt(sqm))**2+
28108 & parp(36)**2)))
28109 alssg=pyalps(q2bn)
28110 mstu(115)=mst115
28111 ENDIF
28112
28113C...Evaluate attractive and repulsive factors.
28114 xattr=4d0*paru(1)*alssg/(3d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
28115 fattr=xattr/(1d0-exp(-min(50d0,xattr)))
28116 xrepu=paru(1)*alssg/(6d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
28117 frepu=xrepu/(exp(min(50d0,xrepu))-1d0)
28118 pyhfth=fratt*fattr+(1d0-fratt)*frepu
28119 vint(138)=pyhfth
28120
28121 RETURN
28122 END
28123
28124C*********************************************************************
28125
28126C...PYSPLI
28127C...Splits a hadron remnant into two (partons or hadron + parton)
28128C...in case it is more complicated than just a quark or a diquark.
28129
28130 SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
28131
28132C...Double precision and integer declarations.
28133 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28134 IMPLICIT INTEGER(I-N)
28135 INTEGER PYK,PYCHGE,PYCOMP
28136C...Commonblocks. PYDAT1 temporary
28137 common/pypars/mstp(200),parp(200),msti(200),pari(200)
28138 common/pyint1/mint(400),vint(400)
28139 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28140 SAVE /pypars/,/pyint1/,/pydat1/
28141C...Local array.
28142 dimension kfl(3)
28143
28144C...Preliminaries. Parton composition.
28145 kfa=iabs(kf)
28146 kfs=isign(1,kf)
28147 kfl(1)=mod(kfa/1000,10)
28148 kfl(2)=mod(kfa/100,10)
28149 kfl(3)=mod(kfa/10,10)
28150 IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN
28151 kfl(2)=int(1.5d0+pyr(0))
28152 IF(mint(105).EQ.333) kfl(2)=3
28153 IF(mint(105).EQ.443) kfl(2)=4
28154 kfl(3)=kfl(2)
28155 ELSEIF((kfa.EQ.111.OR.kfa.EQ.113).AND.pyr(0).GT.0.5d0) THEN
28156 kfl(2)=2
28157 kfl(3)=2
28158 ELSEIF(kfa.EQ.223.AND.pyr(0).GT.0.5d0) THEN
28159 kfl(2)=1
28160 kfl(3)=1
28161 ENDIF
28162 IF(kflin.NE.21.AND.kflin.NE.22.AND.kflin.NE.23) THEN
28163 kflr=kflin*kfs
28164 ELSE
28165 kflr=kflin
28166 ENDIF
28167 kflch=0
28168
28169C...Subdivide lepton.
28170 IF(kfa.GE.11.AND.kfa.LE.18) THEN
28171 IF(kflr.EQ.kfa) THEN
28172 kflsp=kfs*22
28173 ELSEIF(kflr.EQ.22) THEN
28174 kflsp=kfa
28175 ELSEIF(kflr.EQ.-24.AND.mod(kfa,2).EQ.1) THEN
28176 kflsp=kfa+1
28177 ELSEIF(kflr.EQ.24.AND.mod(kfa,2).EQ.0) THEN
28178 kflsp=kfa-1
28179 ELSEIF(kflr.EQ.21) THEN
28180 kflsp=kfa
28181 kflch=kfs*21
28182 ELSE
28183 kflsp=kfa
28184 kflch=-kflr
28185 ENDIF
28186
28187C...Subdivide photon.
28188 ELSEIF(kfa.EQ.22.AND.mint(109).NE.2) THEN
28189 IF(kflr.NE.21) THEN
28190 kflsp=-kflr
28191 ELSE
28192 ragr=0.75d0*pyr(0)
28193 kflsp=1
28194 IF(ragr.GT.0.125d0) kflsp=2
28195 IF(ragr.GT.0.625d0) kflsp=3
28196 IF(pyr(0).GT.0.5d0) kflsp=-kflsp
28197 kflch=-kflsp
28198 ENDIF
28199
28200C...Subdivide Reggeon or Pomeron.
28201 ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN
28202 IF(kflin.EQ.21) THEN
28203 kflsp=kfs*21
28204 ELSE
28205 kflsp=-kflin
28206 ENDIF
28207
28208C...Subdivide meson.
28209 ELSEIF(kfl(1).EQ.0) THEN
28210 kfl(2)=kfl(2)*(-1)**kfl(2)
28211 kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))
28212 IF(kflr.EQ.kfl(2)) THEN
28213 kflsp=kfl(3)
28214 ELSEIF(kflr.EQ.kfl(3)) THEN
28215 kflsp=kfl(2)
28216 ELSEIF(kflr.EQ.21.AND.pyr(0).GT.0.5d0) THEN
28217 kflsp=kfl(2)
28218 kflch=kfl(3)
28219 ELSEIF(kflr.EQ.21) THEN
28220 kflsp=kfl(3)
28221 kflch=kfl(2)
28222 ELSEIF(kflr*kfl(2).GT.0) THEN
28223 ntry=0
28224 100 ntry=ntry+1
28225 CALL pykfdi(-kflr,kfl(2),kfdump,kflch)
28226 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
28227 GOTO 100
28228 ELSEIF(kflch.EQ.0) THEN
28229 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
28230 mint(51)=1
28231 RETURN
28232 ENDIF
28233 kflsp=kfl(3)
28234 ELSE
28235 ntry=0
28236 110 ntry=ntry+1
28237 CALL pykfdi(-kflr,kfl(3),kfdump,kflch)
28238 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
28239 GOTO 110
28240 ELSEIF(kflch.EQ.0) THEN
28241 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
28242 mint(51)=1
28243 RETURN
28244 ENDIF
28245 kflsp=kfl(2)
28246 ENDIF
28247
28248C...Subdivide baryon.
28249 ELSE
28250 nagr=0
28251 DO 120 j=1,3
28252 IF(kflr.EQ.kfl(j)) nagr=nagr+1
28253 120 CONTINUE
28254 IF(nagr.GE.1) THEN
28255 ragr=0.00001d0+(nagr-0.00002d0)*pyr(0)
28256 iagr=0
28257 DO 130 j=1,3
28258 IF(kflr.EQ.kfl(j)) ragr=ragr-1d0
28259 IF(iagr.EQ.0.AND.ragr.LE.0d0) iagr=j
28260 130 CONTINUE
28261 ELSE
28262 iagr=1.00001d0+2.99998d0*pyr(0)
28263 ENDIF
28264 id1=1
28265 IF(iagr.EQ.1) id1=2
28266 IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3
28267 id2=6-iagr-id1
28268 ksp=3
28269 IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN
28270 IF(iagr.NE.3.AND.pyr(0).GT.0.25d0) ksp=1
28271 ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN
28272 IF(iagr.NE.1.AND.pyr(0).GT.0.25d0) ksp=1
28273 ELSEIF(mod(kfa,10).EQ.2) THEN
28274 IF(iagr.EQ.1) ksp=1
28275 IF(iagr.NE.1.AND.pyr(0).GT.0.75d0) ksp=1
28276 ENDIF
28277 kflsp=1000*kfl(id1)+100*kfl(id2)+ksp
28278 IF(kflr.EQ.21) THEN
28279 kflch=kfl(iagr)
28280 ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN
28281 ntry=0
28282 140 ntry=ntry+1
28283 CALL pykfdi(-kflr,kfl(iagr),kfdump,kflch)
28284 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
28285 GOTO 140
28286 ELSEIF(kflch.EQ.0) THEN
28287 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
28288 mint(51)=1
28289 RETURN
28290 ENDIF
28291 ELSEIF(nagr.EQ.0) THEN
28292 ntry=0
28293 150 ntry=ntry+1
28294 CALL pykfdi(10000*kfl(id1)+kflsp,-kflr,kfdump,kflch)
28295 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
28296 GOTO 150
28297 ELSEIF(kflch.EQ.0) THEN
28298 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
28299 mint(51)=1
28300 RETURN
28301 ENDIF
28302 kflsp=kfl(iagr)
28303 ENDIF
28304 ENDIF
28305
28306C...Add on correct sign for result.
28307 kflch=kflch*kfs
28308 kflsp=kflsp*kfs
28309
28310 RETURN
28311 END
28312
28313C*********************************************************************
28314
28315C...PYGAMM
28316C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
28317C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
28318C...(Dover, 1965) 6.1.36.
28319
28320 FUNCTION pygamm(X)
28321
28322C...Double precision and integer declarations.
28323 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28324 IMPLICIT INTEGER(I-N)
28325 INTEGER PYK,PYCHGE,PYCOMP
28326C...Local array and data.
28327 dimension b(8)
28328 DATA b/-0.577191652d0,0.988205891d0,-0.897056937d0,0.918206857d0,
28329 &-0.756704078d0,0.482199394d0,-0.193527818d0,0.035868343d0/
28330
28331 nx=int(x)
28332 dx=x-nx
28333
28334 pygamm=1d0
28335 dxp=1d0
28336 DO 100 i=1,8
28337 dxp=dxp*dx
28338 pygamm=pygamm+b(i)*dxp
28339 100 CONTINUE
28340 IF(x.LT.1d0) THEN
28341 pygamm=pygamm/x
28342 ELSE
28343 DO 110 ix=1,nx-1
28344 pygamm=(x-ix)*pygamm
28345 110 CONTINUE
28346 ENDIF
28347
28348 RETURN
28349 END
28350
28351C***********************************************************************
28352
28353C...PYWAUX
28354C...Calculates real and imaginary parts of the auxiliary functions W1
28355C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
28356C...der Bij, Nucl. Phys. B297 (1988) 221.
28357
28358 SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)
28359
28360C...Double precision and integer declarations.
28361 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28362 IMPLICIT INTEGER(I-N)
28363 INTEGER PYK,PYCHGE,PYCOMP
28364C...Commonblocks.
28365 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28366 SAVE /pydat1/
28367
28368 asinh(x)=log(x+sqrt(x**2+1d0))
28369 acosh(x)=log(x+sqrt(x**2-1d0))
28370
28371 IF(eps.LT.0d0) THEN
28372 IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*asinh(sqrt(-1d0/eps))
28373 IF(iaux.EQ.2) wre=4d0*(asinh(sqrt(-1d0/eps)))**2
28374 wim=0d0
28375 ELSEIF(eps.LT.1d0) THEN
28376 IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*acosh(sqrt(1d0/eps))
28377 IF(iaux.EQ.2) wre=4d0*(acosh(sqrt(1d0/eps)))**2-paru(1)**2
28378 IF(iaux.EQ.1) wim=-paru(1)*sqrt(1d0-eps)
28379 IF(iaux.EQ.2) wim=-4d0*paru(1)*acosh(sqrt(1d0/eps))
28380 ELSE
28381 IF(iaux.EQ.1) wre=2d0*sqrt(eps-1d0)*asin(sqrt(1d0/eps))
28382 IF(iaux.EQ.2) wre=-4d0*(asin(sqrt(1d0/eps)))**2
28383 wim=0d0
28384 ENDIF
28385
28386 RETURN
28387 END
28388
28389C***********************************************************************
28390
28391C...PYI3AU
28392C...Calculates real and imaginary parts of the auxiliary function I3;
28393C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
28394C...Nucl. Phys. B297 (1988) 221.
28395
28396 SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)
28397
28398C...Double precision and integer declarations.
28399 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28400 IMPLICIT INTEGER(I-N)
28401 INTEGER PYK,PYCHGE,PYCOMP
28402C...Commonblocks.
28403 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28404 SAVE /pydat1/
28405
28406 be=0.5d0*(1d0+sqrt(1d0+rat*eps))
28407 IF(eps.LT.1d0) ga=0.5d0*(1d0+sqrt(1d0-eps))
28408
28409 IF(eps.LT.0d0) THEN
28410 IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
28411 f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
28412 & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
28413 & pyspen(0.25d0*(rat+1d0)*eps/(1d0+0.25d0*rat*eps),0d0,1)-
28414 & pyspen((rat+1d0)/rat,0d0,1)+0.5d0*(log(1d0+0.25d0*rat*eps)**2-
28415 & log(0.25d0*rat*eps)**2)+log(1d0-0.25d0*eps)*
28416 & log((1d0+0.25d0*(rat-1d0)*eps)/(1d0+0.25d0*rat*eps))+
28417 & log(-0.25d0*eps)*log(0.25d0*rat*eps/(1d0+0.25d0*(rat-1d0)*
28418 & eps))
28419 ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
28420 f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
28421 & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
28422 & pyspen((be-1d0+0.25d0*eps)/be,0d0,1)-
28423 & pyspen((be-1d0+0.25d0*eps)/(be-1d0),0d0,1)+
28424 & 0.5d0*(log(be)**2-log(be-1d0)**2)+
28425 & log(1d0-0.25d0*eps)*log((be-0.25d0*eps)/be)+
28426 & log(-0.25d0*eps)*log((be-1d0)/(be-0.25d0*eps))
28427 ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
28428 f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
28429 & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
28430 & pyspen((1d0+0.25d0*rat*eps-ga)/(1d0+0.25d0*rat*eps),0d0,1)-
28431 & pyspen((1d0+0.25d0*rat*eps-ga)/(0.25d0*rat*eps),0d0,1)+
28432 & 0.5d0*(log(1d0+0.25d0*rat*eps)**2-log(0.25d0*rat*eps)**2)+
28433 & log(ga)*log((ga+0.25d0*rat*eps)/(1d0+0.25d0*rat*eps))+
28434 & log(ga-1d0)*log(0.25d0*rat*eps/(ga+0.25d0*rat*eps))
28435 ELSE
28436 f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
28437 & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen((be-ga)/be,0d0,1)-
28438 & pyspen((be-ga)/(be-1d0),0d0,1)+0.5d0*(log(be)**2-
28439 & log(be-1d0)**2)+log(ga)*log((ga+be-1d0)/be)+
28440 & log(ga-1d0)*log((be-1d0)/(ga+be-1d0))
28441 ENDIF
28442 f3im=0d0
28443 ELSEIF(eps.LT.1d0) THEN
28444 IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
28445 f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
28446 & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
28447 & pyspen((1d0-0.25d0*eps)/(-0.25d0*(rat+1d0)*eps),0d0,1)-
28448 & pyspen(1d0/(rat+1d0),0d0,1)+log((1d0-0.25d0*eps)/
28449 & (0.25d0*eps))*log((1d0+0.25d0*(rat-1d0)*eps)/
28450 & (0.25d0*(rat+1d0)*eps))
28451 f3im=-paru(1)*log((1d0+0.25d0*(rat-1d0)*eps)/
28452 & (0.25d0*(rat+1d0)*eps))
28453 ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
28454 f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
28455 & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
28456 & pyspen((1d0-0.25d0*eps)/(1d0-0.25d0*eps-be),0d0,1)-
28457 & pyspen(-0.25d0*eps/(1d0-0.25d0*eps-be),0d0,1)+
28458 & log((1d0-0.25d0*eps)/(0.25d0*eps))*
28459 & log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
28460 f3im=-paru(1)*log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
28461 ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
28462 f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
28463 & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
28464 & pyspen(ga/(ga-1d0-0.25d0*rat*eps),0d0,1)-
28465 & pyspen((ga-1d0)/(ga-1d0-0.25d0*rat*eps),0d0,1)+
28466 & log(ga/(1d0-ga))*log((ga+0.25d0*rat*eps)/
28467 & (1d0+0.25d0*rat*eps-ga))
28468 f3im=-paru(1)*log((ga+0.25d0*rat*eps)/
28469 & (1d0+0.25d0*rat*eps-ga))
28470 ELSE
28471 f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
28472 & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen(ga/(ga-be),0d0,1)-
28473 & pyspen((ga-1d0)/(ga-be),0d0,1)+log(ga/(1d0-ga))*
28474 & log((ga+be-1d0)/(be-ga))
28475 f3im=-paru(1)*log((ga+be-1d0)/(be-ga))
28476 ENDIF
28477 ELSE
28478 rsq=eps/(eps-1d0+(2d0*be-1d0)**2)
28479 rcthe=rsq*(1d0-2d0*be/eps)
28480 rsthe=sqrt(max(0d0,rsq-rcthe**2))
28481 rcphi=rsq*(1d0+2d0*(be-1d0)/eps)
28482 rsphi=sqrt(max(0d0,rsq-rcphi**2))
28483 r=sqrt(rsq)
28484 the=acos(max(-0.999999d0,min(0.999999d0,rcthe/r)))
28485 phi=acos(max(-0.999999d0,min(0.999999d0,rcphi/r)))
28486 f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-
28487 & pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+
28488 & (phi-the)*(phi+the-paru(1))
28489 f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-
28490 & pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)
28491 ENDIF
28492
28493 y3re=2d0/(2d0*be-1d0)*f3re
28494 y3im=2d0/(2d0*be-1d0)*f3im
28495
28496 RETURN
28497 END
28498
28499C***********************************************************************
28500
28501C...PYSPEN
28502C...Calculates real and imaginary part of Spence function; see
28503C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
28504
28505 FUNCTION pyspen(XREIN,XIMIN,IREIM)
28506
28507C...Double precision and integer declarations.
28508 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28509 IMPLICIT INTEGER(I-N)
28510 INTEGER PYK,PYCHGE,PYCOMP
28511C...Commonblocks.
28512 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28513 SAVE /pydat1/
28514C...Local array and data.
28515 dimension b(0:14)
28516 DATA b/
28517 &1.000000d+00, -5.000000d-01, 1.666667d-01,
28518 &0.000000d+00, -3.333333d-02, 0.000000d+00,
28519 &2.380952d-02, 0.000000d+00, -3.333333d-02,
28520 &0.000000d+00, 7.575757d-02, 0.000000d+00,
28521 &-2.531135d-01, 0.000000d+00, 1.166667d+00/
28522
28523 xre=xrein
28524 xim=ximin
28525 IF(abs(1d0-xre).LT.1d-6.AND.abs(xim).LT.1d-6) THEN
28526 IF(ireim.EQ.1) pyspen=paru(1)**2/6d0
28527 IF(ireim.EQ.2) pyspen=0d0
28528 RETURN
28529 ENDIF
28530
28531 xmod=sqrt(xre**2+xim**2)
28532 IF(xmod.LT.1d-6) THEN
28533 IF(ireim.EQ.1) pyspen=0d0
28534 IF(ireim.EQ.2) pyspen=0d0
28535 RETURN
28536 ENDIF
28537
28538 xarg=sign(acos(xre/xmod),xim)
28539 sp0re=0d0
28540 sp0im=0d0
28541 sgn=1d0
28542 IF(xmod.GT.1d0) THEN
28543 algxre=log(xmod)
28544 algxim=xarg-sign(paru(1),xarg)
28545 sp0re=-paru(1)**2/6d0-(algxre**2-algxim**2)/2d0
28546 sp0im=-algxre*algxim
28547 sgn=-1d0
28548 xmod=1d0/xmod
28549 xarg=-xarg
28550 xre=xmod*cos(xarg)
28551 xim=xmod*sin(xarg)
28552 ENDIF
28553 IF(xre.GT.0.5d0) THEN
28554 algxre=log(xmod)
28555 algxim=xarg
28556 xre=1d0-xre
28557 xim=-xim
28558 xmod=sqrt(xre**2+xim**2)
28559 xarg=sign(acos(xre/xmod),xim)
28560 algyre=log(xmod)
28561 algyim=xarg
28562 sp0re=sp0re+sgn*(paru(1)**2/6d0-(algxre*algyre-algxim*algyim))
28563 sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)
28564 sgn=-sgn
28565 ENDIF
28566
28567 xre=1d0-xre
28568 xim=-xim
28569 xmod=sqrt(xre**2+xim**2)
28570 xarg=sign(acos(xre/xmod),xim)
28571 zre=-log(xmod)
28572 zim=-xarg
28573
28574 spre=0d0
28575 spim=0d0
28576 savere=1d0
28577 saveim=0d0
28578 DO 100 i=0,14
28579 IF(max(abs(savere),abs(saveim)).LT.1d-30) GOTO 110
28580 termre=(savere*zre-saveim*zim)/dble(i+1)
28581 termim=(savere*zim+saveim*zre)/dble(i+1)
28582 savere=termre
28583 saveim=termim
28584 spre=spre+b(i)*termre
28585 spim=spim+b(i)*termim
28586 100 CONTINUE
28587
28588 110 IF(ireim.EQ.1) pyspen=sp0re+sgn*spre
28589 IF(ireim.EQ.2) pyspen=sp0im+sgn*spim
28590
28591 RETURN
28592 END
28593
28594C***********************************************************************
28595
28596C...PYQQBH
28597C...Calculates the matrix element for the processes
28598C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
28599C...REDUCE output and part of the rest courtesy Z. Kunszt, see
28600C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
28601
28602 SUBROUTINE pyqqbh(WTQQBH)
28603
28604C...Double precision and integer declarations.
28605 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28606 IMPLICIT INTEGER(I-N)
28607 INTEGER PYK,PYCHGE,PYCOMP
28608C...Commonblocks.
28609 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28610 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28611 common/pypars/mstp(200),parp(200),msti(200),pari(200)
28612 common/pyint1/mint(400),vint(400)
28613 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
28614 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/
28615C...Local arrays and function.
28616 dimension pp(15,4),clr(8,8),fm(10,10),rm(8,8),dx(8)
28617 dot(i,j)=pp(i,4)*pp(j,4)-pp(i,1)*pp(j,1)-pp(i,2)*pp(j,2)-
28618 &pp(i,3)*pp(j,3)
28619
28620C...Mass parameters.
28621 wtqqbh=0d0
28622 isub=mint(1)
28623 shpr=sqrt(vint(26))*vint(1)
28624 pq=pmas(pycomp(kfpr(isub,2)),1)
28625 ph=sqrt(vint(21))*vint(1)
28626 spq=pq**2
28627 sph=ph**2
28628
28629C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
28630 DO 100 i=1,2
28631 pt=sqrt(max(0d0,vint(197+5*i)))
28632 pp(i,1)=pt*cos(vint(198+5*i))
28633 pp(i,2)=pt*sin(vint(198+5*i))
28634 100 CONTINUE
28635 pp(3,1)=-pp(1,1)-pp(2,1)
28636 pp(3,2)=-pp(1,2)-pp(2,2)
28637 pms1=spq+pp(1,1)**2+pp(1,2)**2
28638 pms2=spq+pp(2,1)**2+pp(2,2)**2
28639 pms3=sph+pp(3,1)**2+pp(3,2)**2
28640 pmt3=sqrt(pms3)
28641 pp(3,3)=pmt3*sinh(vint(211))
28642 pp(3,4)=pmt3*cosh(vint(211))
28643 pms12=(shpr-pp(3,4))**2-pp(3,3)**2
28644 pp(1,3)=(-pp(3,3)*(pms12+pms1-pms2)+
28645 &vint(213)*(shpr-pp(3,4))*vint(220))/(2d0*pms12)
28646 pp(2,3)=-pp(1,3)-pp(3,3)
28647 pp(1,4)=sqrt(pms1+pp(1,3)**2)
28648 pp(2,4)=sqrt(pms2+pp(2,3)**2)
28649
28650C...Set up incoming kinematics and derived momentum combinations.
28651 DO 110 i=4,5
28652 pp(i,1)=0d0
28653 pp(i,2)=0d0
28654 pp(i,3)=-0.5d0*shpr*(-1)**i
28655 pp(i,4)=-0.5d0*shpr
28656 110 CONTINUE
28657 DO 120 j=1,4
28658 pp(6,j)=pp(1,j)+pp(2,j)
28659 pp(7,j)=pp(1,j)+pp(3,j)
28660 pp(8,j)=pp(1,j)+pp(4,j)
28661 pp(9,j)=pp(1,j)+pp(5,j)
28662 pp(10,j)=-pp(2,j)-pp(3,j)
28663 pp(11,j)=-pp(2,j)-pp(4,j)
28664 pp(12,j)=-pp(2,j)-pp(5,j)
28665 pp(13,j)=-pp(4,j)-pp(5,j)
28666 120 CONTINUE
28667
28668C...Derived kinematics invariants.
28669 x1=dot(1,2)
28670 x2=dot(1,3)
28671 x3=dot(1,4)
28672 x4=dot(1,5)
28673 x5=dot(2,3)
28674 x6=dot(2,4)
28675 x7=dot(2,5)
28676 x8=dot(3,4)
28677 x9=dot(3,5)
28678 x10=dot(4,5)
28679
28680C...Propagators.
28681 ss1=dot(7,7)-spq
28682 ss2=dot(8,8)-spq
28683 ss3=dot(9,9)-spq
28684 ss4=dot(10,10)-spq
28685 ss5=dot(11,11)-spq
28686 ss6=dot(12,12)-spq
28687 ss7=dot(13,13)
28688 dx(1)=ss1*ss6
28689 dx(2)=ss2*ss6
28690 dx(3)=ss2*ss4
28691 dx(4)=ss1*ss5
28692 dx(5)=ss3*ss5
28693 dx(6)=ss3*ss4
28694 dx(7)=ss7*ss1
28695 dx(8)=ss7*ss4
28696
28697C...Define colour coefficients for g + g -> Q + Qbar + H.
28698 IF(isub.EQ.121.OR.isub.EQ.181.OR.isub.EQ.186) THEN
28699 DO 140 i=1,3
28700 DO 130 j=1,3
28701 clr(i,j)=16d0/3d0
28702 clr(i+3,j+3)=16d0/3d0
28703 clr(i,j+3)=-2d0/3d0
28704 clr(i+3,j)=-2d0/3d0
28705 130 CONTINUE
28706 140 CONTINUE
28707 DO 160 l=1,2
28708 DO 150 i=1,3
28709 clr(i,6+l)=-6d0
28710 clr(i+3,6+l)=6d0
28711 clr(6+l,i)=-6d0
28712 clr(6+l,i+3)=6d0
28713 150 CONTINUE
28714 160 CONTINUE
28715 DO 180 k1=1,2
28716 DO 170 k2=1,2
28717 clr(6+k1,6+k2)=12d0
28718 170 CONTINUE
28719 180 CONTINUE
28720
28721C...Evaluate matrix elements for g + g -> Q + Qbar + H.
28722 fm(1,1)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x4+x9+2*
28723 & x7+x5)+8*pq**2*ph**2*(-x1-x4+2*x7)+16*pq**2*(x2*x9+4*x2*
28724 & x7+x2*x5-2*x4*x7-2*x9*x7)+8*ph**2*x4*x7-16*x2*x9*x7
28725 fm(1,2)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10+x9-x8+2
28726 & *x7-4*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x4-2*x2*x10+x2*x7-2*
28727 & x2*x6-2*x3*x7+2*x4*x7+4*x10*x7-x9*x7-x8*x7)+16*x2*x7*(x4+
28728 & x10)
28729 fm(1,3)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-2*x3-4*
28730 & x4-8*x10+x9+x8-2*x7-4*x6+2*x5)-(4*pq**2*ph**2)*(x1+x4+x10
28731 & +x6)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
28732 & -4*x2*x4-5*x2*x10+x2*x8-x2*x7-3*x2*x6+x2*x5+x3*x9+2*x3*x7
28733 & -x3*x5+x4*x8+2*x4*x6-3*x4*x5-5*x10*x5+x9*x8+x9*x6+x9*x5+
28734 & x8*x7-4*x6*x5+x5**2)-(16*x2*x5)*(x1+x4+x10+x6)
28735 fm(1,4)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1+x2-x3-x4+x10-
28736 & x9-x8+2*x7+2*x6-x5)+4*pq**2*ph**2*(x1+x3+x4+x10+2*x7+2*x6
28737 & )+8*pq**2*(4*x1*x10+4*x1*x7+4*x1*x6+2*x2*x10-x2*x9-x2*x8+
28738 & 4*x2*x7+4*x2*x6-x2*x5+4*x10*x5+4*x7*x5+4*x6*x5)-(8*ph**2*
28739 & x1)*(x10+x7+x6)+16*x2*x5*(x10+x7+x6)
28740 fm(1,5)=8*pq**4*(-2*x1-2*x4+x10-x9)+4*pq**2*(4*x1**2-2*x1*
28741 & x2+8*x1*x3+6*x1*x10-2*x1*x9+4*x1*x8+4*x1*x7+4*x1*x6+2*x1*
28742 & x5+x2*x10+4*x3*x4-x3*x9+2*x3*x7+3*x4*x8-2*x4*x6+2*x4*x5-4
28743 & *x10*x7+3*x10*x5-3*x9*x6+3*x8*x7-4*x7**2+4*x7*x5)+8*(x1**
28744 & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5-x1*x4*
28745 & x8-x1*x4*x5+x1*x10*x9+x1*x9*x7+x1*x9*x6-x1*x8*x7-x2*x3*x7
28746 & +x2*x4*x6-x2*x10*x7-x2*x7**2+x3*x7*x5-x4*x10*x5-x4*x7*x5-
28747 & x4*x6*x5)
28748 fm(1,6)=16*pq**4*(-4*x1-x4+x9-x7)+4*pq**2*ph**2*(-2*x1-x4-
28749 & x7)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x4-3*x1*x9-2*x1*x7-3*
28750 & x1*x5-2*x2*x4-2*x7*x5)-8*ph**2*x4*x7+8*(-x1*x2*x9-2*x1*x2
28751 & *x5-x1*x9**2-x1*x9*x5+x2**2*x7-x2*x4*x5+x2*x9*x7-x2*x7*x5
28752 & +x4*x9*x5+x4*x5**2)
28753 fm(1,7)=8*pq**4*(2*x3+x4+3*x10+x9+2*x8+3*x7+6*x6)+2*pq**2*
28754 & ph**2*(-2*x3-x4+3*x10+3*x7+6*x6)+4*pq**2*(4*x1*x10+4*x1*
28755 & x7+8*x1*x6+6*x2*x10+x2*x9+2*x2*x8+6*x2*x7+12*x2*x6-8*x3*
28756 & x7+4*x4*x7+4*x4*x6+4*x10*x5+4*x9*x7+4*x9*x6-8*x8*x7+4*x7*
28757 & x5+8*x6*x5)+4*ph**2*(-x1*x10-x1*x7-2*x1*x6+2*x3*x7-x4*x7-
28758 & x4*x6)+8*x2*(x10*x5+x9*x7+x9*x6-2*x8*x7+x7*x5+2*x6*x5)
28759 fm(1,8)=8*pq**4*(2*x3+x4+3*x10+2*x9+x8+3*x7+6*x6)+2*pq**2*
28760 & ph**2*(-2*x3-x4+2*x10+x7+2*x6)+4*pq**2*(4*x1*x10-2*x1*x9+
28761 & 2*x1*x8+4*x1*x7+8*x1*x6+5*x2*x10+2*x2*x9+x2*x8+4*x2*x7+8*
28762 & x2*x6-x3*x9-8*x3*x7+2*x3*x5+2*x4*x9-x4*x8+4*x4*x7+4*x4*x6
28763 & +4*x4*x5+5*x10*x5+x9**2-x9*x8+2*x9*x7+5*x9*x6+x9*x5-7*x8*
28764 & x7+2*x8*x5+2*x7*x5+10*x6*x5)+2*ph**2*(-x1*x10+x3*x7-2*x4*
28765 & x7+x4*x6)+4*(-x1*x9**2+x1*x9*x8-2*x1*x9*x5-x1*x8*x5+2*x2*
28766 & x10*x5+x2*x9*x7+x2*x9*x6-2*x2*x8*x7+3*x2*x6*x5+x3*x9*x5+
28767 & x3*x5**2+x4*x9*x5-2*x4*x8*x5+2*x4*x5**2)
28768 fm(2,2)=16*pq**6+16*pq**4*(-x1+x3-x4-x10+x7-x6)+16*pq**2*(
28769 & x3*x10+x3*x7+x3*x6+x4*x7+x10*x7)-16*x3*x10*x7
28770 fm(2,3)=16*pq**6+8*pq**4*(-2*x1+x2+2*x3-4*x4-4*x10-x9+x8-2
28771 & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5+4*x3*x10-x3*x9-x3*x8-2*x3*
28772 & x7+2*x3*x6+x3*x5-2*x4*x5-2*x10*x5-2*x6*x5)+16*x3*x5*(x10+
28773 & x6)
28774 fm(2,4)=8*pq**4*(-2*x1-2*x3+x10-x8)+4*pq**2*(4*x1**2-2*x1*
28775 & x2+8*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+4*x1*x7+4*x1*x6+2*x1*
28776 & x5+x2*x10+4*x3*x4+3*x3*x9-2*x3*x7+2*x3*x5-x4*x8+2*x4*x6-4
28777 & *x10*x6+3*x10*x5+3*x9*x6-3*x8*x7-4*x6**2+4*x6*x5)+8*(-x1
28778 & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9-x1*x3*x5+x1*x4
28779 & *x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x1*x8*x6+x2*x3*
28780 & x7-x2*x4*x6-x2*x10*x6-x2*x6**2-x3*x10*x5-x3*x7*x5-x3*x6*
28781 & x5+x4*x6*x5)
28782 fm(2,5)=16*pq**4*x10+8*pq**2*(2*x1**2+2*x1*x3+2*x1*x4+2*x1
28783 & *x10+2*x1*x7+2*x1*x6+x3*x7+x4*x6)+8*(-2*x1**3-2*x1**2*x3-
28784 & 2*x1**2*x4-2*x1**2*x10-2*x1**2*x7-2*x1**2*x6-2*x1*x3*x4-
28785 & x1*x3*x10-2*x1*x3*x6-x1*x4*x10-2*x1*x4*x7-x1*x10**2-x1*
28786 & x10*x7-x1*x10*x6-2*x1*x7*x6+x3**2*x7-x3*x4*x7-x3*x4*x6+x3
28787 & *x10*x7+x3*x7**2-x3*x7*x6+x4**2*x6+x4*x10*x6-x4*x7*x6+x4*
28788 & x6**2)
28789 fm(2,6)=8*pq**4*(-2*x1+x10-x9-2*x7)+4*pq**2*(4*x1**2+2*x1*
28790 & x2+4*x1*x3+4*x1*x4+6*x1*x10-2*x1*x9+4*x1*x8+8*x1*x6-2*x1*
28791 & x5+4*x2*x4+3*x2*x10+2*x2*x7-3*x3*x9-2*x3*x7-4*x4**2-4*x4*
28792 & x10+3*x4*x8+2*x4*x6+x10*x5-x9*x6+3*x8*x7+4*x7*x6)+8*(x1**
28793 & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5+x1*x4*
28794 & x9-x1*x4*x8-x1*x4*x5+x1*x10*x9+x1*x9*x6-x1*x8*x7-x2*x3*x7
28795 & -x2*x4*x7+x2*x4*x6-x2*x10*x7+x3*x7*x5-x4**2*x5-x4*x10*x5-
28796 & x4*x6*x5)
28797 fm(2,7)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
28798 & 2*x1*x4-2*x1*x10+x1*x9-x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
28799 & x4+3*x2*x10+x2*x7+2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9-2*x3*
28800 & x7-4*x3*x6-x3*x5-6*x4**2-6*x4*x10-3*x4*x9-x4*x8-4*x4*x7-2
28801 & *x4*x6-2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+x10*x5
28802 & +x9*x7-2*x8*x7-2*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
28803 & -x1**2*x9+x1**2*x8-2*x1*x2*x10-3*x1*x2*x7-3*x1*x2*x6+x1*
28804 & x3*x9-x1*x3*x5+x1*x4*x9+x1*x4*x8+x1*x4*x5+x1*x10*x9+x1*
28805 & x10*x8-x1*x9*x6+x1*x8*x6+x2*x3*x7-3*x2*x4*x7-x2*x4*x6-3*
28806 & x2*x10*x7-3*x2*x10*x6-3*x2*x7*x6-3*x2*x6**2-2*x3*x4*x5-x3
28807 & *x10*x5-x3*x6*x5-x4**2*x5-x4*x10*x5+x4*x6*x5)
28808 fm(2,8)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
28809 & 2*x1*x4-2*x1*x10-x1*x9+x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
28810 & x4+x2*x10-x2*x7-2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9+x3*x8-2*
28811 & x3*x7-4*x3*x6+x3*x5-6*x4**2-6*x4*x10-2*x4*x9-4*x4*x7-2*x4
28812 & *x6+2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+3*x10*x5-
28813 & x9*x6-2*x8*x7-3*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
28814 & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6-3*x1*x3*x5+x1*x4*x9-
28815 & x1*x4*x8-3*x1*x4*x5+x1*x10*x9+x1*x10*x8-2*x1*x10*x5+x1*x9
28816 & *x6+x1*x8*x7+x1*x8*x6-x2*x4*x7+x2*x4*x6-x2*x10*x7-x2*x10*
28817 & x6-2*x2*x7*x6-x2*x6**2-3*x3*x4*x5-3*x3*x10*x5+x3*x7*x5-3*
28818 & x3*x6*x5-3*x4**2*x5-3*x4*x10*x5-x4*x6*x5)
28819 fm(3,3)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x3+x8+x6
28820 & +2*x5)+8*pq**2*ph**2*(-x1+2*x3-x6)+16*pq**2*(x2*x5-2*x3*
28821 & x8-2*x3*x6+4*x3*x5+x8*x5)+8*ph**2*x3*x6-16*x3*x8*x5
28822 fm(3,4)=16*pq**4*(-4*x1-x3+x8-x6)+4*pq**2*ph**2*(-2*x1-x3-
28823 & x6)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x3-3*x1*x8-2*x1*x6-3*
28824 & x1*x5-2*x2*x3-2*x6*x5)-8*ph**2*x3*x6+8*(-x1*x2*x8-2*x1*x2
28825 & *x5-x1*x8**2-x1*x8*x5+x2**2*x6-x2*x3*x5+x2*x8*x6-x2*x6*x5
28826 & +x3*x8*x5+x3*x5**2)
28827 fm(3,5)=8*pq**4*(-2*x1+x10-x8-2*x6)+4*pq**2*(4*x1**2+2*x1*
28828 & x2+4*x1*x3+4*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+8*x1*x7-2*x1*
28829 & x5+4*x2*x3+3*x2*x10+2*x2*x6-4*x3**2-4*x3*x10+3*x3*x9+2*x3
28830 & *x7-3*x4*x8-2*x4*x6+x10*x5+3*x9*x6-x8*x7+4*x7*x6)+8*(-x1
28831 & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9+x1*x3*x8-x1*x3
28832 & *x5+x1*x4*x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x2*x3*
28833 & x7-x2*x3*x6-x2*x4*x6-x2*x10*x6-x3**2*x5-x3*x10*x5-x3*x7*
28834 & x5+x4*x6*x5)
28835 fm(3,6)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1-x2+2*x3+2*x4+
28836 & x10-x9-x8-x7-x6+x5)+4*pq**2*ph**2*(x1+2*x3+2*x4+x10+x7+x6
28837 & )+8*pq**2*(4*x1*x3+4*x1*x4+4*x1*x10+4*x2*x3+4*x2*x4+4*x2*
28838 & x10-x2*x5+4*x3*x5+4*x4*x5+2*x10*x5-x9*x5-x8*x5)-(8*ph**2*
28839 & x1)*(x3+x4+x10)+16*x2*x5*(x3+x4+x10)
28840 fm(3,7)=8*pq**4*(3*x3+6*x4+3*x10+x9+2*x8+2*x7+x6)+2*pq**2*
28841 & ph**2*(x3+2*x4+2*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+4*
28842 & x1*x10+2*x1*x9-2*x1*x8+2*x2*x3+10*x2*x4+5*x2*x10+2*x2*x9+
28843 & x2*x8+2*x2*x7+4*x2*x6-7*x3*x9+2*x3*x8-8*x3*x7+4*x3*x6+4*
28844 & x3*x5+5*x4*x8+4*x4*x6+8*x4*x5+5*x10*x5-x9*x8-x9*x6+x9*x5+
28845 & x8**2-x8*x7+2*x8*x6+2*x8*x5)+2*ph**2*(-x1*x10+x3*x7-2*x3*
28846 & x6+x4*x6)+4*(-x1*x2*x9-2*x1*x2*x8+x1*x9*x8-x1*x8**2+x2**2
28847 & *x7+2*x2**2*x6+3*x2*x4*x5+2*x2*x10*x5-2*x2*x9*x6+x2*x8*x7
28848 & +x2*x8*x6-2*x3*x9*x5+x3*x8*x5+x4*x8*x5)
28849 fm(3,8)=8*pq**4*(3*x3+6*x4+3*x10+2*x9+x8+2*x7+x6)+2*pq**2*
28850 & ph**2*(3*x3+6*x4+3*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+
28851 & 4*x1*x10+4*x2*x3+8*x2*x4+4*x2*x10-8*x3*x9+4*x3*x8-8*x3*x7
28852 & +4*x3*x6+6*x3*x5+4*x4*x8+4*x4*x6+12*x4*x5+6*x10*x5+2*x9*
28853 & x5+x8*x5)+4*ph**2*(-x1*x3-2*x1*x4-x1*x10+2*x3*x7-x3*x6-x4
28854 & *x6)+8*x5*(x2*x3+2*x2*x4+x2*x10-2*x3*x9+x3*x8+x4*x8)
28855 fm(4,4)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x3+x8+2*
28856 & x6+x5)+8*pq**2*ph**2*(-x1-x3+2*x6)+16*pq**2*(x2*x8+4*x2*
28857 & x6+x2*x5-2*x3*x6-2*x8*x6)+8*ph**2*x3*x6-16*x2*x8*x6
28858 fm(4,5)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10-x9+x8-4
28859 & *x7+2*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x3-2*x2*x10-2*x2*x7+
28860 & x2*x6+2*x3*x6-2*x4*x6+4*x10*x6-x9*x6-x8*x6)+16*x2*x6*(x3+
28861 & x10)
28862 fm(4,6)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-4*x3-2*
28863 & x4-8*x10+x9+x8-4*x7-2*x6+2*x5)-(4*pq**2*ph**2)*(x1+x3+x10
28864 & +x7)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
28865 & -4*x2*x3-5*x2*x10+x2*x9-3*x2*x7-x2*x6+x2*x5+x3*x9+2*x3*x7
28866 & -3*x3*x5+x4*x8+2*x4*x6-x4*x5-5*x10*x5+x9*x8+x9*x6+x8*x7+
28867 & x8*x5-4*x7*x5+x5**2)-(16*x2*x5)*(x1+x3+x10+x7)
28868 fm(4,7)=8*pq**4*(-x3-2*x4-3*x10-2*x9-x8-6*x7-3*x6)+2*pq**2
28869 & *ph**2*(x3+2*x4-3*x10-6*x7-3*x6)+4*pq**2*(-4*x1*x10-8*x1*
28870 & x7-4*x1*x6-6*x2*x10-2*x2*x9-x2*x8-12*x2*x7-6*x2*x6-4*x3*
28871 & x7-4*x3*x6+8*x4*x6-4*x10*x5+8*x9*x6-4*x8*x7-4*x8*x6-8*x7*
28872 & x5-4*x6*x5)+4*ph**2*(x1*x10+2*x1*x7+x1*x6+x3*x7+x3*x6-2*
28873 & x4*x6)+8*x2*(-x10*x5+2*x9*x6-x8*x7-x8*x6-2*x7*x5-x6*x5)
28874 fm(4,8)=8*pq**4*(-x3-2*x4-3*x10-x9-2*x8-6*x7-3*x6)+2*pq**2
28875 & *ph**2*(x3+2*x4-2*x10-2*x7-x6)+4*pq**2*(-4*x1*x10-2*x1*x9
28876 & +2*x1*x8-8*x1*x7-4*x1*x6-5*x2*x10-x2*x9-2*x2*x8-8*x2*x7-4
28877 & *x2*x6+x3*x9-2*x3*x8-4*x3*x7-4*x3*x6-4*x3*x5+x4*x8+8*x4*
28878 & x6-2*x4*x5-5*x10*x5+x9*x8+7*x9*x6-2*x9*x5-x8**2-5*x8*x7-2
28879 & *x8*x6-x8*x5-10*x7*x5-2*x6*x5)+2*ph**2*(x1*x10-x3*x7+2*x3
28880 & *x6-x4*x6)+4*(-x1*x9*x8+x1*x9*x5+x1*x8**2+2*x1*x8*x5-2*x2
28881 & *x10*x5+2*x2*x9*x6-x2*x8*x7-x2*x8*x6-3*x2*x7*x5+2*x3*x9*
28882 & x5-x3*x8*x5-2*x3*x5**2-x4*x8*x5-x4*x5**2)
28883 fm(5,5)=16*pq**6+16*pq**4*(-x1-x3+x4-x10-x7+x6)+16*pq**2*(
28884 & x3*x6+x4*x10+x4*x7+x4*x6+x10*x6)-16*x4*x10*x6
28885 fm(5,6)=16*pq**6+8*pq**4*(-2*x1+x2-4*x3+2*x4-4*x10+x9-x8-2
28886 & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5-2*x3*x5+4*x4*x10-x4*x9-x4*
28887 & x8+2*x4*x7-2*x4*x6+x4*x5-2*x10*x5-2*x7*x5)+16*x4*x5*(x10+
28888 & x7)
28889 fm(5,7)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
28890 & 4*x1*x4+2*x1*x10+x1*x9-x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
28891 & x4-3*x2*x10-2*x2*x7-x2*x6+6*x3**2+6*x3*x4+6*x3*x10+x3*x9+
28892 & 3*x3*x8+2*x3*x7+4*x3*x6+2*x3*x5+6*x4*x10+2*x4*x8+4*x4*x7+
28893 & 2*x4*x6+x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-x10*x5+
28894 & 2*x9*x7+2*x9*x6-x8*x6+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(-
28895 & x1**2*x9+x1**2*x8+2*x1*x2*x10+3*x1*x2*x7+3*x1*x2*x6-x1*x3
28896 & *x9-x1*x3*x8-x1*x3*x5-x1*x4*x8+x1*x4*x5-x1*x10*x9-x1*x10*
28897 & x8-x1*x9*x7+x1*x8*x7+x2*x3*x7+3*x2*x3*x6-x2*x4*x6+3*x2*
28898 & x10*x7+3*x2*x10*x6+3*x2*x7**2+3*x2*x7*x6+x3**2*x5+2*x3*x4
28899 & *x5+x3*x10*x5-x3*x7*x5+x4*x10*x5+x4*x7*x5)
28900 fm(5,8)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
28901 & 4*x1*x4+2*x1*x10-x1*x9+x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
28902 & x4-x2*x10+2*x2*x7+x2*x6+6*x3**2+6*x3*x4+6*x3*x10+2*x3*x8+
28903 & 2*x3*x7+4*x3*x6-2*x3*x5+6*x4*x10-x4*x9+2*x4*x8+4*x4*x7+2*
28904 & x4*x6-x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-3*x10*x5+
28905 & 3*x9*x7+2*x9*x6+x8*x7+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(
28906 & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9-x1*x3*x8+3*
28907 & x1*x3*x5+3*x1*x4*x5-x1*x10*x9-x1*x10*x8+2*x1*x10*x5-x1*x9
28908 & *x7-x1*x9*x6-x1*x8*x7-x2*x3*x7+x2*x3*x6+x2*x10*x7+x2*x10*
28909 & x6+x2*x7**2+2*x2*x7*x6+3*x3**2*x5+3*x3*x4*x5+3*x3*x10*x5+
28910 & x3*x7*x5+3*x4*x10*x5+3*x4*x7*x5-x4*x6*x5)
28911 fm(6,6)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x4+x9+x7
28912 & +2*x5)+8*pq**2*ph**2*(-x1+2*x4-x7)+16*pq**2*(x2*x5-2*x4*
28913 & x9-2*x4*x7+4*x4*x5+x9*x5)+8*ph**2*x4*x7-16*x4*x9*x5
28914 fm(6,7)=8*pq**4*(-6*x3-3*x4-3*x10-2*x9-x8-x7-2*x6)+2*pq**2
28915 & *ph**2*(-2*x3-x4-2*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*x4
28916 & -4*x1*x10+2*x1*x9-2*x1*x8-10*x2*x3-2*x2*x4-5*x2*x10-x2*x9
28917 & -2*x2*x8-4*x2*x7-2*x2*x6-5*x3*x9-4*x3*x7-8*x3*x5-2*x4*x9+
28918 & 7*x4*x8-4*x4*x7+8*x4*x6-4*x4*x5-5*x10*x5-x9**2+x9*x8-2*x9
28919 & *x7+x9*x6-2*x9*x5+x8*x7-x8*x5)+2*ph**2*(x1*x10-x3*x7+2*x4
28920 & *x7-x4*x6)+4*(2*x1*x2*x9+x1*x2*x8+x1*x9**2-x1*x9*x8-2*x2
28921 & **2*x7-x2**2*x6-3*x2*x3*x5-2*x2*x10*x5-x2*x9*x7-x2*x9*x6+
28922 & 2*x2*x8*x7-x3*x9*x5-x4*x9*x5+2*x4*x8*x5)
28923 fm(6,8)=8*pq**4*(-6*x3-3*x4-3*x10-x9-2*x8-x7-2*x6)+2*pq**2
28924 & *ph**2*(-6*x3-3*x4-3*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*
28925 & x4-4*x1*x10-8*x2*x3-4*x2*x4-4*x2*x10-4*x3*x9-4*x3*x7-12*
28926 & x3*x5-4*x4*x9+8*x4*x8-4*x4*x7+8*x4*x6-6*x4*x5-6*x10*x5-x9
28927 & *x5-2*x8*x5)+4*ph**2*(2*x1*x3+x1*x4+x1*x10+x3*x7+x4*x7-2*
28928 & x4*x6)+8*x5*(-2*x2*x3-x2*x4-x2*x10-x3*x9-x4*x9+2*x4*x8)
28929 fm(7,7)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+9*
28930 & x2*x10+7*x3*x7+2*x3*x6+2*x4*x7+7*x4*x6+x10*x5+2*x9*x7+7*
28931 & x9*x6+7*x8*x7+2*x8*x6)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2
28932 & *x4*x7-7*x4*x6)+4*x2*(x10*x5+2*x9*x7+7*x9*x6+7*x8*x7+2*x8
28933 & *x6)
28934 fm(7,8)=72*pq**4*x10+2*pq**2*ph**2*x10+4*pq**2*(2*x1*x10+
28935 & 10*x2*x10+7*x3*x9+2*x3*x8+14*x3*x7+4*x3*x6+2*x4*x9+7*x4*
28936 & x8+4*x4*x7+14*x4*x6+10*x10*x5+x9**2+7*x9*x8+2*x9*x7+7*x9*
28937 & x6+x8**2+7*x8*x7+2*x8*x6)+2*ph**2*(7*x1*x10-7*x3*x7-2*x3*
28938 & x6-2*x4*x7-7*x4*x6)+2*(-2*x1*x9**2-14*x1*x9*x8-2*x1*x8**2
28939 & +2*x2*x10*x5+2*x2*x9*x7+7*x2*x9*x6+7*x2*x8*x7+2*x2*x8*x6+
28940 & 7*x3*x9*x5+2*x3*x8*x5+2*x4*x9*x5+7*x4*x8*x5)
28941 fm(8,8)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+x2
28942 & *x10+7*x3*x9+2*x3*x8+7*x3*x7+2*x3*x6+2*x4*x9+7*x4*x8+2*x4
28943 & *x7+7*x4*x6+9*x10*x5)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2*
28944 & x4*x7-7*x4*x6)+4*x5*(x2*x10+7*x3*x9+2*x3*x8+2*x4*x9+7*x4*
28945 & x8)
28946 fm(9,9)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
28947 & x3*x7+x4*x6-x10*x5+x9*x6+x8*x7)+ph**2*(x1*x10-x3*x7-x4*x6
28948 & )+2*x2*(-x10*x5+x9*x6+x8*x7)
28949 fm(9,10)=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
28950 & x10+2*x3*x9+2*x3*x7+2*x4*x6-2*x10*x5+x9*x8+2*x8*x7)+ph**2
28951 & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x8*x7+x3*
28952 & x9*x5)
28953 fmxx=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
28954 & x10+2*x4*x8+2*x4*x6+2*x3*x7-2*x10*x5+x9*x8+2*x9*x6)+ph**2
28955 & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x9*x6+x4*
28956 & x8*x5)
28957 fm(9,10)=0.5d0*(fmxx+fm(9,10))
28958 fm(10,10)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
28959 & x3*x7+x4*x6-x10*x5+x9*x3+x8*x4)+ph**2*(x1*x10-x3*x7-x4*x6
28960 & )+2*x5*(-x10*x2+x9*x3+x8*x4)
28961
28962C...Repackage matrix elements.
28963 DO 200 i=1,8
28964 DO 190 j=1,8
28965 rm(i,j)=fm(i,j)
28966 190 CONTINUE
28967 200 CONTINUE
28968 rm(7,7)=fm(7,7)-2d0*fm(9,9)
28969 rm(7,8)=fm(7,8)-2d0*fm(9,10)
28970 rm(8,8)=fm(8,8)-2d0*fm(10,10)
28971
28972C...Produce final result: matrix elements * colours * propagators.
28973 DO 220 i=1,8
28974 DO 210 j=i,8
28975 fac=8d0
28976 IF(i.EQ.j)fac=4d0
28977 wtqqbh=wtqqbh+rm(i,j)*fac*clr(i,j)/(dx(i)*dx(j))
28978 210 CONTINUE
28979 220 CONTINUE
28980 wtqqbh=-wtqqbh/256d0
28981
28982 ELSE
28983C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
28984 a11=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x2*x10+x3
28985 & *x7+x4*x6+x9*x6+x8*x7)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x2)*(x9
28986 & *x6+x8*x7)
28987 a12=-8d0*pq**4*x10+4d0*pq**2*(-x2*x10-x3*x9-2d0*x3*x7-x4*x8-
28988 & 2d0*x4*x6-x10*x5-x9*x8-x9*x6-x8*x7)+2d0*ph**2*(-x1*x10+x3*x7
28989 & +x4*x6)+2d0*(2d0*x1*x9*x8-x2*x9*x6-x2*x8*x7-x3*x9*x5-x4*x8*
28990 & x5)
28991 a22=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x3*x9+x3*
28992 & x7+x4*x8+x4*x6+x10*x5)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x5)*(x3
28993 & *x9+x4*x8)
28994
28995C...Produce final result: matrix elements * propagators.
28996 a11=a11/dx(7)**2
28997 a12=a12/(dx(7)*dx(8))
28998 a22=a22/dx(8)**2
28999 wtqqbh=-(a11+a22+2d0*a12)/8d0
29000 ENDIF
29001
29002 RETURN
29003 END
29004
29005C*********************************************************************
29006
29007C...PYMSIN
29008C...Initializes supersymmetry: finds sparticle masses and
29009C...branching ratios and stores this information.
29010C...AUTHOR: STEPHEN MRENNA
29011
29012 SUBROUTINE pymsin
29013
29014C...Double precision and integer declarations.
29015 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29016 IMPLICIT INTEGER(I-N)
29017 INTEGER PYK,PYCHGE,PYCOMP
29018C...Parameter statement to help give large particle numbers.
29019 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29020C...Commonblocks.
29021 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29022 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29023 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
29024 common/pypars/mstp(200),parp(200),msti(200),pari(200)
29025 common/pyint4/mwid(500),wids(500,5)
29026 common/pymssm/imss(0:99),rmss(0:99)
29027 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
29028 &sfmix(16,4)
29029 common/pyhtri/hhh(7)
29030 SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint4/,/pymssm/,
29031 &/pyssmt/
29032
29033C...Local variables.
29034 INTEGER NSTR
29035 DOUBLE PRECISION ALFA,BETA
29036 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
29037 DOUBLE PRECISION PYALEM
29038 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
29039 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
29040 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
29041 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
29042 1 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
29043 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
29044 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
29045 DOUBLE PRECISION DELM,XMDIF,BRLIM
29046 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
29047 DOUBLE PRECISION ARG,SGNMU,R,GAM
29048 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
29049 INTEGER IMSSM,KFHIGG
29050 INTEGER IRPRTY
29051 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
29052 SAVE init,mwidsu,mdcysu
29053 DATA kfsusy/
29054 &1000001,2000001,1000002,2000002,1000003,2000003,
29055 &1000004,2000004,1000005,2000005,1000006,2000006,
29056 &1000011,2000011,1000012,2000012,1000013,2000013,
29057 &1000014,2000014,1000015,2000015,1000016,2000016,
29058 &1000021,1000022,1000023,1000025,1000035,1000024,
29059 &1000037,1000039, 25, 35, 36, 37/
29060 DATA init/0/
29061
29062C...Do nothing if SUSY not requested.
29063 imssm=imss(1)
29064 IF(imssm.EQ.0) RETURN
29065
29066C...Save copy of MWID(KC) and MDCY(KC,1) values before
29067C...they are set to zero for the LSP.
29068 IF(init.EQ.0) THEN
29069 init=1
29070 DO 105 i=1,36
29071 kf=kfsusy(i)
29072 kc=pycomp(kf)
29073 mwidsu(i)=mwid(kc)
29074 mdcysu(i)=mdcy(kc,1)
29075 105 CONTINUE
29076 ENDIF
29077
29078C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
29079 DO 107 i=1,36
29080 kf=kfsusy(i)
29081 kc=pycomp(kf)
29082 IF(mdcy(kc,1).EQ.0.AND.mdcysu(i).NE.0) THEN
29083 mwid(kc)=mwidsu(i)
29084 mdcy(kc,1)=mdcysu(i)
29085 ENDIF
29086 107 CONTINUE
29087
29088C...First part of routine: set masses and couplings.
29089
29090C...Reset mixing values in sfermion sector to pure left/right.
29091 DO 100 i=1,16
29092 sfmix(i,1)=1d0
29093 sfmix(i,4)=1d0
29094 sfmix(i,2)=0d0
29095 sfmix(i,3)=0d0
29096 100 CONTINUE
29097
29098C...Common couplings.
29099 tanb=rmss(5)
29100 beta=atan(tanb)
29101 cosb=cos(beta)
29102 sinb=tanb*cosb
29103 cos2b=cos(2d0*beta)
29104 alfa=rmss(18)
29105 xmw2=pmas(24,1)**2
29106 xmz2=pmas(23,1)**2
29107 xw=paru(102)
29108
29109C...Define sparticle masses for a general MSSM simulation.
29110 IF(imssm.EQ.1) THEN
29111 IF(imss(9).EQ.0) rmss(22)=rmss(9)
29112 DO 110 i=1,5,2
29113 kc=pycomp(ksusy1+i)
29114 pmas(kc,1)=sqrt(rmss(8)**2-(2d0*xmw2+xmz2)*cos2b/6d0)
29115 kc=pycomp(ksusy2+i)
29116 pmas(kc,1)=sqrt(rmss(9)**2+(xmw2-xmz2)*cos2b/3d0)
29117 kc=pycomp(ksusy1+i+1)
29118 pmas(kc,1)=sqrt(rmss(8)**2+(4d0*xmw2-xmz2)*cos2b/6d0)
29119 kc=pycomp(ksusy2+i+1)
29120 pmas(kc,1)=sqrt(rmss(22)**2-(xmw2-xmz2)*cos2b*2d0/3d0)
29121 110 CONTINUE
29122 xarg=rmss(6)**2-pmas(24,1)**2*abs(cos(2d0*beta))
29123 IF(xarg.LT.0d0) THEN
29124 WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
29125 & ' FROM THE SUM RULE. '
29126 WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29127 RETURN
29128 ELSE
29129 xarg=sqrt(xarg)
29130 ENDIF
29131 DO 120 i=11,15,2
29132 pmas(pycomp(ksusy1+i),1)=rmss(6)
29133 pmas(pycomp(ksusy2+i),1)=rmss(7)
29134 pmas(pycomp(ksusy1+i+1),1)=xarg
29135 pmas(pycomp(ksusy2+i+1),1)=9999d0
29136 120 CONTINUE
29137 IF(imss(8).EQ.1) THEN
29138 rmss(13)=rmss(6)
29139 rmss(14)=rmss(7)
29140 ENDIF
29141
29142C...Alternatively derive masses from SUGRA relations.
29143 ELSEIF(imssm.EQ.2) THEN
29144 CALL pyapps
29145 ENDIF
29146
29147C...Add in extra D-term contributions.
29148 IF(imss(7).EQ.1) THEN
29149 r=0.43d0
29150 dx=rmss(23)
29151 dy=rmss(24)
29152 ds=rmss(25)
29153 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29154 WRITE(mstu(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
29155 WRITE(mstu(11),*) 'C IN A U(B-L) THEORY '
29156 WRITE(mstu(11),*) 'C DX = ',dx
29157 WRITE(mstu(11),*) 'C DY = ',dy
29158 WRITE(mstu(11),*) 'C DS = ',ds
29159 WRITE(mstu(11),*) 'C '
29160 dy=r*dy-4d0/33d0*(1d0-r)*dx+(1d0-r)/33d0*ds
29161 WRITE(mstu(11),*) 'C DY AT THE WEAK SCALE = ',dy
29162 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29163 dq2=dy/6d0-dx/3d0-ds/3d0
29164 du2=-2d0*dy/3d0-dx/3d0-ds/3d0
29165 dd2=dy/3d0+dx-2d0*ds/3d0
29166 dl2=-dy/2d0+dx-2d0*ds/3d0
29167 de2=dy-dx/3d0-ds/3d0
29168 dhu2=dy/2d0+2d0*dx/3d0+2d0*ds/3d0
29169 dhd2=-dy/2d0-2d0*dx/3d0+ds
29170 dmu2=(-dy/2d0-2d0/3d0*dx+(cosb**2-2d0*sinb**2/3d0)*ds)
29171 & /abs(cos2b)
29172 dma2 = 2d0*dmu2+dhu2+dhd2
29173 DO 130 i=1,5,2
29174 kc=pycomp(ksusy1+i)
29175 pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
29176 kc=pycomp(ksusy2+i)
29177 pmas(kc,1)=sqrt(pmas(kc,1)**2+dd2)
29178 kc=pycomp(ksusy1+i+1)
29179 pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
29180 kc=pycomp(ksusy2+i+1)
29181 pmas(kc,1)=sqrt(pmas(kc,1)**2+du2)
29182 130 CONTINUE
29183 DO 140 i=11,15,2
29184 kc=pycomp(ksusy1+i)
29185 pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
29186 kc=pycomp(ksusy2+i)
29187 pmas(kc,1)=sqrt(pmas(kc,1)**2+de2)
29188 kc=pycomp(ksusy1+i+1)
29189 pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
29190 140 CONTINUE
29191 IF(rmss(4)**2+dmu2.LT.0d0) THEN
29192 WRITE(mstu(11),*) ' MU2 DRIVEN NEGATIVE '
29193 stop
29194 ENDIF
29195 sgnmu=sign(1d0,rmss(4))
29196 rmss(4)=sgnmu*sqrt(rmss(4)**2+dmu2)
29197 arg=rmss(10)**2*sign(1d0,rmss(10))+dq2
29198 rmss(10)=sign(sqrt(abs(arg)),arg)
29199 arg=rmss(11)**2*sign(1d0,rmss(11))+dd2
29200 rmss(11)=sign(sqrt(abs(arg)),arg)
29201 arg=rmss(12)**2*sign(1d0,rmss(12))+du2
29202 rmss(12)=sign(sqrt(abs(arg)),arg)
29203 arg=rmss(13)**2*sign(1d0,rmss(13))+dl2
29204 rmss(13)=sign(sqrt(abs(arg)),arg)
29205 arg=rmss(14)**2*sign(1d0,rmss(14))+de2
29206 rmss(14)=sign(sqrt(abs(arg)),arg)
29207 IF( rmss(19)**2 + dma2 .LE. 50d0 ) THEN
29208 WRITE(mstu(11),*) ' MA DRIVEN TOO LOW '
29209 stop
29210 ENDIF
29211 rmss(19)=sqrt(rmss(19)**2+dma2)
29212 rmss(6)=sqrt(rmss(6)**2+dl2)
29213 rmss(7)=sqrt(rmss(7)**2+de2)
29214 WRITE(mstu(11),*) ' MTL = ',rmss(10)
29215 WRITE(mstu(11),*) ' MBR = ',rmss(11)
29216 WRITE(mstu(11),*) ' MTR = ',rmss(12)
29217 WRITE(mstu(11),*) ' SEL = ',rmss(6),rmss(13)
29218 WRITE(mstu(11),*) ' SER = ',rmss(7),rmss(14)
29219 ENDIF
29220
29221C...Fix the third generation sfermions.
29222 CALL pythrg
29223 xarg=rmss(13)**2-pmas(24,1)**2*abs(cos2b)
29224 IF(xarg.LT.0d0) THEN
29225 WRITE(mstu(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
29226 & ' THE SUM RULE. '
29227 WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29228 RETURN
29229 ELSE
29230 pmas(pycomp(ksusy1+16),1)=sqrt(xarg)
29231 ENDIF
29232
29233C...Fix the neutralino--chargino--gluino sector.
29234 CALL pyinom
29235
29236C...Fix the Higgs sector.
29237 CALL pyhggm(alfa)
29238
29239C...Choose the Gunion-Haber convention.
29240 alfa=-alfa
29241 rmss(18)=alfa
29242
29243C...Print information on mass parameters.
29244 IF(imssm.EQ.2.AND.mstp(122).GT.0) THEN
29245 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29246 WRITE(mstu(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
29247 WRITE(mstu(11),*) ' M0 = ',rmss(8)
29248 WRITE(mstu(11),*) ' M1/2=',rmss(1)
29249 WRITE(mstu(11),*) ' TANB=',rmss(5)
29250 WRITE(mstu(11),*) ' MU = ',rmss(4)
29251 WRITE(mstu(11),*) ' AT = ',rmss(16)
29252 WRITE(mstu(11),*) ' MA = ',rmss(19)
29253 WRITE(mstu(11),*) ' MTOP=',pmas(6,1)
29254 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29255 ENDIF
29256 IF(imss(20).EQ.1) THEN
29257 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29258 WRITE(mstu(11),*) ' DEBUG MODE '
29259 WRITE(mstu(11),*) ' UMIX = ',umix(1,1),umix(1,2),
29260 & umix(2,1),umix(2,2)
29261 WRITE(mstu(11),*) ' VMIX = ',vmix(1,1),vmix(1,2),
29262 & vmix(2,1),vmix(2,2)
29263 WRITE(mstu(11),*) ' ZMIX = ',zmix
29264 WRITE(mstu(11),*) ' ALFA = ',alfa
29265 WRITE(mstu(11),*) ' BETA = ',beta
29266 WRITE(mstu(11),*) ' STOP = ',(sfmix(6,i),i=1,4)
29267 WRITE(mstu(11),*) ' SBOT = ',(sfmix(5,i),i=1,4)
29268 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
29269 ENDIF
29270
29271C...Set up the Higgs couplings - needed here since initialization
29272C...in PYINRE did not yet occur when PYWIDT is called below.
29273 al=alfa
29274 be=beta
29275 sina=sin(al)
29276 cosa=cos(al)
29277 cosb=cos(be)
29278 sinb=tanb*cosb
29279 sbma=sin(be-al)
29280 sapb=sin(al+be)
29281 capb=cos(al+be)
29282 cbma=cos(be-al)
29283 s2a=sin(2d0*al)
29284 c2a=cos(2d0*al)
29285 c2b=cosb**2-sinb**2
29286C...tanb (used for H+)
29287 paru(141)=tanb
29288
29289C...Firstly: h
29290C...Coupling to d-type quarks
29291 paru(161)=sina/cosb
29292C...Coupling to u-type quarks
29293 paru(162)=-cosa/sinb
29294C...Coupling to leptons
29295 paru(163)=paru(161)
29296C...Coupling to Z
29297 paru(164)=sbma
29298C...Coupling to W
29299 paru(165)=paru(164)
29300
29301C...Secondly: H
29302C...Coupling to d-type quarks
29303 paru(171)=-cosa/cosb
29304C...Coupling to u-type quarks
29305 paru(172)=-sina/sinb
29306C...Coupling to leptons
29307 paru(173)=paru(171)
29308C...Coupling to Z
29309 paru(174)=cbma
29310C...Coupling to W
29311 paru(175)=paru(174)
29312C...Coupling to h
29313C PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
29314 hhh(3)=hhh(3)+hhh(4)+hhh(5)
29315 paru(176)=-3d0/hhh(1)*(hhh(1)*sina**2*cosb*cosa+
29316 1 hhh(2)*cosa**2*sinb*sina+hhh(3)*(sina**3*sinb+cosa**3*cosb-
29317 2 2d0/3d0*cbma)-hhh(6)*sina*(cosb*c2a+cosa*capb)+
29318 3 hhh(7)*cosa*(sinb*c2a+sina*capb))
29319C...Coupling to H+
29320C...Define later
29321C PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
29322 paru(168)=1d0/hhh(1)*(hhh(1)*sinb**2*cosb*sina-
29323 1 hhh(2)*cosb**2*sinb*cosa-hhh(3)*(sinb**3*cosa-cosb**3*sina)+
29324 2 2d0*hhh(5)*sbma-hhh(6)*sinb*(cosb*sapb+sina*c2b)-
29325 3 hhh(7)*cosb*(cosa*c2b-sinb*sapb)-(hhh(5)-hhh(4))*sbma)
29326C...Coupling to A
29327C PARU(177)=COS(2D0*BE)*COS(BE+AL)
29328 paru(177)=-1d0/hhh(1)*(hhh(1)*sinb**2*cosb*cosa+
29329 1 hhh(2)*cosb**2*sinb*sina+hhh(3)*(sinb**3*sina+cosb**3*cosa)-
29330 2 2d0*hhh(5)*cbma-hhh(6)*sinb*(cosb*capb+cosa*c2b)+
29331 3 hhh(7)*cosb*(sinb*capb+sina*c2b))
29332C...Coupling to H+
29333 paru(178)=paru(177)-(hhh(5)-hhh(4))/hhh(1)*cbma
29334C...Thirdly, A
29335C...Coupling to d-type quarks
29336 paru(181)=tanb
29337C...Coupling to u-type quarks
29338 paru(182)=1d0/paru(181)
29339C...Coupling to leptons
29340 paru(183)=paru(181)
29341 paru(184)=0d0
29342 paru(185)=0d0
29343C...Coupling to Z h
29344 paru(186)=cos(be-al)
29345C...Coupling to Z H
29346 paru(187)=sin(be-al)
29347 paru(188)=0d0
29348 paru(189)=0d0
29349 paru(190)=0d0
29350
29351C...Finally: H+
29352C...Coupling to W h
29353 paru(195)=cos(be-al)
29354
29355C...Tell that all Higgs couplings have been set.
29356 mstp(4)=1
29357
29358C...Second part of routine: set decay modes and branching ratios.
29359
29360C...Allow chi10 -> gravitino + gamma or not.
29361 kc=pycomp(ksusy1+39)
29362 IF( imss(11) .NE. 0 ) THEN
29363 pmas(kc,1)=rmss(21)/1000000000d0
29364 pmas(kc,2)=0.0001d0
29365 irprty=0
29366 WRITE(mstu(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
29367 ELSE
29368 pmas(kc,1)=9999d0
29369 irprty=1
29370 ENDIF
29371
29372C...Loop over sparticle and Higgs species.
29373 pmchi1=pmas(pycomp(ksusy1+22),1)
29374C...Find the LSP or NLSP for a gravitino LSP
29375 ilsp=0
29376 pmlsp=1d20
29377 DO 150 i=1,36
29378 kf=kfsusy(i)
29379 IF(kf.EQ.1000039) GOTO 150
29380 kc=pycomp(kf)
29381 IF(pmas(kc,1).LT.pmlsp) THEN
29382 ilsp=i
29383 pmlsp=pmas(kc,1)
29384 ENDIF
29385 150 CONTINUE
29386 DO 210 i=1,36
29387 kf=kfsusy(i)
29388 kc=pycomp(kf)
29389 lknt=0
29390
29391C...Sfermion decays.
29392 IF(i.LE.24) THEN
29393C...First check to see if sneutrino is lighter than chi10.
29394 IF((i.EQ.15.OR.i.EQ.19.OR.i.EQ.23).AND.
29395 & pmas(kc,1).LT.pmchi1) THEN
29396 ELSE
29397 CALL pysfdc(kf,xlam,idlam,lknt)
29398 ENDIF
29399
29400C...Gluino decays.
29401 ELSEIF(i.EQ.25) THEN
29402 CALL pyglui(kf,xlam,idlam,lknt)
29403 IF(i.EQ.ilsp) lknt=0
29404
29405C...Neutralino decays.
29406 ELSEIF(i.GE.26.AND.i.LE.29) THEN
29407 CALL pynjdc(kf,xlam,idlam,lknt)
29408C...chi10 stable or chi10 -> gravitino + gamma.
29409 IF(i.EQ.26.AND.irprty.EQ.1) THEN
29410 pmas(kc,2)=1d-6
29411 mdcy(kc,1)=0
29412 mwid(kc)=0
29413 ENDIF
29414
29415C...Chargino decays.
29416 ELSEIF(i.GE.30.AND.i.LE.31) THEN
29417 CALL pycjdc(kf,xlam,idlam,lknt)
29418
29419C...Gravitino is stable.
29420 ELSEIF(i.EQ.32) THEN
29421 mdcy(kc,1)=0
29422 mwid(kc)=0
29423
29424C...Higgs decays.
29425 ELSEIF(i.GE.33.AND.i.LE.36) THEN
29426C...Calculate decays to non-SUSY particles.
29427 CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
29428 lknt=0
29429 DO 160 i1=0,100
29430 xlam(i1)=0d0
29431 160 CONTINUE
29432 DO 180 i1=1,mdcy(kc,3)
29433 k1=mdcy(kc,2)+i1-1
29434 IF(iabs(kfdp(k1,1)).GT.ksusy1.OR.
29435 & iabs(kfdp(k1,2)).GT.ksusy1) GOTO 180
29436 xlam(i1)=wdtp(i1)
29437 xlam(0)=xlam(0)+xlam(i1)
29438 DO 170 j1=1,3
29439 idlam(i1,j1)=kfdp(k1,j1)
29440 170 CONTINUE
29441 lknt=lknt+1
29442 180 CONTINUE
29443C...Add the decays to SUSY particles.
29444 CALL pyhext(kf,xlam,idlam,lknt)
29445 ENDIF
29446C...Zero the branching ratios for use in loop mode
29447C...thanks to K. Matchev (FNAL)
29448 DO 185 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
29449 brat(idc)=0d0
29450 185 CONTINUE
29451
29452C...Set stable particles.
29453 IF(lknt.EQ.0) THEN
29454 mdcy(kc,1)=0
29455 mwid(kc)=0
29456 pmas(kc,2)=1d-6
29457 pmas(kc,3)=1d-5
29458 pmas(kc,4)=0d0
29459
29460C...Store branching ratios in the standard tables.
29461 ELSE
29462 idc=mdcy(kc,2)+mdcy(kc,3)-1
29463 delm=1d6
29464 DO 200 il=1,lknt
29465 idcsv=idc
29466 190 idc=idc+1
29467 brat(idc)=0d0
29468 IF(idc.EQ.mdcy(kc,2)+mdcy(kc,3)) idc=mdcy(kc,2)
29469 IF(idlam(il,1).EQ.kfdp(idc,1).AND.idlam(il,2).EQ.
29470 & kfdp(idc,2).AND.idlam(il,3).EQ.kfdp(idc,3)) THEN
29471 brat(idc)=xlam(il)/xlam(0)
29472 xmdif=pmas(kc,1)
29473 IF(mdme(idc,1).GE.1) THEN
29474 xmdif=xmdif-pmas(pycomp(kfdp(idc,1)),1)-
29475 & pmas(pycomp(kfdp(idc,2)),1)
29476 IF(kfdp(idc,3).NE.0) xmdif=xmdif-
29477 & pmas(pycomp(kfdp(idc,3)),1)
29478 ENDIF
29479 IF(i.LE.32) THEN
29480 IF(xmdif.GE.0d0) THEN
29481 delm=min(delm,xmdif)
29482 ELSE
29483 WRITE(mstu(11),*) ' ERROR WITH DELM ',delm,xmdif
29484 WRITE(mstu(11),*) ' KF = ',kf
29485 WRITE(mstu(11),*) ' KF(decay) = ',(kfdp(idc,j),j=1,3)
29486 ENDIF
29487 ENDIF
29488 GOTO 200
29489 ELSEIF(idc.EQ.idcsv) THEN
29490 WRITE(mstu(11),*) ' Error in PYMSIN: SUSY decay ',
29491 & 'channel not recognized:'
29492 WRITE(mstu(11),*) kf,' -> ',(idlam(i,j),j=1,3)
29493 GOTO 200
29494 ELSE
29495 GOTO 190
29496 ENDIF
29497 200 CONTINUE
29498
29499C...Store width, cutoff and lifetime.
29500 pmas(kc,2)=xlam(0)
29501 IF(pmas(kc,2).LT.0.1d0*delm) THEN
29502 pmas(kc,3)=pmas(kc,2)*10d0
29503 ELSE
29504 pmas(kc,3)=0.95d0*delm
29505 ENDIF
29506 IF(pmas(kc,2).NE.0d0) THEN
29507 pmas(kc,4)=paru(3)/pmas(kc,2)*1d-12
29508 ENDIF
29509 ENDIF
29510 210 CONTINUE
29511
29512 RETURN
29513 END
29514
29515C*********************************************************************
29516
29517C...PYAPPS
29518C...Uses approximate analytical formulae to determine the full set of
29519C...MSSM parameters from SUGRA input.
29520C...See M. Drees and S.P. Martin, hep-ph/9504124
29521
29522 SUBROUTINE pyapps
29523
29524C...Double precision and integer declarations.
29525 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29526 IMPLICIT INTEGER(I-N)
29527 INTEGER PYK,PYCHGE,PYCOMP
29528C...Parameter statement to help give large particle numbers.
29529 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29530C...Commonblocks.
29531 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29532 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29533 common/pymssm/imss(0:99),rmss(0:99)
29534 SAVE /pydat1/,/pydat2/,/pymssm/
29535
29536 imss(5)=0
29537 xmt=pmas(6,1)
29538 xmz2=pmas(23,1)**2
29539 xmw2=pmas(24,1)**2
29540 tanb=rmss(5)
29541 beta=atan(tanb)
29542 xw=paru(102)
29543 xmg=rmss(1)
29544 xmg2=xmg*xmg
29545 xm0=rmss(8)
29546 xm02=xm0*xm0
29547 at=-rmss(16)
29548 rmss(15)=at
29549 rmss(17)=at
29550 cosb=cos(beta)
29551 sinb=tanb/sqrt(tanb**2+1d0)
29552 cosb=sinb/tanb
29553
29554 dterm=xmz2*cos(2d0*beta)
29555 xmer=sqrt(xm02+0.15d0*xmg2-xw*dterm)
29556 xmel=sqrt(xm02+0.52d0*xmg2-(0.5d0-xw)*dterm)
29557 rmss(6)=xmel
29558 rmss(7)=xmer
29559 xmur=sqrt(pyrnmq(2,2d0/3d0*xw*dterm))
29560 xmdr=sqrt(pyrnmq(3,-1d0/3d0*xw*dterm))
29561 xmul=sqrt(pyrnmq(1,(0.5d0-2d0/3d0*xw)*dterm))
29562 xmdl=sqrt(pyrnmq(1,-(0.5d0-1d0/3d0*xw)*dterm))
29563 DO 100 i=1,5,2
29564 pmas(pycomp(ksusy1+i),1)=xmdl
29565 pmas(pycomp(ksusy2+i),1)=xmdr
29566 pmas(pycomp(ksusy1+i+1),1)=xmul
29567 pmas(pycomp(ksusy2+i+1),1)=xmur
29568 100 CONTINUE
29569 xarg=xmel**2-xmw2*abs(cos(2d0*beta))
29570 IF(xarg.LT.0d0) THEN
29571 WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
29572 & ' FROM THE SUM RULE. '
29573 WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
29574 RETURN
29575 ELSE
29576 xarg=sqrt(xarg)
29577 ENDIF
29578 DO 110 i=11,15,2
29579 pmas(pycomp(ksusy1+i),1)=xmel
29580 pmas(pycomp(ksusy2+i),1)=xmer
29581 pmas(pycomp(ksusy1+i+1),1)=xarg
29582 pmas(pycomp(ksusy2+i+1),1)=9999d0
29583 110 CONTINUE
29584 xmnu=xarg
29585
29586 rmt=pyrnmt(xmt)
29587 xtop=(rmt/150d0/sinb)**2*(.9d0*xm02+2.1d0*xmg2+
29588 &(1d0-(rmt/190d0/sinb)**3)*(.24d0*at**2+at*xmg))
29589 rmb=3d0
29590 xbot=(rmb/150d0/cosb)**2*(.9d0*xm02+2.1d0*xmg2+
29591 &(1d0-(rmb/190d0/cosb)**3)*(.24d0*at**2+at*xmg))
29592 xtau=1d-4/cosb**2*(xm02+0.15d0*xmg2+at**2/3d0)
29593 atp=at*(1d0-(rmt/190d0/sinb)**2)+xmg*(3.47d0-1.9d0*(rmt/190d0/
29594 &sinb)**2)
29595 rmss(16)=-atp
29596C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
29597C.....
29598 xmu2=-.5d0*xmz2+(sinb**2*(xm02+.52d0*xmg2-xtop)-
29599 &cosb**2*(xm02+.52d0*xmg2-xbot-xtau/3d0))/(cosb**2-sinb**2)
29600C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
29601C.....
29602 xma2=2d0*(xm02+.52d0*xmg2)-xtop-xbot-xtau/3d0+2d0*xmu2
29603 xmu=sign(sqrt(xmu2),rmss(4))
29604 rmss(4)=xmu
29605 rmss(19)=sqrt(xma2)
29606 arg=xm02+0.15d0*xmg2-2d0*xtau/3d0-xw*dterm
29607 IF(arg.GT.0d0) THEN
29608 rmss(14)=sqrt(arg)
29609 ELSE
29610 WRITE(mstu(11),*) ' RIGHT STAU MASS < 0 '
29611 stop
29612 ENDIF
29613 arg=xm02+0.52d0*xmg2-xtau/3d0-(0.5d0-xw)*dterm
29614 IF(arg.GT.0d0) THEN
29615 rmss(13)=sqrt(arg)
29616 ELSE
29617 WRITE(mstu(11),*) ' LEFT STAU MASS < 0 '
29618 stop
29619 ENDIF
29620 arg=pyrnmq(1,-(xbot+xtop)/3d0)
29621 IF(arg.GT.0d0) THEN
29622 rmss(10)=sqrt(arg)
29623 ELSE
29624 rmss(10)=-sqrt(-arg)
29625 ENDIF
29626 arg=pyrnmq(2,-2d0*xtop/3d0)
29627 IF(arg.GT.0d0) THEN
29628 rmss(12)=sqrt(arg)
29629 ELSE
29630 rmss(12)=-sqrt(-arg)
29631 ENDIF
29632 arg=pyrnmq(3,-2d0*xbot/3d0)
29633 IF(arg.GT.0d0) THEN
29634 rmss(11)=sqrt(arg)
29635 ELSE
29636 rmss(11)=-sqrt(-arg)
29637 ENDIF
29638
29639 RETURN
29640 END
29641
29642C*********************************************************************
29643
29644C...PYRNMQ
29645C...Determines the running mass of quarks.
29646
29647 FUNCTION pyrnmq(ID,DTERM)
29648
29649C...Double precision and integer declarations.
29650 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29651 IMPLICIT INTEGER(I-N)
29652 INTEGER PYK,PYCHGE,PYCOMP
29653C...Commonblock.
29654 common/pymssm/imss(0:99),rmss(0:99)
29655 SAVE /pymssm/
29656
29657C...Local variables.
29658 DOUBLE PRECISION PI,R
29659 DOUBLE PRECISION TOL
29660 DOUBLE PRECISION CI(3)
29661 EXTERNAL pyalps
29662 DOUBLE PRECISION PYALPS
29663 DATA tol/0.001d0/
29664 DATA pi,r/3.141592654d0,.61803399d0/
29665 DATA ci/0.47d0,0.07d0,0.02d0/
29666
29667 c=1d0-r
29668 ca=ci(id)
29669 ag=(0.71d0)**2/4d0/pi
29670 ag=rmss(20)
29671 xm0=rmss(8)
29672 xmg=rmss(1)
29673 xm02=xm0*xm0
29674 xmg2=xmg*xmg
29675
29676 as=pyalps(xm02+6d0*xmg2)
29677 cg=8d0/9d0*((as/ag)**2-1d0)
29678 bx=xm02+(ca+cg)*xmg2+dterm
29679 ax=min(50d0**2,0.5d0*bx)
29680 cx=max(2000d0**2,2d0*bx)
29681
29682 x0=ax
29683 x3=cx
29684 IF(abs(cx-bx).GT.abs(bx-ax))THEN
29685 x1=bx
29686 x2=bx+c*(cx-bx)
29687 ELSE
29688 x2=bx
29689 x1=bx-c*(bx-ax)
29690 ENDIF
29691 as1=pyalps(x1)
29692 cg=8d0/9d0*((as1/ag)**2-1d0)
29693 f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
29694 as2=pyalps(x2)
29695 cg=8d0/9d0*((as2/ag)**2-1d0)
29696 f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
29697 100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
29698 IF(f2.LT.f1) THEN
29699 x0=x1
29700 x1=x2
29701 x2=r*x1+c*x3
29702 f1=f2
29703 as2=pyalps(x2)
29704 cg=8d0/9d0*((as2/ag)**2-1d0)
29705 f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
29706 ELSE
29707 x3=x2
29708 x2=x1
29709 x1=r*x2+c*x0
29710 f2=f1
29711 as1=pyalps(x1)
29712 cg=8d0/9d0*((as1/ag)**2-1d0)
29713 f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
29714 ENDIF
29715 GOTO 100
29716 ENDIF
29717 IF(f1.LT.f2) THEN
29718 pyrnmq=x1
29719 xmin=x1
29720 ELSE
29721 pyrnmq=x2
29722 xmin=x2
29723 ENDIF
29724
29725 RETURN
29726 END
29727
29728C*********************************************************************
29729
29730C...PYRNMT
29731C...Determines the running mass of the top quark.
29732
29733 FUNCTION pyrnmt(XMT)
29734
29735C...Double precision and integer declarations.
29736 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29737 IMPLICIT INTEGER(I-N)
29738 INTEGER PYK,PYCHGE,PYCOMP
29739C...Commonblock.
29740 common/pymssm/imss(0:99),rmss(0:99)
29741 SAVE /pymssm/
29742
29743C...Local variables.
29744 DOUBLE PRECISION XMT
29745 DOUBLE PRECISION PI,R
29746 DOUBLE PRECISION TOL
29747 EXTERNAL pyalps
29748 DOUBLE PRECISION PYALPS
29749 DATA tol/0.001d0/
29750 DATA pi,r/3.141592654d0,0.61803399d0/
29751
29752 c=1d0-r
29753
29754 bx=xmt
29755 ax=min(50d0,bx*0.5d0)
29756 cx=max(300d0,2d0*bx)
29757
29758 x0=ax
29759 x3=cx
29760 IF(abs(cx-bx).GT.abs(bx-ax))THEN
29761 x1=bx
29762 x2=bx+c*(cx-bx)
29763 ELSE
29764 x2=bx
29765 x1=bx-c*(bx-ax)
29766 ENDIF
29767 as1=pyalps(x1**2)/pi
29768 f1=abs(xmt/(1d0+4d0/3d0*as1+11d0*as1**2)-x1)
29769 as2=pyalps(x2**2)/pi
29770 f2=abs(xmt/(1d0+4d0/3d0*as2+11d0*as2**2)-x2)
29771 100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
29772 IF(f2.LT.f1) THEN
29773 x0=x1
29774 x1=x2
29775 x2=r*x1+c*x3
29776 f1=f2
29777 as2=pyalps(x2**2)/pi
29778 f2=abs(xmt/(1d0+4d0/3d0*as2+11d0*as2**2)-x2)
29779 ELSE
29780 x3=x2
29781 x2=x1
29782 x1=r*x2+c*x0
29783 f2=f1
29784 as1=pyalps(x1**2)/pi
29785 f1=abs(xmt/(1d0+4d0/3d0*as1+11d0*as1**2)-x1)
29786 ENDIF
29787 GOTO 100
29788 ENDIF
29789 IF(f1.LT.f2) THEN
29790 pyrnmt=x1
29791 xmin=x1
29792 ELSE
29793 pyrnmt=x2
29794 xmin=x2
29795 ENDIF
29796
29797 RETURN
29798 END
29799
29800C*********************************************************************
29801
29802C...PYTHRG
29803C...Calculates the mass eigenstates of the third generation sfermions.
29804C...Created: 5-31-96
29805
29806 SUBROUTINE pythrg
29807
29808C...Double precision and integer declarations.
29809 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29810 IMPLICIT INTEGER(I-N)
29811 INTEGER PYK,PYCHGE,PYCOMP
29812C...Parameter statement to help give large particle numbers.
29813 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29814C...Commonblocks.
29815 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29816 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29817 common/pymssm/imss(0:99),rmss(0:99)
29818 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
29819 &sfmix(16,4)
29820 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
29821
29822C...Local variables.
29823 DOUBLE PRECISION BETA
29824 DOUBLE PRECISION PYRNMT
29825 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
29826 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
29827 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
29828 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
29829 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
29830 INTEGER IF,I,J,II,JJ,IT,L
29831 LOGICAL DTERM
29832 DATA small/1d-3/
29833 DATA id1/10,10,13/
29834 DATA id2/5,6,15/
29835 DATA id3/15,16,17/
29836 DATA id4/11,12,14/
29837 DATA dterm/.true./
29838
29839 xmz2=pmas(23,1)**2
29840 xmw2=pmas(24,1)**2
29841 tanb=rmss(5)
29842 xmu=-rmss(4)
29843 beta=atan(tanb)
29844 cos2b=cos(2d0*beta)
29845
29846C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
29847
29848 iopt=imss(5)
29849 IF(iopt.EQ.1) THEN
29850 ctt=rmss(27)
29851 ctt2=ctt**2
29852 stt2=1d0-ctt2
29853 stt=sqrt(stt2)
29854 xm12=rmss(12)**2
29855 xm22=rmss(10)**2
29856 xmql2=ctt2*xm12+stt2*xm22
29857 xmqr2=stt2*xm12+ctt2*xm22
29858 xmfr=pmas(6,1)
29859 xmf2=pyrnmt(xmfr)**2
29860 atop=-xmu/tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
29861 atmt=sqrt(xmf2)*(atop+xmu/tanb)
29862 xtest=(xmql2-xmqr2)*(ctt2-stt2)
29863 IF(xtest.GT.4d0*stt*ctt*atmt) THEN
29864 stt=-stt
29865 atop=-xmu/tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
29866 ENDIF
29867 rmss(16)=atop
29868C......SUBTRACT OUT D-TERM AND FERMION MASS
29869 xmql2=xmql2-xmf2-(4d0*xmw2-xmz2)*cos2b/6d0
29870 xmqr2=xmqr2-xmf2+(xmw2-xmz2)*cos2b*2d0/3d0
29871 IF(xmql2.GE.0d0) THEN
29872 rmss(10)=sqrt(xmql2)
29873 ELSE
29874 rmss(10)=-sqrt(-xmql2)
29875 ENDIF
29876 IF(xmqr2.GE.0d0) THEN
29877 rmss(12)=sqrt(xmqr2)
29878 ELSE
29879 rmss(12)=-sqrt(-xmqr2)
29880 ENDIF
29881C SAME FOR BOTTOM SQUARK
29882 ctt=rmss(26)
29883 ctt2=ctt**2
29884 stt2=1d0-ctt2
29885 stt=max(sqrt(stt2),1d-6)
29886 xmf=3d00
29887 xmf2=xmf**2
29888 xm12=rmss(11)**2
29889 xmql2=rmss(10)**2-(2d0*xmw2+xmz2)*cos2b/6d0+xmf2
29890 IF(abs(ctt).EQ.1d0) THEN
29891 xm22=xm12
29892 xm12=xmql2
29893 xmqr2=xm22
29894 ELSEIF(ctt.EQ.0d0) THEN
29895 xm22=xmql2
29896 xmqr2=xm12
29897 ELSE
29898 xm22=(xmql2-ctt2*xm12)/stt2
29899 xmqr2=stt2*xm12+ctt2*xm22
29900 ENDIF
29901 abot=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
29902 atmt=sqrt(xmf2)*(abot+xmu*tanb)
29903 xtest=(xmql2-xmqr2)*(ctt2-stt2)
29904 IF(xtest.GT.4d0*stt*ctt*atmt) THEN
29905 stt=-stt
29906 abot=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
29907 ENDIF
29908 rmss(15)=abot
29909C......SUBTRACT OUT D-TERM AND FERMION MASS
29910 xmqr2=xmqr2-(xmw2-xmz2)*cos2b/3d0-xmf2
29911 IF(xmqr2.GE.0d0) THEN
29912 rmss(11)=sqrt(xmqr2)
29913 ELSE
29914 rmss(11)=-sqrt(-xmqr2)
29915 ENDIF
29916C SAME FOR TAU SLEPTON
29917 ctt=rmss(28)
29918 ctt2=ctt**2
29919 stt2=1d0-ctt2
29920 stt=sqrt(stt2)
29921 xm12=rmss(14)**2
29922 xm22=rmss(13)**2
29923 xmql2=ctt2*xm12+stt2*xm22
29924 xmqr2=stt2*xm12+ctt2*xm22
29925 xmfr=pmas(15,1)
29926 xmf2=xmfr**2
29927 atau=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
29928 atmt=sqrt(xmf2)*(atau+xmu*tanb)
29929 xtest=(xmql2-xmqr2)*(ctt2-stt2)
29930 IF(xtest.GT.4d0*stt*ctt*atmt) THEN
29931 stt=-stt
29932 atau=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
29933 ENDIF
29934 rmss(17)=atau
29935C......SUBTRACT OUT D-TERM AND FERMION MASS
29936 xmql2=xmql2-xmf2+(-.5d0*xmz2+xmw2)*cos2b
29937 xmqr2=xmqr2-xmf2+(xmz2-xmw2)*cos2b
29938 IF(xmql2.GE.0d0) THEN
29939 rmss(13)=sqrt(xmql2)
29940 ELSE
29941 rmss(13)=-sqrt(-xmql2)
29942 ENDIF
29943 IF(xmqr2.GE.0d0) THEN
29944 rmss(14)=sqrt(xmqr2)
29945 ELSE
29946 rmss(14)=-sqrt(-xmqr2)
29947 ENDIF
29948 ENDIF
29949 DO 170 l=1,3
29950 amql=rmss(id1(l))
29951 IF(amql.LT.0d0) THEN
29952 xmql2=-amql**2
29953 ELSE
29954 xmql2=amql**2
29955 ENDIF
29956 if=id2(l)
29957 xmf=pmas(IF,1)
29958 IF(l.EQ.1) xmf=3d0
29959 IF(l.EQ.2) xmf=pyrnmt(xmf)
29960 xmf2=xmf**2
29961 atr=rmss(id3(l))
29962 amqr=rmss(id4(l))
29963 IF(amqr.LT.0d0) THEN
29964 xmqr2=-amqr**2
29965 ELSE
29966 xmqr2=amqr**2
29967 ENDIF
29968 am2(1,1)=xmql2+xmf2
29969 am2(2,2)=xmqr2+xmf2
29970 IF(dterm) THEN
29971 IF(l.EQ.1) THEN
29972 am2(1,1)=am2(1,1)-(2d0*xmw2+xmz2)*cos2b/6d0
29973 am2(2,2)=am2(2,2)+(xmw2-xmz2)*cos2b/3d0
29974 am2(1,2)=xmf*(atr+xmu*tanb)
29975 ELSEIF(l.EQ.2) THEN
29976 am2(1,1)=am2(1,1)+(4d0*xmw2-xmz2)*cos2b/6d0
29977 am2(2,2)=am2(2,2)-(xmw2-xmz2)*cos2b*2d0/3d0
29978 am2(1,2)=xmf*(atr+xmu/tanb)
29979 ELSEIF(l.EQ.3) THEN
29980 IF(imss(8).EQ.1) THEN
29981 am2(1,1)=rmss(6)**2
29982 am2(2,2)=rmss(7)**2
29983 am2(1,2)=0d0
29984 rmss(13)=rmss(6)
29985 rmss(14)=rmss(7)
29986 ELSE
29987 am2(1,2)=xmf*(atr+xmu*tanb)
29988 ENDIF
29989 ENDIF
29990 ENDIF
29991 am2(2,1)=am2(1,2)
29992 detm=am2(1,1)*am2(2,2)-am2(2,1)**2
29993 IF(detm.LT.0d0) THEN
29994 WRITE(mstu(11),*) id1(l),detm
29995 CALL pyerrm(30,' NEGATIVE**2 MASS FOR SFERMION ')
29996 ENDIF
29997 same=0.5d0*(am2(1,1)+am2(2,2))
29998 diff=0.5d0*sqrt((am2(1,1)-am2(2,2))**2+4d0*am2(1,2)*am2(2,1))
29999 xmf12=same-diff
30000 xmf22=same+diff
30001 it=0
30002 IF(xmf22-xmf12.GT.0d0) THEN
30003 rt(1,1) = sqrt(max(0d0,(xmf22-am2(1,1))/(xmf22-xmf12)))
30004 rt(2,2) = rt(1,1)
30005 rt(1,2) = -sign(sqrt(max(0d0,1d0-rt(1,1)**2)),
30006 & am2(1,2)/(xmf22-xmf12))
30007 rt(2,1) = -rt(1,2)
30008 ELSE
30009 rt(1,1) = 1d0
30010 rt(2,2) = rt(1,1)
30011 rt(1,2) = 0d0
30012 rt(2,1) = -rt(1,2)
30013 ENDIF
30014 100 CONTINUE
30015 it=it+1
30016
30017 DO 140 i=1,2
30018 DO 130 jj=1,2
30019 di(i,jj)=0d0
30020 DO 120 ii=1,2
30021 DO 110 j=1,2
30022 di(i,jj)=di(i,jj)+rt(i,j)*am2(j,ii)*rt(jj,ii)
30023 110 CONTINUE
30024 120 CONTINUE
30025 130 CONTINUE
30026 140 CONTINUE
30027
30028 IF(di(1,1).GT.di(2,2)) THEN
30029 WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION '
30030 WRITE(mstu(11),*) l,sqrt(xmf12),sqrt(xmf22)
30031 WRITE(mstu(11),*) am2
30032 WRITE(mstu(11),*) di
30033 WRITE(mstu(11),*) rt
30034 di(1,1)=-rt(2,1)
30035 di(2,2)=rt(1,2)
30036 di(1,2)=-rt(2,2)
30037 di(2,1)=rt(1,1)
30038 DO 160 i=1,2
30039 DO 150 j=1,2
30040 rt(i,j)=di(i,j)
30041 150 CONTINUE
30042 160 CONTINUE
30043 GOTO 100
30044 ELSEIF(abs(di(1,2)*di(2,1)/di(1,1)/di(2,2)).GT.small) THEN
30045 WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
30046 & ' OFF DIAGONAL ELEMENTS '
30047 WRITE(mstu(11),*) 'MASSES = ',l,sqrt(xmf12),sqrt(xmf22)
30048 WRITE(mstu(11),*) di
30049 WRITE(mstu(11),*) ' ROTATION = ',rt
30050C...STOP
30051 ELSEIF(di(1,1).LT.0d0.OR.di(2,2).LT.0d0) THEN
30052 WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
30053 & ' NEGATIVE MASSES '
30054 stop
30055 ENDIF
30056 pmas(pycomp(ksusy1+if),1)=sqrt(xmf12)
30057 pmas(pycomp(ksusy2+if),1)=sqrt(xmf22)
30058 sfmix(IF,1)=rt(1,1)
30059 sfmix(IF,2)=rt(1,2)
30060 sfmix(IF,3)=rt(2,1)
30061 sfmix(IF,4)=rt(2,2)
30062 170 CONTINUE
30063
30064 RETURN
30065 END
30066
30067C*********************************************************************
30068
30069C...PYINOM
30070C...Finds the mass eigenstates and mixing matrices for neutralinos
30071C...and charginos.
30072
30073 SUBROUTINE pyinom
30074
30075C...Double precision and integer declarations.
30076 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30077 IMPLICIT INTEGER(I-N)
30078 INTEGER PYK,PYCHGE,PYCOMP
30079C...Parameter statement to help give large particle numbers.
30080 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30081C...Commonblocks.
30082 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30083 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30084 common/pymssm/imss(0:99),rmss(0:99)
30085 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
30086 &sfmix(16,4)
30087 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
30088
30089C...Local variables.
30090 DOUBLE PRECISION XMW,XMZ
30091 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
30092 DOUBLE PRECISION ZP(4,4)
30093 DOUBLE PRECISION DETX,XI(2,2)
30094 DOUBLE PRECISION XXX,YYY,XMH,XML
30095 DOUBLE PRECISION COSW,SINW
30096 DOUBLE PRECISION XMU
30097 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
30098 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
30099 DOUBLE PRECISION XM1,XM2,XM3,BETA
30100 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
30101 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
30102 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
30103 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
30104 DOUBLE PRECISION PYALPS,PYALEM
30105 DOUBLE PRECISION PYRNM3
30106 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
30107 DATA kfnchi/1000022,1000023,1000025,1000035/
30108
30109 iopt=imss(2)
30110 IF(imss(1).EQ.2) THEN
30111 iopt=1
30112 ENDIF
30113C...M1, M2, AND M3 ARE INDEPENDENT
30114 IF(iopt.EQ.0) THEN
30115 xm1=rmss(1)
30116 xm2=rmss(2)
30117 xm3=rmss(3)
30118 ELSEIF(iopt.GE.1) THEN
30119 q2=pmas(23,1)**2
30120 aem=pyalem(q2)
30121 a2=aem/paru(102)
30122 a1=aem/(1d0-paru(102))
30123 xm1=rmss(1)
30124 xm2=rmss(2)
30125 IF(imss(1).EQ.2) xm1=rmss(1)/rmss(20)*a1*5d0/3d0
30126 IF(iopt.EQ.1) THEN
30127 xm2=xm1*a2/a1*3d0/5d0
30128 rmss(2)=xm2
30129 ELSEIF(iopt.EQ.3) THEN
30130 xm1=xm2*5d0/3d0*a1/a2
30131 rmss(1)=xm1
30132 ENDIF
30133 xm3=pyrnm3(xm2/a2)
30134 rmss(3)=xm3
30135 IF(xm3.LE.0d0) THEN
30136 WRITE(mstu(11),*) ' ERROR WITH M3 = ',xm3
30137 stop
30138 ENDIF
30139 ENDIF
30140
30141C...GLUINO MASS
30142 IF(imss(3).EQ.1) THEN
30143 pmas(pycomp(ksusy1+21),1)=xm3
30144 ELSE
30145 aq=0d0
30146 DO 110 i=1,4
30147 DO 100 ilr=1,2
30148 rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
30149 aq=aq+0.5d0*((2d0-rm1)*(rm1*log(rm1)-1d0)
30150 & +(1d0-rm1)**2*log(abs(1d0-rm1)))
30151 100 CONTINUE
30152 110 CONTINUE
30153
30154 DO 130 i=5,6
30155 DO 120 ilr=1,2
30156 rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
30157 rm2=pmas(i,1)**2/xm3**2
30158 arg=(rm1-rm2-1d0)**2-4d0*rm2**2
30159 IF(arg.GE.0d0) THEN
30160 x0=0.5d0*(1d0+rm2-rm1-sqrt(arg))
30161 ax0=abs(x0)
30162 x1=0.5d0*(1d0+rm2-rm1+sqrt(arg))
30163 ax1=abs(x1)
30164 IF(x0.EQ.1d0) THEN
30165 at=-1d0
30166 bt=0.25d0
30167 ELSEIF(x0.EQ.0d0) THEN
30168 at=0d0
30169 bt=-0.25d0
30170 ELSE
30171 at=0.5d0*log(abs(1d0-x0))*(1d0-x0**2)+
30172 & 0.5d0*x0**2*log(ax0)
30173 bt=(-1d0-2d0*x0)/4d0
30174 ENDIF
30175 IF(x1.EQ.1d0) THEN
30176 at=-1d0+at
30177 bt=0.25d0+bt
30178 ELSEIF(x1.EQ.0d0) THEN
30179 at=0d0+at
30180 bt=-0.25d0+bt
30181 ELSE
30182 at=0.5d0*log(abs(1d0-x1))*(1d0-x1**2)+0.5d0*
30183 & x1**2*log(ax1)+at
30184 bt=(-1d0-2d0*x1)/4d0+bt
30185 ENDIF
30186 aq=aq+at+bt
30187 ELSE
30188 x0=0.5d0*(1d0+rm2-rm1)
30189 y0=-0.5d0*sqrt(-arg)
30190 amgx0=sqrt(x0**2+y0**2)
30191 am1x0=sqrt((1d0-x0)**2+y0**2)
30192 argx0=atan2(-x0,-y0)
30193 ar1x0=atan2(1d0-x0,y0)
30194 x1=x0
30195 y1=-y0
30196 amgx1=amgx0
30197 am1x1=am1x0
30198 argx1=atan2(-x1,-y1)
30199 ar1x1=atan2(1d0-x1,y1)
30200 at=0.5d0*log(am1x0)*(1d0-x0**2+3d0*y0**2)
30201 & +0.5d0*(x0**2-y0**2)*log(amgx0)
30202 bt=(-1d0-2d0*x0)/4d0+x0*y0*( ar1x0-argx0 )
30203 at=at+0.5d0*log(am1x1)*(1d0-x1**2+3d0*y1**2)
30204 & +0.5d0*(x1**2-y1**2)*log(amgx1)
30205 bt=bt+(-1d0-2d0*x1)/4d0+x1*y1*( ar1x1-argx1 )
30206 aq=aq+at+bt
30207 ENDIF
30208 120 CONTINUE
30209 130 CONTINUE
30210 pmas(pycomp(ksusy1+21),1)=xm3*(1d0+pyalps(xm3**2)/(2d0*paru(2))*
30211 & (15d0+aq))
30212 ENDIF
30213
30214C...NEUTRALINO MASSES
30215 xmz=pmas(23,1)
30216 xmw=pmas(24,1)
30217 xmu=rmss(4)
30218 sinw=sqrt(paru(102))
30219 cosw=sqrt(1d0-paru(102))
30220 tanb=rmss(5)
30221 beta=atan(tanb)
30222 cosb=cos(beta)
30223 sinb=tanb*cosb
30224 ar(1,1) = xm1
30225 ar(2,2) = xm2
30226 ar(3,3) = 0d0
30227 ar(4,4) = 0d0
30228 ar(1,2) = 0d0
30229 ar(2,1) = 0d0
30230 ar(1,3) = -xmz*sinw*cosb
30231 ar(3,1) = ar(1,3)
30232 ar(1,4) = xmz*sinw*sinb
30233 ar(4,1) = ar(1,4)
30234 ar(2,3) = xmz*cosw*cosb
30235 ar(3,2) = ar(2,3)
30236 ar(2,4) = -xmz*cosw*sinb
30237 ar(4,2) = ar(2,4)
30238 ar(3,4) = -xmu
30239 ar(4,3) = -xmu
30240 CALL pyeig4(ar,wr,zr)
30241 DO 150 i=1,4
30242 smz(i)=wr(i)
30243 pmas(pycomp(kfnchi(i)),1)=abs(smz(i))
30244 DO 140 j=1,4
30245 zmix(i,j)=zr(i,j)
30246 IF(abs(zmix(i,j)).LT.1d-6) zmix(i,j)=0d0
30247 140 CONTINUE
30248 150 CONTINUE
30249
30250C...CHARGINO MASSES
30251 ar(1,1) = xm2
30252 ar(2,2) = xmu
30253 ar(1,2) = sqrt(2d0)*xmw*sinb
30254 ar(2,1) = sqrt(2d0)*xmw*cosb
30255 termb=ar(1,1)**2+ar(2,2)**2+ar(1,2)**2+ar(2,1)**2
30256 termc=(ar(1,1)**2-ar(2,2)**2)**2+(ar(1,2)**2-ar(2,1)**2)**2
30257 termc=termc+2d0*(ar(1,1)**2+ar(2,2)**2)*
30258 &(ar(1,2)**2+ar(2,1)**2)+
30259 &8d0*ar(1,1)*ar(2,2)*ar(1,2)*ar(2,1)
30260 discr=termc
30261 IF(discr.LT.0d0) THEN
30262 WRITE(mstu(11),*) ' PROBLEM WITH DISCR '
30263 ELSE
30264 discr=sqrt(discr)
30265 ENDIF
30266 xml2=0.5d0*(termb-discr)
30267 xmh2=0.5d0*(termb+discr)
30268 xml=sqrt(xml2)
30269 xmh=sqrt(xmh2)
30270 pmas(pycomp(ksusy1+24),1)=xml
30271 pmas(pycomp(ksusy1+37),1)=xmh
30272 smw(1)=xml
30273 smw(2)=xmh
30274 xxx=ar(1,1)**2+ar(2,1)**2
30275 yyy=ar(1,1)*ar(1,2)+ar(2,2)*ar(2,1)
30276 vmix(2,2) = yyy/sqrt(yyy**2+(xml2-xxx)**2)
30277 vmix(1,1) = sign(vmix(2,2),ar(1,1)*ar(2,2)-0.5d0*ar(1,2)**2)
30278 vmix(2,1) = -(xml2-xxx)/sqrt(yyy**2+(xml2-xxx)**2)
30279 vmix(1,2) = -sign(vmix(2,1),ar(1,1)*ar(2,2)-0.5d0*ar(1,2)**2)
30280 zr(1,1) = xml
30281 zr(1,2) = 0d0
30282 zr(2,1) = 0d0
30283 zr(2,2) = xmh
30284 detx = ar(1,1)*ar(2,2)-ar(1,2)*ar(2,1)
30285 xi(1,1) = ar(2,2)/detx
30286 xi(2,2) = ar(1,1)/detx
30287 xi(1,2) = -ar(1,2)/detx
30288 xi(2,1) = -ar(2,1)/detx
30289 DO 190 i=1,2
30290 DO 180 j=1,2
30291 umix(i,j)=0d0
30292 DO 170 k=1,2
30293 DO 160 l=1,2
30294 umix(i,j)=umix(i,j)+zr(i,k)*vmix(k,l)*xi(l,j)
30295 160 CONTINUE
30296 170 CONTINUE
30297 180 CONTINUE
30298 190 CONTINUE
30299
30300 RETURN
30301 END
30302
30303
30304
30305C*********************************************************************
30306
30307C...PYRNM3
30308C...Calculates the running of M3, the SU(3) gluino mass parameter.
30309
30310 FUNCTION pyrnm3(RGUT)
30311
30312C...Double precision and integer declarations.
30313 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30314 IMPLICIT INTEGER(I-N)
30315 INTEGER PYK,PYCHGE,PYCOMP
30316
30317C...Local variables.
30318 DOUBLE PRECISION PI,R
30319 DOUBLE PRECISION TOL
30320 EXTERNAL pyalps
30321 DOUBLE PRECISION PYALPS
30322 DATA tol/0.001d0/
30323 DATA pi,r/3.141592654d0,0.61803399d0/
30324
30325 c=1d0-r
30326
30327 bx=rgut*pyalps(rgut**2)
30328 ax=min(50d0,bx*0.5d0)
30329 cx=max(2000d0,2d0*bx)
30330
30331 x0=ax
30332 x3=cx
30333 IF(abs(cx-bx).GT.abs(bx-ax))THEN
30334 x1=bx
30335 x2=bx+c*(cx-bx)
30336 ELSE
30337 x2=bx
30338 x1=bx-c*(bx-ax)
30339 ENDIF
30340 as1=pyalps(x1**2)
30341 f1=abs(x1-rgut*as1)
30342 as2=pyalps(x2**2)
30343 f2=abs(x2-rgut*as2)
30344 100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
30345 IF(f2.LT.f1) THEN
30346 x0=x1
30347 x1=x2
30348 x2=r*x1+c*x3
30349 f1=f2
30350 as2=pyalps(x2**2)
30351 f2=abs(x2-rgut*as2)
30352 ELSE
30353 x3=x2
30354 x2=x1
30355 x1=r*x2+c*x0
30356 f2=f1
30357 as1=pyalps(x1**2)
30358 f1=abs(x1-rgut*as1)
30359 ENDIF
30360 GOTO 100
30361 ENDIF
30362 IF(f1.LT.f2) THEN
30363 pyrnm3=x1
30364 xmin=x1
30365 ELSE
30366 pyrnm3=x2
30367 xmin=x2
30368 ENDIF
30369
30370 RETURN
30371 END
30372
30373C*********************************************************************
30374
30375C...PYEIG4
30376C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
30377C...Specific application: mixing in neutralino sector.
30378
30379 SUBROUTINE pyeig4(A,W,Z)
30380
30381C...Double precision and integer declarations.
30382 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30383 IMPLICIT INTEGER(I-N)
30384 INTEGER PYK,PYCHGE,PYCOMP
30385
30386C...Arrays: in call and local.
30387 dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)
30388
30389C...Coefficients of fourth-degree equation from matrix.
30390C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
30391 b3=-(a(1,1)+a(2,2)+a(3,3)+a(4,4))
30392 b2=0d0
30393 DO 110 i=1,3
30394 DO 100 j=i+1,4
30395 b2=b2+a(i,i)*a(j,j)-a(i,j)*a(j,i)
30396 100 CONTINUE
30397 110 CONTINUE
30398 b1=0d0
30399 b0=0d0
30400 DO 120 i=1,4
30401 i1=mod(i,4)+1
30402 i2=mod(i+1,4)+1
30403 i3=mod(i+2,4)+1
30404 b1=b1+a(i,i)*(-a(i1,i1)*a(i2,i2)+a(i1,i2)*a(i2,i1)+
30405 & a(i1,i3)*a(i3,i1)+a(i2,i3)*a(i3,i2))-
30406 & a(i,i1)*a(i1,i2)*a(i2,i)-a(i,i2)*a(i2,i1)*a(i1,i)
30407 b0=b0+(-1d0)**(i+1)*a(1,i)*(
30408 & a(2,i1)*(a(3,i2)*a(4,i3)-a(3,i3)*a(4,i2))+
30409 & a(2,i2)*(a(3,i3)*a(4,i1)-a(3,i1)*a(4,i3))+
30410 & a(2,i3)*(a(3,i1)*a(4,i2)-a(3,i2)*a(4,i1)))
30411 120 CONTINUE
30412
30413C...Coefficients of third-degree equation needed for
30414C...separation into two second-degree equations.
30415C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
30416 c2=-b2
30417 c1=b1*b3-4d0*b0
30418 c0=-b1**2-b0*b3**2+4d0*b0*b2
30419 cq=c1/3d0-c2**2/9d0
30420 cr=c1*c2/6d0-c0/2d0-c2**3/27d0
30421 cqr=cq**3+cr**2
30422
30423C...Cases with one or three real roots.
30424 IF(cqr.GE.0d0) THEN
30425 s1=(cr+sqrt(cqr))**(1d0/3d0)
30426 s2=(cr-sqrt(cqr))**(1d0/3d0)
30427 u=s1+s2-c2/3d0
30428 ELSE
30429 sabs=sqrt(-cq)
30430 the=acos(cr/sabs**3)/3d0
30431 sre=sabs*cos(the)
30432 u=2d0*sre-c2/3d0
30433 ENDIF
30434
30435C...Find and solve two second-degree equations.
30436 p1=b3/2d0-sqrt(b3**2/4d0+u-b2)
30437 p2=b3/2d0+sqrt(b3**2/4d0+u-b2)
30438 q1=u/2d0+sqrt(u**2/4d0-b0)
30439 q2=u/2d0-sqrt(u**2/4d0-b0)
30440 IF(abs(p1*q1+p2*q2-b1).LT.abs(p1*q2+p2*q1-b1)) THEN
30441 qsav=q1
30442 q1=q2
30443 q2=qsav
30444 ENDIF
30445 x(1)=-p1/2d0+sqrt(p1**2/4d0-q1)
30446 x(2)=-p1/2d0-sqrt(p1**2/4d0-q1)
30447 x(3)=-p2/2d0+sqrt(p2**2/4d0-q2)
30448 x(4)=-p2/2d0-sqrt(p2**2/4d0-q2)
30449
30450C...Order eigenvalues in asceding mass.
30451 w(1)=x(1)
30452 DO 150 i1=2,4
30453 DO 130 i2=i1-1,1,-1
30454 IF(abs(x(i1)).GE.abs(w(i2))) GOTO 140
30455 w(i2+1)=w(i2)
30456 130 CONTINUE
30457 140 w(i2+1)=x(i1)
30458 150 CONTINUE
30459
30460C...Find equation system for eigenvectors.
30461 DO 250 i=1,4
30462 DO 170 j1=1,4
30463 d(j1,j1)=a(j1,j1)-w(i)
30464 DO 160 j2=j1+1,4
30465 d(j1,j2)=a(j1,j2)
30466 d(j2,j1)=a(j2,j1)
30467 160 CONTINUE
30468 170 CONTINUE
30469
30470C...Find largest element in matrix.
30471 damax=0d0
30472 DO 190 j1=1,4
30473 DO 180 j2=1,4
30474 IF(abs(d(j1,j2)).LE.damax) GOTO 180
30475 ja=j1
30476 jb=j2
30477 damax=abs(d(j1,j2))
30478 180 CONTINUE
30479 190 CONTINUE
30480
30481C...Subtract others by multiple of row selected above.
30482 damax=0d0
30483 DO 210 j3=ja+1,ja+3
30484 j1=j3-4*((j3-1)/4)
30485 rl=d(j1,jb)/d(ja,jb)
30486 DO 200 j2=1,4
30487 d(j1,j2)=d(j1,j2)-rl*d(ja,j2)
30488 IF(abs(d(j1,j2)).LE.damax) GOTO 200
30489 jc=j1
30490 jd=j2
30491 damax=abs(d(j1,j2))
30492 200 CONTINUE
30493 210 CONTINUE
30494
30495C...Do one more subtraction of a row.
30496 damax=0d0
30497 DO 230 j3=jc+1,jc+3
30498 j1=j3-4*((j3-1)/4)
30499 IF(j1.EQ.ja) GOTO 230
30500 rl=d(j1,jd)/d(jc,jd)
30501 DO 220 j2=1,4
30502 IF(j2.EQ.jb) GOTO 220
30503 d(j1,j2)=d(j1,j2)-rl*d(jc,j2)
30504 IF(abs(d(j1,j2)).LE.damax) GOTO 220
30505 je=j1
30506 damax=abs(d(j1,j2))
30507 220 CONTINUE
30508 230 CONTINUE
30509
30510C...Construct unnormalized eigenvector.
30511 jf1=jd+1-4*(jd/4)
30512 jf2=jd+2-4*((jd+1)/4)
30513 IF(jf1.EQ.jb) jf1=jd+3-4*((jd+2)/4)
30514 IF(jf2.EQ.jb) jf2=jd+3-4*((jd+2)/4)
30515 e(jf1)=-d(je,jf2)
30516 e(jf2)=d(je,jf1)
30517 e(jd)=-(d(jc,jf1)*e(jf1)+d(jc,jf2)*e(jf2))/d(jc,jd)
30518 e(jb)=-(d(ja,jf1)*e(jf1)+d(ja,jf2)*e(jf2)+d(ja,jd)*e(jd))/
30519 & d(ja,jb)
30520
30521C...Normalize and fill in final array.
30522 ea=sqrt(e(1)**2+e(2)**2+e(3)**2+e(4)**2)
30523 sgn=(-1d0)**int(pyr(0)+0.5d0)
30524 DO 240 j=1,4
30525 z(i,j)=sgn*e(j)/ea
30526 240 CONTINUE
30527 250 CONTINUE
30528
30529 RETURN
30530 END
30531
30532C*********************************************************************
30533
30534C...PYHGGM
30535C...Determines the Higgs boson mass spectrum using several inputs.
30536
30537 SUBROUTINE pyhggm(ALPHA)
30538
30539C...Double precision and integer declarations.
30540 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30541 IMPLICIT INTEGER(I-N)
30542 INTEGER PYK,PYCHGE,PYCOMP
30543C...Parameter statement to help give large particle numbers.
30544 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30545C...Commonblocks.
30546 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30547 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30548 common/pypars/mstp(200),parp(200),msti(200),pari(200)
30549 common/pymssm/imss(0:99),rmss(0:99)
30550 SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/
30551
30552C...Local variables.
30553 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
30554 DOUBLE PRECISION ALPHA
30555 INTEGER I,J,IHOPT,II,JJ,IT
30556 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
30557 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
30558 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
30559 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
30560
30561 ihopt=imss(4)
30562 IF(ihopt.EQ.2) THEN
30563 alpha=rmss(18)
30564 RETURN
30565 ENDIF
30566 at=rmss(16)
30567 ab=rmss(15)
30568 xmu=rmss(4)
30569 tanb=rmss(5)
30570
30571 dma=rmss(19)
30572 dtanb=tanb
30573 dmq=rmss(10)
30574 dmur=rmss(12)
30575 dmdr=rmss(11)
30576 dmtop=pmas(6,1)
30577 dmc=pmas(pycomp(ksusy1+37),1)
30578 dau=at
30579 dad=ab
30580 dmu=xmu
30581
30582 IF(ihopt.EQ.0) THEN
30583 CALL pysubh (dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
30584 & dmhch,dsa,dca,dtanba)
30585 ELSEIF(ihopt.EQ.1) THEN
30586 CALL pysubh (dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
30587 & dmhch,dsa,dca,dtanba)
30588 CALL pypole(3,dmc,dma,dtanb,dmq,dmur,dmdr,dmtop,dau,dad,dmu,
30589 & dmh,dmhp,dhm,dhmp,damp,dsa,dca,
30590 & dstop1,dstop2,dsbot1,dsbot2,dtanba)
30591 dmh=dmhp
30592 dhm=dhmp
30593 dma=damp
30594 IF(abs(pmas(pycomp(1000006),1)-dstop2).GT.5d-1) THEN
30595 WRITE(mstu(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
30596 WRITE(mstu(11),*) ' STOP1 MASSES = ',
30597 & pmas(pycomp(1000006),1),dstop2
30598 ENDIF
30599 IF(abs(pmas(pycomp(2000006),1)-dstop1).GT.5d-1) THEN
30600 WRITE(mstu(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
30601 WRITE(mstu(11),*) ' STOP2 MASSES = ',
30602 & pmas(pycomp(2000006),1),dstop1
30603 ENDIF
30604 IF(abs(pmas(pycomp(1000005),1)-dsbot2).GT.5d-1) THEN
30605 WRITE(mstu(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
30606 WRITE(mstu(11),*) ' SBOT1 MASSES = ',
30607 & pmas(pycomp(1000005),1),dsbot2
30608 ENDIF
30609 IF(abs(pmas(pycomp(2000005),1)-dsbot1).GT.5d-1) THEN
30610 WRITE(mstu(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
30611 WRITE(mstu(11),*) ' SBOT2 MASSES = ',
30612 & pmas(pycomp(2000005),1),dsbot1
30613 ENDIF
30614
30615 ENDIF
30616
30617 alpha=acos(dca)
30618
30619 pmas(25,1)=dmh
30620 pmas(35,1)=dhm
30621 pmas(36,1)=dma
30622 pmas(37,1)=dmhch
30623
30624 RETURN
30625 END
30626
30627C*********************************************************************
30628
30629C...PYSUBH
30630C...This routine computes the renormalization group improved
30631C...values of Higgs masses and couplings in the MSSM.
30632
30633C...Program based on the work by M. Carena, J.R. Espinosa,
30634c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
30635
30636C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
30637C...All masses in GeV units. MA is the CP-odd Higgs mass,
30638C...MTOP is the physical top mass, MQ and MUR are the soft
30639C...supersymmetry breaking mass parameters of left handed
30640C...and right handed stops respectively, AU and AD are the
30641C...stop and sbottom trilinear soft breaking terms,
30642C...respectively, and MU is the supersymmetric
30643C...Higgs mass parameter. We use the conventions from
30644C...the physics report of Haber and Kane: left right
30645C...stop mixing term proportional to (AU - MU/TANB)
30646C...We use as input TANB defined at the scale MTOP
30647
30648C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
30649C...where MH and HM are the lightest and heaviest CP-even
30650C...Higgs masses, MHCH is the charged Higgs mass and
30651C...ALPHA is the Higgs mixing angle
30652C...TANBA is the angle TANB at the CP-odd Higgs mass scale
30653
30654C...Range of validity:
30655C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
30656C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
30657C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
30658C...are the sbottom mass eigenvalues, respectively. This
30659C...range automatically excludes the existence of tachyons.
30660C...For the charged Higgs mass computation, the method is
30661C...valid if
30662C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
30663C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
30664C...where M_SUSY**2 is the average of the squared stop mass
30665C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
30666C...masses have been assumed to be of order of the stop ones
30667C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
30668
30669 SUBROUTINE pysubh (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
30670 &XMHCH,SA,CA,TANBA)
30671
30672C...Double precision and integer declarations.
30673 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30674 IMPLICIT INTEGER(I-N)
30675 INTEGER PYK,PYCHGE,PYCOMP
30676C...Parameter statement to help give large particle numbers.
30677 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30678C...Commonblocks.
30679 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30680 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30681 common/pyhtri/hhh(7)
30682 SAVE /pydat1/,/pydat2/
30683
30684C...Local variables.
30685 DOUBLE PRECISION PYALEM,PYALPS
30686 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
30687 DOUBLE PRECISION XMHCH,SA,CA
30688 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
30689 DOUBLE PRECISION Q02
30690 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
30691 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
30692 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
30693 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
30694 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
30695 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
30696 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
30697 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
30698
30699 xmz = pmas(23,1)
30700 q02=xmz**2
30701 aem=pyalem(q02)
30702 alp1=aem/(1d0-paru(102))
30703 alp2=aem/paru(102)
30704 alph3z=pyalps(q02)
30705
30706 alp1 = 0.0101d0
30707 alp2 = 0.0337d0
30708 alph3z = 0.12d0
30709
30710 v = 174.1d0
30711 pi = paru(1)
30712 tanba = tanb
30713 tanbt = tanb
30714
30715C...MBOTTOM(MTOP) = 3. GEV
30716 xmb = 3d0
30717 alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*
30718 &log(xmtop**2/xmz**2))
30719
30720C...RMTOP= RUNNING TOP QUARK MASS
30721 rmtop = xmtop/(1d0+4d0*alp3/3d0/pi)
30722 xms = ((xmq**2 + xmur**2)/2d0 + xmtop**2)**0.5d0
30723 t = log(xms**2/xmtop**2)
30724 sinb = tanb/((1d0 + tanb**2)**0.5d0)
30725 cosb = sinb/tanb
30726C...IF(MA.LE.XMTOP) TANBA = TANBT
30727 IF(xma.GT.xmtop)
30728 &tanba = tanbt*(1d0-3d0/32d0/pi**2*
30729 &(rmtop**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
30730 &log(xma**2/xmtop**2))
30731
30732 sinbt = tanbt/sqrt(1d0 + tanbt**2)
30733 cosbt = 1d0/sqrt(1d0 + tanbt**2)
30734 cos2bt = (tanbt**2 - 1d0)/(tanbt**2 + 1d0)
30735 g1 = sqrt(alp1*4d0*pi)
30736 g2 = sqrt(alp2*4d0*pi)
30737 g3 = sqrt(alp3*4d0*pi)
30738 hu = rmtop/v/sinbt
30739 hd = xmb/v/cosbt
30740 hu2=hu*hu
30741 hd2=hd*hd
30742 hu4=hu2*hu2
30743 hd4=hd2*hd2
30744 au2=au**2
30745 ad2=ad**2
30746 xms2=xms**2
30747 xms3=xms**3
30748 xms4=xms2*xms2
30749 xmu2=xmu*xmu
30750 pi2=pi*pi
30751
30752 xau = (2d0*au2/xms2)*(1d0 - au2/12d0/xms2)
30753 xad = (2d0*ad2/xms2)*(1d0 - ad2/12d0/xms2)
30754 aud = (-6d0*xmu2/xms2 - ( xmu2- ad*au)**2/xms4
30755 &+ 3d0*(au + ad)**2/xms2)/6d0
30756 xlam1 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hd2*t/8d0/pi2)
30757 &+(3d0*hd4/8d0/pi2) * (t + xad/2d0 + (3d0*hd2/2d0 + hu2/2d0
30758 &- 8d0*g3**2) * (xad*t + t**2)/16d0/pi2)
30759 &-(3d0*hu4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hu2 -5d0* hd2
30760 &- 16d0*g3**2) *t/16d0/pi2)
30761 xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu2*t/8d0/pi2)
30762 &+(3d0*hu4/8d0/pi2) * (t + xau/2d0 + (3d0*hu2/2d0 + hd2/2d0
30763 &- 8d0*g3**2) * (xau*t + t**2)/16d0/pi2)
30764 &-(3d0*hd4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hd2 -5d0* hu2
30765 &- 16d0*g3**2) *t/16d0/pi2)
30766 xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
30767 &(hu2 + hd2)*t/16d0/pi2)
30768 &+(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
30769 &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
30770 &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
30771 &xms4)* (1d0+ (6d0*hu2 -2d0* hd2/2d0
30772 &- 16d0*g3**2) *t/16d0/pi2)
30773 &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
30774 &xms4)*(1d0+ (6d0*hd2 -2d0* hu2
30775 &- 16d0*g3**2) *t/16d0/pi2)
30776 xlam4 = (- g2**2/2d0)*(1d0-3d0*(hu2 + hd2)*t/16d0/pi2)
30777 &-(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
30778 &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
30779 &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
30780 &xms4)*
30781 &(1+ (6d0*hu2 -2d0* hd2
30782 &- 16d0*g3**2) *t/16d0/pi2)
30783 &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
30784 &xms4)*
30785 &(1+ (6d0*hd2 -2d0* hu2/2d0
30786 &- 16d0*g3**2) *t/16d0/pi2)
30787 xlam5 = -(3d0*hu4* xmu2*au2/96d0/pi2/xms4) *
30788 &(1- (2d0*hd2 -6d0* hu2 + 16d0*g3**2) *t/16d0/pi2)
30789 &-(3d0*hd4* xmu2*ad2/96d0/pi2/xms4) *
30790 &(1- (2d0*hu2 -6d0* hd2 + 16d0*g3**2) *t/16d0/pi2)
30791 xlam6 = (3d0*hu4* xmu**3*au/96d0/pi2/xms4) *
30792 &(1- (7d0*hd2/2d0 -15d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
30793 &+(3d0*hd4* xmu *(ad**3/xms3 - 6d0*ad/xms )/96d0/pi2/xms) *
30794 &(1- (hu2/2d0 -9d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
30795 xlam7 = (3d0*hd4* xmu**3*ad/96d0/pi2/xms4) *
30796 &(1- (7d0*hu2/2d0 -15d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
30797 &+(3d0*hu4* xmu *(au**3/xms3 - 6d0*au/xms )/96d0/pi2/xms) *
30798 &(1- (hd2/2d0 -9d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
30799 hhh(1)=xlam1
30800 hhh(2)=xlam2
30801 hhh(3)=xlam3
30802 hhh(4)=xlam4
30803 hhh(5)=xlam5
30804 hhh(6)=xlam6
30805 hhh(7)=xlam7
30806 trm2 = xma**2 + 2d0*v**2* (xlam1* cosbt**2 +
30807 &2d0* xlam6*sinbt*cosbt
30808 &+ xlam5*sinbt**2 + xlam2* sinbt**2 + 2d0* xlam7*sinbt*cosbt
30809 &+ xlam5*cosbt**2)
30810 detm2 = 4d0*v**4*(-(sinbt*cosbt*(xlam3 + xlam4) +
30811 &xlam6*cosbt**2
30812 &+ xlam7* sinbt**2)**2 + (xlam1* cosbt**2 +
30813 &2d0* xlam6* cosbt*sinbt
30814 &+ xlam5*sinbt**2)*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
30815 &+ xlam5*cosbt**2)) + xma**2*2d0*v**2 *
30816 &((xlam1* cosbt**2 +2d0*
30817 &xlam6* cosbt*sinbt + xlam5*sinbt**2)*cosbt**2 +
30818 &(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt + xlam5*cosbt**2)
30819 &*sinbt**2
30820 &+2d0*sinbt*cosbt* (sinbt*cosbt*(xlam3
30821 &+ xlam4) + xlam6*cosbt**2
30822 &+ xlam7* sinbt**2))
30823
30824 xmh2 = (trm2 - sqrt(trm2**2 - 4d0* detm2))/2d0
30825 xhm2 = (trm2 + sqrt(trm2**2 - 4d0* detm2))/2d0
30826 xhm = sqrt(xhm2)
30827 xmh = sqrt(xmh2)
30828 xmhch2 = xma**2 + (xlam5 - xlam4)* v**2
30829 xmhch = sqrt(xmhch2)
30830
30831 sinalp = sqrt(((trm2**2 - 4d0* detm2)**0.5d0) -
30832 &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
30833 &xlam6* cosbt*sinbt
30834 &+ xlam5*sinbt**2) + xma**2*sinbt**2)
30835 &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
30836 &+ xlam5*cosbt**2) + xma**2*cosbt**2)))/
30837 &sqrt(((trm2**2 - 4d0* detm2)**0.5d0))/2d0**0.5d0
30838
30839 cosalp = (2d0*(2d0*v**2*(sinbt*cosbt*(xlam3 + xlam4) +
30840 &xlam6*cosbt**2 + xlam7* sinbt**2) -
30841 &xma**2*sinbt*cosbt))/2d0**0.5d0/
30842 &sqrt(((trm2**2 - 4d0* detm2)**0.5d0)*
30843 &(((trm2**2 - 4d0* detm2)**0.5d0) -
30844 &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
30845 &xlam6* cosbt*sinbt
30846 &+ xlam5*sinbt**2) + xma**2*sinbt**2)
30847 &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
30848 &+ xlam5*cosbt**2) + xma**2*cosbt**2))))
30849
30850 sa = -sinalp
30851 ca = -cosalp
30852
30853 100 CONTINUE
30854
30855 RETURN
30856 END
30857
30858C*********************************************************************
30859
30860C...PYPOLE
30861C...This subroutine computes the CP-even higgs and CP-odd pole
30862c...Higgs masses and mixing angles.
30863
30864C...Program based on the work by M. Carena, M. Quiros
30865C...and C.E.M. Wagner, "Effective potential methods and
30866C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
30867
30868C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
30869C...AT,AB,MU
30870C...where MCHI is the largest chargino mass, MA is the running
30871C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
30872C...expectaion values at the scale MTOP, MQ is the third generation
30873C...left handed squark mass parameter, MUR is the third generation
30874C...right handed stop mass parameter, MDR is the third generation
30875C...right handed sbottom mass parameter, MTOP is the pole top quark
30876C...mass; AT,AB are the soft supersymmetry breaking trilinear
30877C...couplings of the stop and sbottoms, respectively, and MU is the
30878C...supersymmetric mass parameter
30879
30880C...The parameter IHIGGS=0,1,2,3 corresponds to the
30881c...number of Higgses whose pole mass is computed
30882c...by the subroutine PYVACU(...). If IHIGGS=0 only running
30883c...masses are given, what makes the running of the program
30884c...much faster and it is quite generally a good approximation
30885c...(for a theoretical discussion see ref. below).
30886c...If IHIGGS=1, only the pole
30887c...mass for H is computed. If IHIGGS=2, then h and H, and
30888c...if IHIGGS=3, then h,H,A polarizations are computed
30889
30890C...Output: MH and MHP which are the lightest CP-even Higgs running
30891C...and pole masses, respectively; HM and HMP are the heaviest CP-even
30892C...Higgs running and pole masses, repectively; SA and CA are the
30893C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
30894C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
30895C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
30896C...the value of TANB at the CP-odd Higgs mass scale
30897
30898C...This subroutine makes use of CERN library subroutine
30899C...integration package, which makes the computation of the
30900C...pole Higgs masses somewhat faster. We thank P. Janot for this
30901C...improvement. Those who are not able to call the CERN
30902C...libraries, please use the subroutine SUBHPOLE2.F, which
30903C...although somewhat slower, gives identical results
30904
30905 SUBROUTINE pypole(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
30906 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
30907
30908C...Double precision and integer declarations.
30909 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30910 IMPLICIT INTEGER(I-N)
30911
30912C...Parameters.
30913 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30914 INTEGER PYK,PYCHGE,PYCOMP
30915
30916C...Local variables.
30917 dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),
30918 &ssbot2(2),b(2,2),coupb(2,2),
30919 &hcoupt(2,2),hcoupb(2,2),
30920 &acoupt(2,2),acoupb(2,2),pr(3), polar(3)
30921
30922 delta(1,1) = 1d0
30923 delta(2,2) = 1d0
30924 delta(1,2) = 0d0
30925 delta(2,1) = 0d0
30926 v = 174.1d0
30927 xmz=91.18d0
30928 pi=3.14159d0
30929 alp3z=0.12d0
30930 alp3=1d0/(1d0/alp3z+23d0/6d0/pi*log(xmt/xmz))
30931
30932C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
30933 rxmt = pyrnmt(xmt)
30934
30935 ht = rxmt /v
30936 CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,
30937 &xmu,xmh,hm,sa,ca,tanba)
30938 sinb = tanb/(tanb**2+1d0)**0.5d0
30939 cosb = 1d0/(tanb**2+1d0)**0.5d0
30940 cos2b = sinb**2 - cosb**2
30941 sinbpa = sinb*ca + cosb*sa
30942 cosbpa = cosb*ca - sinb*sa
30943 rmbot = 3d0
30944 xmq2 = xmq**2
30945 xmur2 = xmur**2
30946 IF(xmur.LT.0d0) xmur2=-xmur2
30947 xmdr2 = xmdr**2
30948 xmst11 = rxmt**2 + xmq2 - 0.35d0*xmz**2*cos2b
30949 xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b
30950 IF(xmst11.LT.0d0) GOTO 500
30951 IF(xmst22.LT.0d0) GOTO 500
30952 xmsb11 = rmbot**2 + xmq2 + 0.42d0*xmz**2*cos2b
30953 xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b
30954 IF(xmsb11.LT.0d0) GOTO 500
30955 IF(xmsb22.LT.0d0) GOTO 500
30956 wmst11 = rxmt**2 + xmq2
30957 wmst22 = rxmt**2 + xmur2
30958 xmst12 = rxmt*(at - xmu/tanb)
30959 xmsb12 = rmbot*(ab - xmu*tanb)
30960
30961CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30962C...STOP EIGENVALUES CALCULATION
30963CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30964
30965 stop12 = 0.5d0*(xmst11+xmst22) +
30966 &0.5d0*((xmst11+xmst22)**2 -
30967 &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0
30968 stop22 = 0.5d0*(xmst11+xmst22) -
30969 &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -
30970 &xmst12**2))**0.5d0
30971
30972 IF(stop22.LT.0d0) GOTO 500
30973 sstop2(1) = stop12
30974 sstop2(2) = stop22
30975 stop1 = stop12**0.5d0
30976 stop2 = stop22**0.5d0
30977 stop1w = stop1
30978 stop2w = stop2
30979
30980 IF(xmst12.EQ.0d0) xst11 = 1d0
30981 IF(xmst12.EQ.0d0) xst12 = 0d0
30982 IF(xmst12.EQ.0d0) xst21 = 0d0
30983 IF(xmst12.EQ.0d0) xst22 = 1d0
30984
30985 IF(xmst12.EQ.0d0) GOTO 110
30986
30987 100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0
30988 xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0
30989 xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0
30990 xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0
30991
30992 110 t(1,1) = xst11
30993 t(2,2) = xst22
30994 t(1,2) = xst12
30995 t(2,1) = xst21
30996
30997 sbot12 = 0.5d0*(xmsb11+xmsb22) +
30998 &0.5d0*((xmsb11+xmsb22)**2 -
30999 &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0
31000 sbot22 = 0.5d0*(xmsb11+xmsb22) -
31001 &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -
31002 &xmsb12**2))**0.5d0
31003 IF(sbot22.LT.0d0) GOTO 500
31004 sbot1 = sbot12**0.5d0
31005 sbot2 = sbot22**0.5d0
31006
31007 ssbot2(1) = sbot12
31008 ssbot2(2) = sbot22
31009
31010 IF(xmsb12.EQ.0d0) xsb11 = 1d0
31011 IF(xmsb12.EQ.0d0) xsb12 = 0d0
31012 IF(xmsb12.EQ.0d0) xsb21 = 0d0
31013 IF(xmsb12.EQ.0d0) xsb22 = 1d0
31014
31015 IF(xmsb12.EQ.0d0) GOTO 130
31016
31017 120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
31018 xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
31019 xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
31020 xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
31021
31022 130 b(1,1) = xsb11
31023 b(2,2) = xsb22
31024 b(1,2) = xsb12
31025 b(2,1) = xsb21
31026
31027
31028 sint = 0.2320d0
31029 sqr = 2d0**0.5d0
31030 vp = 174.1d0*sqr
31031
31032CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31033C...STARTING OF LIGHT HIGGS
31034CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31035
31036 IF(ihiggs.EQ.0) GOTO 490
31037
31038 DO 150 i = 1,2
31039 DO 140 j = 1,2
31040 coupt(i,j) =
31041 & sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +
31042 & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
31043 & -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)
31044 & -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +
31045 & t(1,j)*t(2,i))
31046 140 CONTINUE
31047 150 CONTINUE
31048
31049
31050 DO 170 i = 1,2
31051 DO 160 j = 1,2
31052 coupb(i,j) =
31053 & -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +
31054 & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
31055 & +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)
31056 & +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +
31057 & b(1,j)*b(2,i))
31058 160 CONTINUE
31059 170 CONTINUE
31060
31061 prun = xmh
31062 eps = 1d-4*prun
31063 iter = 0
31064 180 iter = iter + 1
31065 DO 230 i3 = 1,3
31066
31067 pr(i3)=prun+(i3-2)*eps/2
31068 p2=pr(i3)**2
31069 polt = 0d0
31070 DO 200 i = 1,2
31071 DO 190 j = 1,2
31072 polt = polt + coupt(i,j)**2*3d0*
31073 & pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2
31074 190 CONTINUE
31075 200 CONTINUE
31076 polb = 0d0
31077 DO 220 i = 1,2
31078 DO 210 j = 1,2
31079 polb = polb + coupb(i,j)**2*3d0*
31080 & pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2
31081 210 CONTINUE
31082 220 CONTINUE
31083 rxmt2 = rxmt**2
31084 xmt2=xmt**2
31085
31086 poltt =
31087 & 3d0*rxmt**2/8d0/pi**2/ v **2*
31088 & ca**2/sinb**2 *
31089 & (-2d0*xmt**2+0.5d0*p2)*
31090 & pyfint(p2,xmt2,xmt2)
31091
31092 pol = polt + polb + poltt
31093 polar(i3) = p2 - xmh**2 - pol
31094 230 CONTINUE
31095 deriv = (polar(3)-polar(1))/eps
31096 drun = - polar(2)/deriv
31097 prun = prun + drun
31098 p2 = prun**2
31099 IF( abs(drun) .LT. 1d-4 .OR.iter.GT.100 ) GOTO 240
31100 GOTO 180
31101 240 CONTINUE
31102
31103 xmhp = p2**0.5d0
31104
31105CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31106C...END OF LIGHT HIGGS
31107CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31108
31109 250 IF(ihiggs.EQ.1) GOTO 490
31110
31111CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31112C... STARTING OF HEAVY HIGGS
31113CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31114
31115 DO 270 i = 1,2
31116 DO 260 j = 1,2
31117 hcoupt(i,j) =
31118 & -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +
31119 & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
31120 & -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)
31121 & -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +
31122 & t(1,j)*t(2,i))
31123 260 CONTINUE
31124 270 CONTINUE
31125
31126 DO 290 i = 1,2
31127 DO 280 j = 1,2
31128 hcoupb(i,j) =
31129 & sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +
31130 & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
31131 & -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)
31132 & -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +
31133 & b(1,j)*b(2,i))
31134 hcoupb(i,j)=0d0
31135 280 CONTINUE
31136 290 CONTINUE
31137
31138 prun = hm
31139 eps = 1d-4*prun
31140 iter = 0
31141 300 iter = iter + 1
31142 DO 350 i3 = 1,3
31143 pr(i3)=prun+(i3-2)*eps/2
31144 hp2=pr(i3)**2
31145
31146 hpolt = 0d0
31147 DO 320 i = 1,2
31148 DO 310 j = 1,2
31149 hpolt = hpolt + hcoupt(i,j)**2*3d0*
31150 & pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2
31151 310 CONTINUE
31152 320 CONTINUE
31153
31154 hpolb = 0d0
31155 DO 340 i = 1,2
31156 DO 330 j = 1,2
31157 hpolb = hpolb + hcoupb(i,j)**2*3d0*
31158 & pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2
31159 330 CONTINUE
31160 340 CONTINUE
31161
31162 rxmt2 = rxmt**2
31163 xmt2 = xmt**2
31164
31165 hpoltt =
31166 & 3d0*rxmt**2/8d0/pi**2/ v **2*
31167 & sa**2/sinb**2 *
31168 & (-2d0*xmt**2+0.5d0*hp2)*
31169 & pyfint(hp2,xmt2,xmt2)
31170
31171 hpol = hpolt + hpolb + hpoltt
31172 polar(i3) =hp2-hm**2-hpol
31173 350 CONTINUE
31174 deriv = (polar(3)-polar(1))/eps
31175 drun = - polar(2)/deriv
31176 prun = prun + drun
31177 hp2 = prun**2
31178 IF( abs(drun) .LT. 1d-4 .OR.iter.GT.100 ) GOTO 360
31179 GOTO 300
31180 360 CONTINUE
31181
31182
31183 370 CONTINUE
31184 hmp = hp2**0.5d0
31185
31186CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31187C... END OF HEAVY HIGGS
31188CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31189
31190 IF(ihiggs.EQ.2) GOTO 490
31191
31192CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31193C...BEGINNING OF PSEUDOSCALAR HIGGS
31194CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31195
31196 DO 390 i = 1,2
31197 DO 380 j = 1,2
31198 acoupt(i,j) =
31199 & -rxmt/vp/sinb*(at*cosb + xmu*sinb)*
31200 & (t(1,i)*t(2,j) -t(1,j)*t(2,i))
31201 380 CONTINUE
31202 390 CONTINUE
31203 DO 410 i = 1,2
31204 DO 400 j = 1,2
31205 acoupb(i,j) =
31206 & rmbot/vp/cosb*(ab*sinb + xmu*cosb)*
31207 & (b(1,i)*b(2,j) -b(1,j)*b(2,i))
31208 400 CONTINUE
31209 410 CONTINUE
31210
31211 prun = xma
31212 eps = 1d-4*prun
31213 iter = 0
31214 420 iter = iter + 1
31215 DO 470 i3 = 1,3
31216 pr(i3)=prun+(i3-2)*eps/2
31217 ap2=pr(i3)**2
31218 apolt = 0d0
31219 DO 440 i = 1,2
31220 DO 430 j = 1,2
31221 apolt = apolt + acoupt(i,j)**2*3d0*
31222 & pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2
31223 430 CONTINUE
31224 440 CONTINUE
31225 apolb = 0d0
31226 DO 460 i = 1,2
31227 DO 450 j = 1,2
31228 apolb = apolb + acoupb(i,j)**2*3d0*
31229 & pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2
31230 450 CONTINUE
31231 460 CONTINUE
31232 rxmt2 = rxmt**2
31233 xmt2=xmt**2
31234 apoltt =
31235 & 3d0*rxmt**2/8d0/pi**2/ v **2*
31236 & cosb**2/sinb**2 *
31237 & (-0.5d0*ap2)*
31238 & pyfint(ap2,xmt2,xmt2)
31239 apol = apolt + apolb + apoltt
31240 polar(i3) = ap2 - xma**2 -apol
31241 470 CONTINUE
31242 deriv = (polar(3)-polar(1))/eps
31243 drun = - polar(2)/deriv
31244 prun = prun + drun
31245 ap2 = prun**2
31246 IF( abs(drun) .LT. 1d-4 .OR.iter.GT.100 ) GOTO 480
31247 GOTO 420
31248 480 CONTINUE
31249
31250 amp = ap2**0.5d0
31251
31252CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31253C...END OF PSEUDOSCALAR HIGGS
31254CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31255
31256 IF(ihiggs.EQ.3) GOTO 490
31257
31258 490 CONTINUE
31259 RETURN
31260 500 CONTINUE
31261 WRITE(mstu(11),*) ' EXITING IN PYVACU '
31262 WRITE(mstu(11),*) ' XMST11,XMST22 = ',xmst11,xmst22
31263 WRITE(mstu(11),*) ' XMSB11,XMSB22 = ',xmsb11,xmsb22
31264 WRITE(mstu(11),*) ' STOP22,SBOT22 = ',stop22,sbot22
31265 stop
31266 END
31267
31268C*********************************************************************
31269
31270C...PYVACU
31271C...Computes Higgs masses and mixing angles, see PYPOLE above.
31272
31273 SUBROUTINE pyvacu(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
31274 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
31275 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
31276
31277C...Double precision and integer declarations.
31278 IMPLICIT DOUBLE PRECISION(a-h, o-z)
31279 IMPLICIT INTEGER(I-N)
31280C...Parameters.
31281 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31282 INTEGER PYK,PYCHGE,PYCOMP
31283
31284C...Local variables.
31285 dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),
31286 &ssbot2(2),b(2,2),coupb(2,2),
31287 &hcoupt(2,2),hcoupb(2,2),
31288 &acoupt(2,2),acoupb(2,2),pr(3), polar(3)
31289
31290 delta(1,1) = 1d0
31291 delta(2,2) = 1d0
31292 delta(1,2) = 0d0
31293 delta(2,1) = 0d0
31294 v = 174.1d0
31295 xmz=91.18d0
31296 pi=3.14159d0
31297 alp3z=0.12d0
31298 alp3=1d0/(1d0/alp3z+23d0/6d0/pi*log(xmt/xmz))
31299
31300C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
31301 rxmt = pyrnmt(xmt)
31302
31303 ht = rxmt /v
31304 CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,
31305 &xmu,xmh,hm,sa,ca,tanba)
31306 sinb = tanb/(tanb**2+1d0)**0.5d0
31307 cosb = 1d0/(tanb**2+1d0)**0.5d0
31308 cos2b = sinb**2 - cosb**2
31309 sinbpa = sinb*ca + cosb*sa
31310 cosbpa = cosb*ca - sinb*sa
31311 rmbot = 3d0
31312 xmq2 = xmq**2
31313 xmur2 = xmur**2
31314 IF(xmur.LT.0d0) xmur2=-xmur2
31315 xmdr2 = xmdr**2
31316 xmst11 = rxmt**2 + xmq2 - 0.35d0*xmz**2*cos2b
31317 xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b
31318 IF(xmst11.LT.0d0) GOTO 500
31319 IF(xmst22.LT.0d0) GOTO 500
31320 xmsb11 = rmbot**2 + xmq2 + 0.42d0*xmz**2*cos2b
31321 xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b
31322 IF(xmsb11.LT.0d0) GOTO 500
31323 IF(xmsb22.LT.0d0) GOTO 500
31324 wmst11 = rxmt**2 + xmq2
31325 wmst22 = rxmt**2 + xmur2
31326 xmst12 = rxmt*(at - xmu/tanb)
31327 xmsb12 = rmbot*(ab - xmu*tanb)
31328
31329CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31330C...STOP EIGENVALUES CALCULATION
31331CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31332
31333 stop12 = 0.5d0*(xmst11+xmst22) +
31334 &0.5d0*((xmst11+xmst22)**2 -
31335 &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0
31336 stop22 = 0.5d0*(xmst11+xmst22) -
31337 &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -
31338 &xmst12**2))**0.5d0
31339
31340 IF(stop22.LT.0d0) GOTO 500
31341 sstop2(1) = stop12
31342 sstop2(2) = stop22
31343 stop1 = stop12**0.5d0
31344 stop2 = stop22**0.5d0
31345 stop1w = stop1
31346 stop2w = stop2
31347
31348 IF(xmst12.EQ.0d0) xst11 = 1d0
31349 IF(xmst12.EQ.0d0) xst12 = 0d0
31350 IF(xmst12.EQ.0d0) xst21 = 0d0
31351 IF(xmst12.EQ.0d0) xst22 = 1d0
31352
31353 IF(xmst12.EQ.0d0) GOTO 110
31354
31355 100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0
31356 xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0
31357 xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0
31358 xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0
31359
31360 110 t(1,1) = xst11
31361 t(2,2) = xst22
31362 t(1,2) = xst12
31363 t(2,1) = xst21
31364
31365 sbot12 = 0.5d0*(xmsb11+xmsb22) +
31366 &0.5d0*((xmsb11+xmsb22)**2 -
31367 &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0
31368 sbot22 = 0.5d0*(xmsb11+xmsb22) -
31369 &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -
31370 &xmsb12**2))**0.5d0
31371 IF(sbot22.LT.0d0) GOTO 500
31372 sbot1 = sbot12**0.5d0
31373 sbot2 = sbot22**0.5d0
31374
31375 ssbot2(1) = sbot12
31376 ssbot2(2) = sbot22
31377
31378 IF(xmsb12.EQ.0d0) xsb11 = 1d0
31379 IF(xmsb12.EQ.0d0) xsb12 = 0d0
31380 IF(xmsb12.EQ.0d0) xsb21 = 0d0
31381 IF(xmsb12.EQ.0d0) xsb22 = 1d0
31382
31383 IF(xmsb12.EQ.0d0) GOTO 130
31384
31385 120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
31386 xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
31387 xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
31388 xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
31389
31390 130 b(1,1) = xsb11
31391 b(2,2) = xsb22
31392 b(1,2) = xsb12
31393 b(2,1) = xsb21
31394
31395
31396 sint = 0.2320d0
31397 sqr = 2d0**0.5d0
31398 vp = 174.1d0*sqr
31399
31400CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31401C...STARTING OF LIGHT HIGGS
31402CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31403
31404 IF(ihiggs.EQ.0) GOTO 490
31405
31406 DO 150 i = 1,2
31407 DO 140 j = 1,2
31408 coupt(i,j) =
31409 & sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +
31410 & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
31411 & -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)
31412 & -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +
31413 & t(1,j)*t(2,i))
31414 140 CONTINUE
31415 150 CONTINUE
31416
31417
31418 DO 170 i = 1,2
31419 DO 160 j = 1,2
31420 coupb(i,j) =
31421 & -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +
31422 & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
31423 & +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)
31424 & +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +
31425 & b(1,j)*b(2,i))
31426 160 CONTINUE
31427 170 CONTINUE
31428
31429 prun = xmh
31430 eps = 1d-4*prun
31431 iter = 0
31432 180 iter = iter + 1
31433 DO 230 i3 = 1,3
31434
31435 pr(i3)=prun+(i3-2)*eps/2
31436 p2=pr(i3)**2
31437 polt = 0d0
31438 DO 200 i = 1,2
31439 DO 190 j = 1,2
31440 polt = polt + coupt(i,j)**2*3d0*
31441 & pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2
31442 190 CONTINUE
31443 200 CONTINUE
31444 polb = 0d0
31445 DO 220 i = 1,2
31446 DO 210 j = 1,2
31447 polb = polb + coupb(i,j)**2*3d0*
31448 & pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2
31449 210 CONTINUE
31450 220 CONTINUE
31451 rxmt2 = rxmt**2
31452 xmt2=xmt**2
31453
31454 poltt =
31455 & 3d0*rxmt**2/8d0/pi**2/ v **2*
31456 & ca**2/sinb**2 *
31457 & (-2d0*xmt**2+0.5d0*p2)*
31458 & pyfint(p2,xmt2,xmt2)
31459
31460 pol = polt + polb + poltt
31461 polar(i3) = p2 - xmh**2 - pol
31462 230 CONTINUE
31463 deriv = (polar(3)-polar(1))/eps
31464 drun = - polar(2)/deriv
31465 prun = prun + drun
31466 p2 = prun**2
31467 IF( abs(drun) .LT. 1d-4 ) GOTO 240
31468 GOTO 180
31469 240 CONTINUE
31470
31471 xmhp = p2**0.5d0
31472
31473CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31474C...END OF LIGHT HIGGS
31475CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31476
31477 250 IF(ihiggs.EQ.1) GOTO 490
31478
31479CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31480C... STARTING OF HEAVY HIGGS
31481CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31482
31483 DO 270 i = 1,2
31484 DO 260 j = 1,2
31485 hcoupt(i,j) =
31486 & -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +
31487 & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
31488 & -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)
31489 & -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +
31490 & t(1,j)*t(2,i))
31491 260 CONTINUE
31492 270 CONTINUE
31493
31494 DO 290 i = 1,2
31495 DO 280 j = 1,2
31496 hcoupb(i,j) =
31497 & sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +
31498 & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
31499 & -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)
31500 & -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +
31501 & b(1,j)*b(2,i))
31502 hcoupb(i,j)=0d0
31503 280 CONTINUE
31504 290 CONTINUE
31505
31506 prun = hm
31507 eps = 1d-4*prun
31508 iter = 0
31509 300 iter = iter + 1
31510 DO 350 i3 = 1,3
31511 pr(i3)=prun+(i3-2)*eps/2
31512 hp2=pr(i3)**2
31513
31514 hpolt = 0d0
31515 DO 320 i = 1,2
31516 DO 310 j = 1,2
31517 hpolt = hpolt + hcoupt(i,j)**2*3d0*
31518 & pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2
31519 310 CONTINUE
31520 320 CONTINUE
31521
31522 hpolb = 0d0
31523 DO 340 i = 1,2
31524 DO 330 j = 1,2
31525 hpolb = hpolb + hcoupb(i,j)**2*3d0*
31526 & pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2
31527 330 CONTINUE
31528 340 CONTINUE
31529
31530 rxmt2 = rxmt**2
31531 xmt2 = xmt**2
31532
31533 hpoltt =
31534 & 3d0*rxmt**2/8d0/pi**2/ v **2*
31535 & sa**2/sinb**2 *
31536 & (-2d0*xmt**2+0.5d0*hp2)*
31537 & pyfint(hp2,xmt2,xmt2)
31538
31539 hpol = hpolt + hpolb + hpoltt
31540 polar(i3) =hp2-hm**2-hpol
31541 350 CONTINUE
31542 deriv = (polar(3)-polar(1))/eps
31543 drun = - polar(2)/deriv
31544 prun = prun + drun
31545 hp2 = prun**2
31546 IF( abs(drun) .LT. 1d-4 ) GOTO 360
31547 GOTO 300
31548 360 CONTINUE
31549
31550
31551 370 CONTINUE
31552 hmp = hp2**0.5d0
31553
31554CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31555C... END OF HEAVY HIGGS
31556CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31557
31558 IF(ihiggs.EQ.2) GOTO 490
31559
31560CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31561C...BEGINNING OF PSEUDOSCALAR HIGGS
31562CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31563
31564 DO 390 i = 1,2
31565 DO 380 j = 1,2
31566 acoupt(i,j) =
31567 & -rxmt/vp/sinb*(at*cosb + xmu*sinb)*
31568 & (t(1,i)*t(2,j) -t(1,j)*t(2,i))
31569 380 CONTINUE
31570 390 CONTINUE
31571 DO 410 i = 1,2
31572 DO 400 j = 1,2
31573 acoupb(i,j) =
31574 & rmbot/vp/cosb*(ab*sinb + xmu*cosb)*
31575 & (b(1,i)*b(2,j) -b(1,j)*b(2,i))
31576 400 CONTINUE
31577 410 CONTINUE
31578
31579 prun = xma
31580 eps = 1d-4*prun
31581 iter = 0
31582 420 iter = iter + 1
31583 DO 470 i3 = 1,3
31584 pr(i3)=prun+(i3-2)*eps/2
31585 ap2=pr(i3)**2
31586 apolt = 0d0
31587 DO 440 i = 1,2
31588 DO 430 j = 1,2
31589 apolt = apolt + acoupt(i,j)**2*3d0*
31590 & pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2
31591 430 CONTINUE
31592 440 CONTINUE
31593 apolb = 0d0
31594 DO 460 i = 1,2
31595 DO 450 j = 1,2
31596 apolb = apolb + acoupb(i,j)**2*3d0*
31597 & pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2
31598 450 CONTINUE
31599 460 CONTINUE
31600 rxmt2 = rxmt**2
31601 xmt2=xmt**2
31602 apoltt =
31603 & 3d0*rxmt**2/8d0/pi**2/ v **2*
31604 & cosb**2/sinb**2 *
31605 & (-0.5d0*ap2)*
31606 & pyfint(ap2,xmt2,xmt2)
31607 apol = apolt + apolb + apoltt
31608 polar(i3) = ap2 - xma**2 -apol
31609 470 CONTINUE
31610 deriv = (polar(3)-polar(1))/eps
31611 drun = - polar(2)/deriv
31612 prun = prun + drun
31613 ap2 = prun**2
31614 IF( abs(drun) .LT. 1d-4 ) GOTO 480
31615 GOTO 420
31616 480 CONTINUE
31617
31618 amp = ap2**0.5d0
31619
31620CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31621C...END OF PSEUDOSCALAR HIGGS
31622CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31623
31624 IF(ihiggs.EQ.3) GOTO 490
31625
31626 490 CONTINUE
31627 RETURN
31628 500 CONTINUE
31629 WRITE(mstu(11),*) ' EXITING IN PYVACU '
31630 WRITE(mstu(11),*) ' XMST11,XMST22 = ',xmst11,xmst22
31631 WRITE(mstu(11),*) ' XMSB11,XMSB22 = ',xmsb11,xmsb22
31632 WRITE(mstu(11),*) ' STOP22,SBOT22 = ',stop22,sbot22
31633 stop
31634 END
31635
31636C*********************************************************************
31637
31638C...PYRGHM
31639C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
31640
31641 SUBROUTINE pyrghm(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
31642 &XMHP,HMP,SA,CA,TANBA)
31643
31644C...Double precision and integer declarations.
31645 IMPLICIT DOUBLE PRECISION(a-h, o-z)
31646 IMPLICIT INTEGER(I-N)
31647 INTEGER PYK,PYCHGE,PYCOMP
31648 COMMON/PYHTRI/HHH(7)
31649
31650C...Local variables.
31651 dimension vh(2,2),xm2(2,2),xm2p(2,2)
31652
31653 xmz = 91.18d0
31654 alp1 = 0.0101d0
31655 alp2 = 0.0337d0
31656 alp3z = 0.12d0
31657 v = 174.1d0
31658 pi = 3.14159d0
31659 tanba = tanb
31660 tanbt = tanb
31661
31662C...MBOTTOM(XMT) = 3. GEV
31663 xmb = 3d0
31664 alp3 = alp3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alp3z*
31665 &log(xmt**2/xmz**2))
31666
31667C...RXMT= RUNNING TOP QUARK MASS
31668 rxmt = xmt/(1d0+4d0*alp3/3d0/pi)
31669 tq = log((xmq**2+xmt**2)/xmt**2)
31670 tu = log((xmur**2 + xmt**2)/xmt**2)
31671 td = log((xmdl**2 + xmt**2)/xmt**2)
31672 sinb = tanb/((1d0 + tanb**2)**0.5d0)
31673 cosb = sinb/tanb
31674 IF(xma.GT.xmt)
31675 &tanba = tanb*(1d0-3d0/32d0/pi**2*
31676 &(rxmt**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
31677 &log(xma**2/xmt**2))
31678 IF(xma.LT.xmt.OR.xma.EQ.xmt) tanbt = tanba
31679 sinb = tanbt/((1d0 + tanbt**2)**0.5d0)
31680 cosb = 1d0/((1d0 + tanbt**2)**0.5d0)
31681 cos2b = (tanbt**2 - 1d0)/(tanbt**2 + 1d0)
31682 g1 = (alp1*4d0*pi)**0.5d0
31683 g2 = (alp2*4d0*pi)**0.5d0
31684 g3 = (alp3*4d0*pi)**0.5d0
31685 hu = rxmt/v/sinb
31686 hd = xmb/v/cosb
31687
31688 CALL pygfxx(xma,tanba,xmq,xmur,xmdl,xmt,au,ad,
31689 &xmu,vh,stop1,stop2)
31690
31691 IF(xmq.GT.xmur) tp = tq - tu
31692 IF(xmq.LT.xmur.OR.xmq.EQ.xmur) tp = tu - tq
31693 IF(xmq.GT.xmur) tdp = tu
31694 IF(xmq.LT.xmur.OR.xmq.EQ.xmur) tdp = tq
31695 IF(xmq.GT.xmdl) tpd = tq - td
31696 IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) tpd = td - tq
31697 IF(xmq.GT.xmdl) tdpd = td
31698 IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) tdpd = tq
31699
31700 IF(xmq.GT.xmdl) dlam1 = 6d0/96d0/pi**2*g1**2*hd**2*tpd
31701 IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) dlam1 = 3d0/32d0/pi**2*
31702 &hd**2*(g1**2/3d0+g2**2)*tpd
31703
31704 IF(xmq.GT.xmur) dlam2 =12d0/96d0/pi**2*g1**2*hu**2*tp
31705 IF(xmq.LT.xmur.OR.xmq.EQ.xmur) dlam2 = 3d0/32d0/pi**2*
31706 &hu**2*(-g1**2/3d0+g2**2)*tp
31707
31708 dlam3 = 0d0
31709 dlam4 = 0d0
31710
31711 IF(xmq.GT.xmdl) dlam3 = -1d0/32d0/pi**2*g1**2*hd**2*tpd
31712 IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) dlam3 = 3d0/64d0/pi**2*hd**2*
31713 &(g2**2-g1**2/3d0)*tpd
31714
31715 IF(xmq.GT.xmur) dlam3 = dlam3 -
31716 &1d0/16d0/pi**2*g1**2*hu**2*tp
31717 IF(xmq.LT.xmur.OR.xmq.EQ.xmur) dlam3 = dlam3 +
31718 &3d0/64d0/pi**2*hu**2*(g2**2+g1**2/3d0)*tp
31719
31720 IF(xmq.LT.xmur) dlam4 = -3d0/32d0/pi**2*g2**2*hu**2*tp
31721 IF(xmq.LT.xmdl) dlam4 = dlam4 - 3d0/32d0/pi**2*g2**2*
31722 &hd**2*tpd
31723
31724 xlam1 = ((g1**2 + g2**2)/4d0)*
31725 &(1d0-3d0*hd**2*(tpd + tdpd)/8d0/pi**2)
31726 &+(3d0*hd**4/16d0/pi**2) *tpd*(1d0
31727 &+ (3d0*hd**2/2d0 + hu**2/2d0
31728 &- 8d0*g3**2) * (tpd + 2d0*tdpd)/16d0/pi**2)
31729 &+(3d0*hd**4/8d0/pi**2) *tdpd*(1d0 + (3d0*hd**2/2d0 + hu**2/2d0
31730 &- 8d0*g3**2) * tdpd/16d0/pi**2) + dlam1
31731 xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu**2*
31732 &(tp + tdp)/8d0/pi**2)
31733 &+(3d0*hu**4/16d0/pi**2) *tp*(1d0
31734 &+ (3d0*hu**2/2d0 + hd**2/2d0
31735 &- 8d0*g3**2) * (tp + 2d0*tdp)/16d0/pi**2)
31736 &+(3d0*hu**4/8d0/pi**2) *tdp*(1d0 + (3d0*hu**2/2d0 + hd**2/2d0
31737 &- 8d0*g3**2) * tdp/16d0/pi**2) + dlam2
31738 xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
31739 &(hu**2)*(tp + tdp)/16d0/pi**2 -3d0*
31740 &(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlam3
31741 xlam4 = (- g2**2/2d0)*(1d0
31742 &-3d0*(hu**2)*(tp + tdp)/16d0/pi**2
31743 &-3d0*(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlam4
31744
31745 xlam5 = 0d0
31746 xlam6 = 0d0
31747 xlam7 = 0d0
31748
31749C...Defined now in PYSUBH
31750C HHH(1)=XLAM1
31751C HHH(2)=XLAM2
31752C HHH(3)=XLAM3
31753C HHH(4)=XLAM4
31754C HHH(5)=XLAM5
31755C HHH(6)=XLAM6
31756C HHH(7)=XLAM7
31757
31758 xm2(1,1) = 2d0*v**2*(xlam1*cosb**2+2d0*xlam6*
31759 &cosb*sinb + xlam5*sinb**2) + xma**2*sinb**2
31760
31761 xm2(2,2) = 2d0*v**2*(xlam5*cosb**2+2d0*xlam7*
31762 &cosb*sinb + xlam2*sinb**2) + xma**2*cosb**2
31763 xm2(1,2) = 2d0*v**2*(xlam6*cosb**2+(xlam3+xlam4)*
31764 &cosb*sinb + xlam7*sinb**2) - xma**2*sinb*cosb
31765
31766 xm2(2,1) = xm2(1,2)
31767
31768CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31769C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
31770CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31771
31772 xmssu=(0.5d0*(xmq**2+xmur**2)+xmt**2)**0.5d0
31773
31774 IF(xmc.GT.xmssu) GOTO 100
31775 IF(xmc.LT.xmt) xmc=xmt
31776
31777 tchar=log(xmssu**2/xmc**2)
31778
31779 del12=(9d0/64d0/pi**2*g2**4+5d0/192d0/pi**2*g1**4)*tchar
31780 del3p4=(3d0/64d0/pi**2*g2**4+7d0/192d0/pi**2*g1**4
31781 &+4d0/32/pi**2*g1**2*g2**2)*tchar
31782
31783 dem112=2d0*del12*v**2*cosb**2
31784 dem222=2d0*del12*v**2*sinb**2
31785 dem122=2d0*del3p4*v**2*sinb*cosb
31786
31787 xm2(1,1)=xm2(1,1)+dem112
31788 xm2(2,2)=xm2(2,2)+dem222
31789 xm2(1,2)=xm2(1,2)+dem122
31790 xm2(2,1)=xm2(2,1)+dem122
31791
31792 100 CONTINUE
31793
31794CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31795C...END OF CHARGINOS/NEUTRALINOS
31796CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31797
31798 DO 120 i = 1,2
31799 DO 110 j = 1,2
31800 xm2p(i,j) = xm2(i,j) + vh(i,j)
31801 110 CONTINUE
31802 120 CONTINUE
31803
31804 trm2p = xm2p(1,1) + xm2p(2,2)
31805 detm2p = xm2p(1,1)*xm2p(2,2) - xm2p(1,2)*xm2p(2,1)
31806
31807 xmh2p = (trm2p - (trm2p**2 - 4d0* detm2p)**0.5d0)/2d0
31808 hm2p = (trm2p + (trm2p**2 - 4d0* detm2p)**0.5d0)/2d0
31809 hmp = hm2p**0.5d0
31810 IF(xmh2p.LT.0d0) GOTO 130
31811 xmhp = xmh2p**0.5d0
31812 s2alp = 2d0*xm2p(1,2)/(trm2p**2-4d0*detm2p)**0.5d0
31813 c2alp = (xm2p(1,1)-xm2p(2,2))/(trm2p**2-4d0*detm2p)**0.5d0
31814 IF(c2alp.GT.0d0) alp = asin(s2alp)/2d0
31815 IF(c2alp.LT.0d0) alp = -pi/2d0-asin(s2alp)/2d0
31816 sa = sin(alp)
31817 ca = cos(alp)
31818 sqbma = (sinb*ca - cosb*sa)**2
31819 130 xin = 1d0
31820 140 CONTINUE
31821
31822 RETURN
31823 END
31824
31825C*********************************************************************
31826
31827C...PYGFXX
31828C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
31829
31830 SUBROUTINE pygfxx(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
31831 &STOP1,STOP2)
31832
31833C...Double precision and integer declarations.
31834 IMPLICIT DOUBLE PRECISION(a-h, o-z)
31835 IMPLICIT INTEGER(I-N)
31836 INTEGER PYK,PYCHGE,PYCOMP
31837
31838C...Local variables.
31839 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
31840 &vh3t(2,2),vh3b(2,2),
31841 &hmix(2,2),al(2,2),xm2(2,2)
31842
31843C...Statement function.
31844 g(x,y) = 2d0 - (x+y)/(x-y)*log(x/y)
31845
31846 IF(dabs(xmu).LT.0.000001d0) xmu = 0.000001d0
31847 xmq2 = xmq**2
31848 xmur2 = xmur**2
31849 xmdl2 = xmdl**2
31850 tanba = tanb
31851 sinba = tanba/(tanba**2+1d0)**0.5d0
31852 cosba = sinba/tanba
31853
31854 sinb = tanb/(tanb**2+1d0)**0.5d0
31855 cosb = sinb/tanb
31856 pi = 3.14159d0
31857 g2 = (0.0336d0*4d0*pi)**0.5d0
31858 g12 = (0.0101d0*4d0*pi)
31859 g1 = g12**0.5d0
31860 xmz = 91.18d0
31861 v = 174.1d0
31862 mw = (g2**2*v**2/2d0)**0.5d0
31863 alp3 = 0.12d0/(1d0+23/12d0/pi*0.12d0*log(xmt**2/xmz**2))
31864
31865 xmb = 3d0
31866 IF(xmq.GT.xmur) xmst = xmq
31867 IF(xmur.GT.xmq.OR.xmur.EQ.xmq) xmst = xmur
31868
31869 xmsut = (xmst**2 + xmt**2)**0.5d0
31870
31871 IF(xmq.GT.xmdl) xmsb = xmq
31872 IF(xmdl.GT.xmq.OR.xmdl.EQ.xmq) xmsb = xmdl
31873
31874 xmsub = (xmsb**2 + xmb**2)**0.5d0
31875
31876 tt = log(xmsut**2/xmt**2)
31877 tb = log(xmsub**2/xmt**2)
31878
31879 rxmt = xmt/(1d0+4d0*alp3/3d0/pi)
31880 ht = rxmt/(174.1d0*sinb)
31881 htst = rxmt/174.1d0
31882 hb = xmb/174.1d0/cosb
31883 g32 = alp3*4d0*pi
31884 bt2 = -(8d0*g32 - 9d0*ht**2/2d0 - hb**2/2d0)/(4d0*pi)**2
31885 bb2 = -(8d0*g32 - 9d0*hb**2/2d0 - ht**2/2d0)/(4d0*pi)**2
31886 al2 = 3d0/8d0/pi**2*ht**2
31887 bt2st = -(8d0*g32 - 9d0*htst**2/2d0)/(4d0*pi)**2
31888 alst = 3d0/8d0/pi**2*htst**2
31889 al1 = 3d0/8d0/pi**2*hb**2
31890
31891 al(1,1) = al1
31892 al(1,2) = (al2+al1)/2d0
31893 al(2,1) = (al2+al1)/2d0
31894 al(2,2) = al2
31895
31896 xmt4 = rxmt**4*(1d0+2d0*bt2*tt- al2*tt)
31897 xmt2 = sqrt(xmt4)
31898 xmbot4 = xmb**4*(1d0+2d0*bb2*tb - al1*tb)
31899 xmbot2 = sqrt(xmbot4)
31900
31901 IF(xma.GT.xmt) THEN
31902 vi = 174.1d0*(1d0 + 3d0/32d0/pi**2*htst**2*
31903 & log(xmt**2/xma**2))
31904 h1i = vi* cosba
31905 h2i = vi*sinba
31906 h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xma**2/xmsut**2))**0.25d0
31907 h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xma**2/xmsut**2))**0.25d0
31908 h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xma**2/xmsub**2))**0.25d0
31909 h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xma**2/xmsub**2))**0.25d0
31910 ELSE
31911 vi = 174.1d0
31912 h1i = vi*cosb
31913 h2i = vi*sinb
31914 h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xmt**2/xmsut**2))**0.25d0
31915 h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xmt**2/xmsut**2))**0.25d0
31916 h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xmt**2/xmsub**2))**0.25d0
31917 h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xmt**2/xmsub**2))**0.25d0
31918 ENDIF
31919
31920 tanbst = h2t/h1t
31921 sinbt = tanbst/(1d0+tanbst**2)**0.5d0
31922 cosbt = sinbt/tanbst
31923
31924 tanbsb = h2b/h1b
31925 sinbb = tanbsb/(1d0+tanbsb**2)**0.5d0
31926 cosbb = sinbb/tanbsb
31927
31928 stop12 = (xmq2 + xmur2)*0.5d0 + xmt2
31929 &+1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
31930 &+(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
31931 &xmq2 - xmur2)**2*0.25d0 + xmt2*(at-xmu/tanbst)**2)**0.5d0
31932 stop22 = (xmq2 + xmur2)*0.5d0 + xmt2
31933 &+1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
31934 &- (((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
31935 &xmq2 - xmur2)**2*0.25d0
31936 &+ xmt2*(at-xmu/tanbst)**2)**0.5d0
31937 IF(stop22.LT.0d0) GOTO 120
31938 sbot12 = (xmq2 + xmdl2)*0.5d0
31939 &- 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
31940 &+ (((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
31941 &xmq2 - xmdl2)**2*0.25d0 + xmbot2*(ab-xmu*tanbsb)**2)**0.5d0
31942 sbot22 = (xmq2 + xmdl2)*0.5d0
31943 &- 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
31944 &- (((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
31945 &xmq2 - xmdl2)**2*0.25d0 + xmbot2*(ab-xmu*tanbsb)**2)**0.5d0
31946 IF(sbot22.LT.0d0) GOTO 120
31947
31948 stop1 = stop12**0.5d0
31949 stop2 = stop22**0.5d0
31950 sbot1 = sbot12**0.5d0
31951 sbot2 = sbot22**0.5d0
31952
31953 vh1(1,1) = 1d0/tanbst
31954 vh1(2,1) = -1d0
31955 vh1(1,2) = -1d0
31956 vh1(2,2) = tanbst
31957 vh2(1,1) = tanbst
31958 vh2(1,2) = -1d0
31959 vh2(2,1) = -1d0
31960 vh2(2,2) = 1d0/tanbst
31961
31962CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31963C...D-TERMS
31964CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31965 stw=0.2320d0
31966
31967 f1t=(xmq2-xmur2)/(stop12-stop22)*(0.5d0-4d0/3d0*stw)*
31968 &log(stop1/stop2)
31969 &+(0.5d0-2d0/3d0*stw)*log(stop1*stop2/(xmq2+xmt2))
31970 &+ 2d0/3d0*stw*log(stop1*stop2/(xmur2+xmt2))
31971
31972 f1b=(xmq2-xmdl2)/(sbot12-sbot22)*(-0.5d0+2d0/3d0*stw)*
31973 &log(sbot1/sbot2)
31974 &+(-0.5d0+1d0/3d0*stw)*log(sbot1*sbot2/(xmq2+xmbot2))
31975 &- 1d0/3d0*stw*log(sbot1*sbot2/(xmdl2+xmbot2))
31976
31977 f2t=xmt2**0.5d0*(at-xmu/tanbst)/(stop12-stop22)*
31978 &(-0.5d0*log(stop12/stop22)
31979 &+(4d0/3d0*stw-0.5d0)*(xmq2-xmur2)/(stop12-stop22)*
31980 &g(stop12,stop22))
31981
31982 f2b=xmbot2**0.5d0*(ab-xmu*tanbsb)/(sbot12-sbot22)*
31983 &(0.5d0*log(sbot12/sbot22)
31984 &+(-2d0/3d0*stw+0.5d0)*(xmq2-xmdl2)/(sbot12-sbot22)*
31985 &g(sbot12,sbot22))
31986
31987 vh3b(1,1) = xmbot4/(cosbb**2)*(log(sbot1**2*sbot2**2/
31988 &(xmq2+xmbot2)/(xmdl2+xmbot2))
31989 &+ 2d0*(ab*(ab-xmu*tanbsb)/(sbot1**2-sbot2**2))*
31990 &log(sbot1**2/sbot2**2)) +
31991 &xmbot4/(cosbb**2)*(ab*(ab-xmu*tanbsb)/
31992 &(sbot1**2-sbot2**2))**2*g(sbot12,sbot22)
31993
31994 vh3t(1,1) =
31995 &xmt4/(sinbt**2)*(xmu*(-at+xmu/tanbst)/(stop1**2
31996 &-stop2**2))**2*g(stop12,stop22)
31997
31998 vh3b(1,1)=vh3b(1,1)+
31999 &xmz**2*(2*xmbot2*f1b-xmbot2**0.5d0*ab*f2b)
32000
32001 vh3t(1,1) = vh3t(1,1) +
32002 &xmz**2*(xmt2**0.5d0*xmu/tanbst*f2t)
32003
32004 vh3t(2,2) = xmt4/(sinbt**2)*(log(stop1**2*stop2**2/
32005 &(xmq2+xmt2)/(xmur2+xmt2))
32006 &+ 2d0*(at*(at-xmu/tanbst)/(stop1**2-stop2**2))*
32007 &log(stop1**2/stop2**2)) +
32008 &xmt4/(sinbt**2)*(at*(at-xmu/tanbst)/
32009 &(stop1**2-stop2**2))**2*g(stop12,stop22)
32010
32011 vh3b(2,2) =
32012 &xmbot4/(cosbb**2)*(xmu*(-ab+xmu*tanbsb)/(sbot1**2
32013 &-sbot2**2))**2*g(sbot12,sbot22)
32014
32015 vh3t(2,2)=vh3t(2,2)+
32016 &xmz**2*(-2*xmt2*f1t+xmt2**0.5d0*at*f2t)
32017
32018 vh3b(2,2) = vh3b(2,2) -xmz**2*xmbot2**0.5d0*xmu*tanbsb*f2b
32019
32020 vh3t(1,2) = -
32021 &xmt4/(sinbt**2)*xmu*(at-xmu/tanbst)/
32022 &(stop1**2-stop2**2)*(log(stop1**2/stop2**2) + at*
32023 &(at - xmu/tanbst)/(stop1**2-stop2**2)*g(stop12,stop22))
32024
32025 vh3b(1,2) =
32026 &- xmbot4/(cosbb**2)*xmu*(at-xmu*tanbsb)/
32027 &(sbot1**2-sbot2**2)*(log(sbot1**2/sbot2**2) + ab*
32028 &(ab - xmu*tanbsb)/(sbot1**2-sbot2**2)*g(sbot12,sbot22))
32029
32030 vh3t(1,2)=vh3t(1,2) +
32031 &xmz**2*(xmt2/tanbst*f1t-xmt2**0.5d0*(at/tanbst+xmu)/2d0*f2t)
32032
32033 vh3b(1,2)=vh3b(1,2)
32034 &+xmz**2*(-xmbot2*tanbsb*f1b+xmbot2**0.5d0*(ab*tanbsb+xmu)/2d0*f2b)
32035
32036 vh3t(2,1) = vh3t(1,2)
32037 vh3b(2,1) = vh3b(1,2)
32038
32039 tq = log((xmq2 + xmt2)/xmt2)
32040 tu = log((xmur2+xmt2)/xmt2)
32041 tqd = log((xmq2 + xmb**2)/xmb**2)
32042 td = log((xmdl2+xmb**2)/xmb**2)
32043
32044 DO 110 i = 1,2
32045 DO 100 j = 1,2
32046
32047 vh(i,j) =
32048 & 6d0/(8d0*pi**2*(h1t**2+h2t**2))
32049 & *vh3t(i,j)*0.5d0*(1d0-al(i,j)*tt/2d0) +
32050 & 6d0/(8d0*pi**2*(h1b**2+h2b**2))
32051 & *vh3b(i,j)*0.5d0*(1d0-al(i,j)*tb/2d0)
32052
32053 100 CONTINUE
32054 110 CONTINUE
32055
32056 GOTO 150
32057 120 DO 140 i =1,2
32058 DO 130 j = 1,2
32059 vh(i,j) = -1d+15
32060 130 CONTINUE
32061 140 CONTINUE
32062
32063 150 CONTINUE
32064
32065 RETURN
32066 END
32067
32068C*********************************************************************
32069
32070C...PYFINT
32071C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
32072
32073 FUNCTION pyfint(A,B,C)
32074
32075C...Double precision and integer declarations.
32076 IMPLICIT DOUBLE PRECISION(a-h, o-z)
32077 IMPLICIT INTEGER(I-N)
32078 INTEGER PYK,PYCHGE,PYCOMP
32079C...Commonblock.
32080 common/pyints/xxm(20)
32081 SAVE/pyints/
32082
32083C...Local variables.
32084 EXTERNAL pyfisb
32085 DOUBLE PRECISION PYFISB
32086
32087 xxm(1)=a
32088 xxm(2)=b
32089 xxm(3)=c
32090 xlo=0d0
32091 xhi=1d0
32092 pyfint = pygaus(pyfisb,xlo,xhi,1d-3)
32093
32094 RETURN
32095 END
32096
32097C*********************************************************************
32098
32099C...PYFISB
32100C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
32101
32102 FUNCTION pyfisb(X)
32103
32104C...Double precision and integer declarations.
32105 IMPLICIT DOUBLE PRECISION(a-h, o-z)
32106 IMPLICIT INTEGER(I-N)
32107 INTEGER PYK,PYCHGE,PYCOMP
32108C...Commonblock.
32109 common/pyints/xxm(20)
32110 SAVE/pyints/
32111
32112 pyfisb = log(abs(x*xxm(2)+(1-x)*xxm(3)-x*(1-x)*xxm(1))/
32113 &(x*(xxm(2)-xxm(3))+xxm(3)))
32114
32115 RETURN
32116 END
32117
32118C*********************************************************************
32119
32120C...PYSFDC
32121C...Calculates decays of sfermions.
32122
32123 SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)
32124
32125C...Double precision and integer declarations.
32126 IMPLICIT DOUBLE PRECISION(a-h, o-z)
32127 IMPLICIT INTEGER(I-N)
32128 INTEGER PYK,PYCHGE,PYCOMP
32129C...Parameter statement to help give large particle numbers.
32130 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
32131C...Commonblocks.
32132 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
32133 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
32134 common/pymssm/imss(0:99),rmss(0:99)
32135 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
32136 &sfmix(16,4)
32137 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
32138
32139C...Local variables.
32140 INTEGER KFIN,KCIN
32141 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
32142 &XMZ2,AXMJ,AXMI
32143 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
32144 DOUBLE PRECISION PYLAMF,XL
32145 DOUBLE PRECISION TANW,XW,AEM,C1,AS
32146 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
32147 DOUBLE PRECISION CH1,CH2,CH3,CH4
32148 DOUBLE PRECISION XMBOT,XMTOP
32149 DOUBLE PRECISION XLAM(0:200)
32150 INTEGER IDLAM(200,3)
32151 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
32152 DOUBLE PRECISION SR2
32153 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
32154 DOUBLE PRECISION CW
32155 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
32156 DOUBLE PRECISION COSA,SINA,TANB
32157 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
32158 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
32159 INTEGER IG,KF1,KF2,ILR2,IDP
32160 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
32161 DATA igg/23,25,35,36/
32162 DATA pi/3.141592654d0/
32163 DATA sr2/1.4142136d0/
32164 DATA kfnchi/1000022,1000023,1000025,1000035/
32165 DATA kfcchi/1000024,1000037/
32166
32167C...COUNT THE NUMBER OF DECAY MODES
32168 lknt=0
32169
32170C...NO NU_R DECAYS
32171 IF(kfin.EQ.ksusy2+12.OR.kfin.EQ.ksusy2+14.OR.
32172 &kfin.EQ.ksusy2+16) RETURN
32173
32174 xmw=pmas(24,1)
32175 xmw2=xmw**2
32176 xmz=pmas(23,1)
32177 xmz2=xmz**2
32178 xw=paru(102)
32179 tanw = sqrt(xw/(1d0-xw))
32180 cw=sqrt(1d0-xw)
32181
32182C...KCIN
32183 kcin=pycomp(kfin)
32184C...ILR is 1 for left and 2 for right.
32185 ilr=kfin/ksusy1
32186C...IFL is matching non-SUSY flavour.
32187 ifl=mod(kfin,ksusy1)
32188C...IDU is weak isospin, 1 for down and 2 for up.
32189 idu=2-mod(ifl,2)
32190
32191 xmi=pmas(kcin,1)
32192 xmi2=xmi**2
32193 aem=pyalem(xmi2)
32194 as =pyalps(xmi2)
32195 c1=aem/xw
32196 xmi3=xmi**3
32197 ei=kchg(ifl,1)/3d0
32198
32199 xmbot=3d0
32200 xmtop=pyrnmt(pmas(6,1))
32201 xmbot=0d0
32202
32203 tanb=rmss(5)
32204 beta=atan(tanb)
32205 alfa=rmss(18)
32206 cbeta=cos(beta)
32207 sbeta=tanb*cbeta
32208 sina=sin(alfa)
32209 cosa=cos(alfa)
32210 xmu=-rmss(4)
32211 atrit=rmss(16)
32212 atrib=rmss(15)
32213 atril=rmss(17)
32214
32215C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
32216
32217 IF(imss(11).EQ.1) THEN
32218 xmp=rmss(29)
32219 idg=39+ksusy1
32220 xmgr=pmas(pycomp(idg),1)
32221 xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
32222 IF(ifl.EQ.5) THEN
32223 xmf=xmbot
32224 ELSEIF(ifl.EQ.6) THEN
32225 xmf=xmtop
32226 ELSE
32227 xmf=pmas(ifl,1)
32228 ENDIF
32229 IF(xmi.GT.xmgr+xmf) THEN
32230 lknt=lknt+1
32231 idlam(lknt,1)=idg
32232 idlam(lknt,2)=ifl
32233 idlam(lknt,3)=0
32234 xlam(lknt)=xfac*(1d0-xmf**2/xmi2)**4
32235 ENDIF
32236 ENDIF
32237
32238C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
32239
32240C...CHARGED DECAYS:
32241 DO 100 ix=1,2
32242C...DI -> U CHI1-,CHI2-
32243 IF(idu.EQ.1) THEN
32244 xmfp=pmas(ifl+1,1)
32245 xmf =pmas(ifl,1)
32246C...UI -> D CHI1+,CHI2+
32247 ELSE
32248 xmfp=pmas(ifl-1,1)
32249 xmf =pmas(ifl,1)
32250 ENDIF
32251 xmj=smw(ix)
32252 axmj=abs(xmj)
32253 IF(xmi.GE.axmj+xmfp) THEN
32254 xma2=xmj**2
32255 xmb2=xmfp**2
32256 IF(idu.EQ.2) THEN
32257 IF(ifl.EQ.6) THEN
32258 xmfp=xmbot
32259 xmf =xmtop
32260 ELSEIF(ifl.LT.6) THEN
32261 xmf=0d0
32262 xmfp=0d0
32263 ENDIF
32264 bl=vmix(ix,1)
32265 al=-xmfp*umix(ix,2)/sr2/xmw/cbeta
32266 br=-xmf*vmix(ix,2)/sr2/xmw/sbeta
32267 ar=0d0
32268 ELSE
32269 IF(ifl.EQ.5) THEN
32270 xmf =xmbot
32271 xmfp=xmtop
32272 ELSEIF(ifl.LT.5) THEN
32273 xmf=0d0
32274 xmfp=0d0
32275 ENDIF
32276 bl=umix(ix,1)
32277 al=-xmfp*vmix(ix,2)/sr2/xmw/sbeta
32278 br=-xmf*umix(ix,2)/sr2/xmw/cbeta
32279 ar=0d0
32280 ENDIF
32281
32282 alp=sfmix(ifl,1)*al + sfmix(ifl,2)*ar
32283 blp=sfmix(ifl,1)*bl + sfmix(ifl,2)*br
32284 arp=sfmix(ifl,4)*ar + sfmix(ifl,3)*al
32285 brp=sfmix(ifl,4)*br + sfmix(ifl,3)*bl
32286 al=alp
32287 bl=blp
32288 ar=arp
32289 br=brp
32290
32291C...F1 -> F` CHI
32292 IF(ilr.EQ.1) THEN
32293 ca=al
32294 cb=bl
32295C...F2 -> F` CHI
32296 ELSE
32297 ca=ar
32298 cb=br
32299 ENDIF
32300 lknt=lknt+1
32301 xl=pylamf(xmi2,xma2,xmb2)
32302C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
32303 xlam(lknt)=2d0*c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
32304 & (ca**2+cb**2)-4d0*ca*cb*xmj*xmfp)
32305 idlam(lknt,3)=0
32306 IF(idu.EQ.1) THEN
32307 idlam(lknt,1)=-kfcchi(ix)
32308 idlam(lknt,2)=ifl+1
32309 ELSE
32310 idlam(lknt,1)=kfcchi(ix)
32311 idlam(lknt,2)=ifl-1
32312 ENDIF
32313 ENDIF
32314 100 CONTINUE
32315
32316C...NEUTRAL DECAYS
32317 DO 110 ix=1,4
32318C...DI -> D CHI10
32319 xmf=pmas(ifl,1)
32320 xmj=smz(ix)
32321 axmj=abs(xmj)
32322 IF(xmi.GE.axmj+xmf) THEN
32323 xma2=xmj**2
32324 xmb2=xmf**2
32325 IF(idu.EQ.1) THEN
32326 IF(ifl.EQ.5) THEN
32327 xmf=xmbot
32328 ELSEIF(ifl.LT.5) THEN
32329 xmf=0d0
32330 ENDIF
32331 bl=-zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei+1)
32332 al=xmf*zmix(ix,3)/xmw/cbeta
32333 ar=-2d0*ei*tanw*zmix(ix,1)
32334 br=al
32335 ELSE
32336 IF(ifl.EQ.6) THEN
32337 xmf=xmtop
32338 ELSEIF(ifl.LT.5) THEN
32339 xmf=0d0
32340 ENDIF
32341 bl=zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-1)
32342 al=xmf*zmix(ix,4)/xmw/sbeta
32343 ar=-2d0*ei*tanw*zmix(ix,1)
32344 br=al
32345 ENDIF
32346
32347 alp=sfmix(ifl,1)*al + sfmix(ifl,2)*ar
32348 blp=sfmix(ifl,1)*bl + sfmix(ifl,2)*br
32349 arp=sfmix(ifl,4)*ar + sfmix(ifl,3)*al
32350 brp=sfmix(ifl,4)*br + sfmix(ifl,3)*bl
32351 al=alp
32352 bl=blp
32353 ar=arp
32354 br=brp
32355
32356C...F1 -> F CHI
32357 IF(ilr.EQ.1) THEN
32358 ca=al
32359 cb=bl
32360C...F2 -> F CHI
32361 ELSE
32362 ca=ar
32363 cb=br
32364 ENDIF
32365 lknt=lknt+1
32366 xl=pylamf(xmi2,xma2,xmb2)
32367C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
32368 xlam(lknt)=c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
32369 & (ca**2+cb**2)-4d0*ca*cb*xmj*xmf)
32370 idlam(lknt,1)=kfnchi(ix)
32371 idlam(lknt,2)=ifl
32372 idlam(lknt,3)=0
32373 ENDIF
32374 110 CONTINUE
32375
32376C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
32377C...IG=23,25,35,36
32378 DO 120 ii=1,4
32379 ig=igg(ii)
32380 IF(ilr.EQ.1) GOTO 120
32381 xmb=pmas(ig,1)
32382 xmsf1=pmas(pycomp(kfin-ksusy1),1)
32383 IF(xmi.LT.xmsf1+xmb) GOTO 120
32384 IF(ig.EQ.23) THEN
32385 bl=-sign(.5d0,ei)/cw+ei*xw/cw
32386 br=ei*xw/cw
32387 blr=0d0
32388 ELSEIF(ig.EQ.25) THEN
32389 IF(ifl.EQ.5) THEN
32390 xmf=xmbot
32391 ELSEIF(ifl.EQ.6) THEN
32392 xmf=xmtop
32393 ELSEIF(ifl.LT.5) THEN
32394 xmf=0d0
32395 ELSE
32396 xmf=pmas(ifl,1)
32397 ENDIF
32398 IF(idu.EQ.2) THEN
32399 ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
32400 & xmf**2/xmw*cosa/sbeta
32401 ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
32402 & xmf**2/xmw*cosa/sbeta
32403 ELSE
32404 ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
32405 & xmf**2/xmw*(-sina)/cbeta
32406 ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
32407 & xmf**2/xmw*(-sina)/cbeta
32408 ENDIF
32409 IF(ifl.EQ.5) THEN
32410 at=atrib
32411 ELSEIF(ifl.EQ.6) THEN
32412 at=atrit
32413 ELSEIF(ifl.EQ.15) THEN
32414 at=atril
32415 ELSE
32416 at=0d0
32417 ENDIF
32418 IF(idu.EQ.2) THEN
32419 ghlr=xmf/2d0/xmw/sbeta*(-xmu*sina+
32420 & at*cosa)
32421 ELSE
32422 ghlr=xmf/2d0/xmw/cbeta*(xmu*cosa-
32423 & at*sina)
32424 ENDIF
32425 bl=ghll
32426 br=ghrr
32427 blr=-ghlr
32428 ELSEIF(ig.EQ.35) THEN
32429 IF(ifl.EQ.5) THEN
32430 xmf=xmbot
32431 ELSEIF(ifl.EQ.6) THEN
32432 xmf=xmtop
32433 ELSEIF(ifl.LT.5) THEN
32434 xmf=0d0
32435 ELSE
32436 xmf=pmas(ifl,1)
32437 ENDIF
32438 IF(idu.EQ.2) THEN
32439 ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
32440 & xmf**2/xmw*sina/sbeta
32441 ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
32442 & xmf**2/xmw*sina/sbeta
32443 ELSE
32444 ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
32445 & xmf**2/xmw*cosa/cbeta
32446 ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
32447 & xmf**2/xmw*cosa/cbeta
32448 ENDIF
32449 IF(ifl.EQ.5) THEN
32450 at=atrib
32451 ELSEIF(ifl.EQ.6) THEN
32452 at=atrit
32453 ELSEIF(ifl.EQ.15) THEN
32454 at=atril
32455 ELSE
32456 at=0d0
32457 ENDIF
32458 IF(idu.EQ.2) THEN
32459 ghlr=xmf/2d0/xmw/sbeta*(xmu*cosa+
32460 & at*sina)
32461 ELSE
32462 ghlr=xmf/2d0/xmw/cbeta*(xmu*sina+
32463 & at*cosa)
32464 ENDIF
32465 bl=ghll
32466 br=ghrr
32467 blr=ghlr
32468 ELSEIF(ig.EQ.36) THEN
32469 ghll=0d0
32470 ghrr=0d0
32471 IF(ifl.EQ.5) THEN
32472 xmf=xmbot
32473 ELSEIF(ifl.EQ.6) THEN
32474 xmf=xmtop
32475 ELSEIF(ifl.LT.5) THEN
32476 xmf=0d0
32477 ELSE
32478 xmf=pmas(ifl,1)
32479 ENDIF
32480 IF(ifl.EQ.5) THEN
32481 at=atrib
32482 ELSEIF(ifl.EQ.6) THEN
32483 at=atrit
32484 ELSEIF(ifl.EQ.15) THEN
32485 at=atril
32486 ELSE
32487 at=0d0
32488 ENDIF
32489 IF(idu.EQ.2) THEN
32490 ghlr=xmf/2d0/xmw*(-xmu+at/tanb)
32491 ELSE
32492 ghlr=xmf/2d0/xmw/(-xmu+at*tanb)
32493 ENDIF
32494 bl=ghll
32495 br=ghrr
32496 blr=ghlr
32497 ENDIF
32498 al=sfmix(ifl,1)*sfmix(ifl,3)*bl+
32499 & sfmix(ifl,2)*sfmix(ifl,4)*br+
32500 & (sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,3)*sfmix(ifl,2))*blr
32501 xl=pylamf(xmi2,xmsf1**2,xmb**2)
32502 lknt=lknt+1
32503 IF(ig.EQ.23) THEN
32504 xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
32505 ELSE
32506 xlam(lknt)=c1/4d0/xmi3*sqrt(xl)*al**2
32507 ENDIF
32508 idlam(lknt,3)=0
32509 idlam(lknt,1)=kfin-ksusy1
32510 idlam(lknt,2)=ig
32511 120 CONTINUE
32512
32513C...SF -> SF' + W
32514 xmb=pmas(24,1)
32515 IF(mod(ifl,2).EQ.0) THEN
32516 kf1=ksusy1+ifl-1
32517 ELSE
32518 kf1=ksusy1+ifl+1
32519 ENDIF
32520 kf2=kf1+ksusy1
32521 xmsf1=pmas(pycomp(kf1),1)
32522 xmsf2=pmas(pycomp(kf2),1)
32523 IF(xmi.GT.xmb+xmsf1) THEN
32524 IF(mod(ifl,2).EQ.0) THEN
32525 IF(ilr.EQ.1) THEN
32526 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,1)
32527 ELSE
32528 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,1)
32529 ENDIF
32530 ELSE
32531 IF(ilr.EQ.1) THEN
32532 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,1)
32533 ELSE
32534 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,1)
32535 ENDIF
32536 ENDIF
32537 xl=pylamf(xmi2,xmsf1**2,xmb**2)
32538 lknt=lknt+1
32539 xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
32540 idlam(lknt,3)=0
32541 idlam(lknt,1)=kf1
32542 idlam(lknt,2)=sign(24,kchg(ifl,1))
32543 ENDIF
32544 IF(xmi.GT.xmb+xmsf2) THEN
32545 IF(mod(ifl,2).EQ.0) THEN
32546 IF(ilr.EQ.1) THEN
32547 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,3)
32548 ELSE
32549 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,3)
32550 ENDIF
32551 ELSE
32552 IF(ilr.EQ.1) THEN
32553 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,3)
32554 ELSE
32555 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,3)
32556 ENDIF
32557 ENDIF
32558 xl=pylamf(xmi2,xmsf2**2,xmb**2)
32559 lknt=lknt+1
32560 xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
32561 idlam(lknt,3)=0
32562 idlam(lknt,1)=kf2
32563 idlam(lknt,2)=sign(24,kchg(ifl,1))
32564 ENDIF
32565
32566C...SF -> SF' + HC
32567 xmb=pmas(37,1)
32568 IF(mod(ifl,2).EQ.0) THEN
32569 kf1=ksusy1+ifl-1
32570 ELSE
32571 kf1=ksusy1+ifl+1
32572 ENDIF
32573 kf2=kf1+ksusy1
32574 xmsf1=pmas(pycomp(kf1),1)
32575 xmsf2=pmas(pycomp(kf2),1)
32576 IF(xmi.GT.xmb+xmsf1) THEN
32577 xmf=0d0
32578 xmfp=0d0
32579 at=0d0
32580 ab=0d0
32581 IF(mod(ifl,2).EQ.0) THEN
32582C...T1-> B1 HC
32583 IF(ilr.EQ.1) THEN
32584 ch1=-sfmix(ifl,1)*sfmix(ifl-1,1)
32585 ch2= sfmix(ifl,2)*sfmix(ifl-1,2)
32586 ch3=-sfmix(ifl,1)*sfmix(ifl-1,2)
32587 ch4=-sfmix(ifl,2)*sfmix(ifl-1,1)
32588C...T2-> B1 HC
32589 ELSE
32590 ch1= sfmix(ifl,3)*sfmix(ifl-1,1)
32591 ch2=-sfmix(ifl,4)*sfmix(ifl-1,2)
32592 ch3= sfmix(ifl,3)*sfmix(ifl-1,2)
32593 ch4= sfmix(ifl,4)*sfmix(ifl-1,1)
32594 ENDIF
32595 IF(ifl.EQ.6) THEN
32596 xmf=xmtop
32597 xmfp=xmbot
32598 at=atrit
32599 ab=atrib
32600 ENDIF
32601 ELSE
32602C...B1 -> T1 HC
32603 IF(ilr.EQ.1) THEN
32604 ch1=-sfmix(ifl+1,1)*sfmix(ifl,1)
32605 ch2= sfmix(ifl+1,2)*sfmix(ifl,2)
32606 ch3=-sfmix(ifl+1,1)*sfmix(ifl,2)
32607 ch4=-sfmix(ifl+1,2)*sfmix(ifl,1)
32608C...B2-> T1 HC
32609 ELSE
32610 ch1= sfmix(ifl,3)*sfmix(ifl+1,1)
32611 ch2=-sfmix(ifl,4)*sfmix(ifl+1,2)
32612 ch3= sfmix(ifl,4)*sfmix(ifl+1,1)
32613 ch4= sfmix(ifl,3)*sfmix(ifl+1,2)
32614 ENDIF
32615 IF(ifl.EQ.5) THEN
32616 xmf=xmtop
32617 xmfp=xmbot
32618 at=atrit
32619 ab=atrib
32620 ENDIF
32621 ENDIF
32622 xl=pylamf(xmi2,xmsf1**2,xmb**2)
32623 lknt=lknt+1
32624 al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
32625 & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
32626 & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
32627 xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
32628 idlam(lknt,3)=0
32629 idlam(lknt,1)=kf1
32630 idlam(lknt,2)=sign(37,kchg(ifl,1))
32631 ENDIF
32632 IF(xmi.GT.xmb+xmsf2) THEN
32633 xmf=0d0
32634 xmfp=0d0
32635 at=0d0
32636 ab=0d0
32637 IF(mod(ifl,2).EQ.0) THEN
32638C...T1-> B2 HC
32639 IF(ilr.EQ.1) THEN
32640 ch1= sfmix(ifl-1,3)*sfmix(ifl,1)
32641 ch2=-sfmix(ifl-1,4)*sfmix(ifl,2)
32642 ch3= sfmix(ifl-1,4)*sfmix(ifl,1)
32643 ch4= sfmix(ifl-1,3)*sfmix(ifl,2)
32644C...T2-> B2 HC
32645 ELSE
32646 ch1= -sfmix(ifl,3)*sfmix(ifl-1,3)
32647 ch2= sfmix(ifl,4)*sfmix(ifl-1,4)
32648 ch3= -sfmix(ifl,3)*sfmix(ifl-1,4)
32649 ch4= -sfmix(ifl,4)*sfmix(ifl-1,3)
32650 ENDIF
32651 IF(ifl.EQ.6) THEN
32652 xmf=xmtop
32653 xmfp=xmbot
32654 at=atrit
32655 ab=atrib
32656 ENDIF
32657 ELSE
32658C...B1 -> T2 HC
32659 IF(ilr.EQ.1) THEN
32660 ch1= sfmix(ifl+1,3)*sfmix(ifl,1)
32661 ch2=-sfmix(ifl+1,4)*sfmix(ifl,2)
32662 ch3= sfmix(ifl+1,3)*sfmix(ifl,2)
32663 ch4= sfmix(ifl+1,4)*sfmix(ifl,1)
32664C...B2-> T2 HC
32665 ELSE
32666 ch1= -sfmix(ifl+1,3)*sfmix(ifl,3)
32667 ch2= sfmix(ifl+1,4)*sfmix(ifl,4)
32668 ch3= -sfmix(ifl+1,3)*sfmix(ifl,4)
32669 ch4= -sfmix(ifl+1,4)*sfmix(ifl,3)
32670 ENDIF
32671 IF(ifl.EQ.5) THEN
32672 xmf=xmtop
32673 xmfp=xmbot
32674 at=atrit
32675 ab=atrib
32676 ENDIF
32677 ENDIF
32678 xl=pylamf(xmi2,xmsf1**2,xmb**2)
32679 lknt=lknt+1
32680 al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
32681 & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
32682 & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
32683 xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
32684 idlam(lknt,3)=0
32685 idlam(lknt,1)=kf2
32686 idlam(lknt,2)=sign(37,kchg(ifl,1))
32687 ENDIF
32688
32689C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
32690
32691 IF(ifl.LE.6) THEN
32692 xmfp=0d0
32693 xmf=0d0
32694 IF(ifl.EQ.6) xmf=pmas(6,1)
32695 IF(ifl.EQ.5) xmf=pmas(5,1)
32696 xmj=pmas(pycomp(ksusy1+21),1)
32697 axmj=abs(xmj)
32698 IF(xmi.GE.axmj+xmf) THEN
32699 al=-sfmix(ifl,3)
32700 bl=sfmix(ifl,1)
32701 ar=-sfmix(ifl,4)
32702 br=sfmix(ifl,2)
32703C...F1 -> F CHI
32704 IF(ilr.EQ.1) THEN
32705 ca=al
32706 cb=bl
32707C...F2 -> F CHI
32708 ELSE
32709 ca=ar
32710 cb=br
32711 ENDIF
32712 lknt=lknt+1
32713 xma2=xmj**2
32714 xmb2=xmf**2
32715 xl=pylamf(xmi2,xma2,xmb2)
32716 xlam(lknt)=4d0/3d0*as/2d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
32717 & (ca**2+cb**2)+4d0*ca*cb*xmj*xmf)
32718 idlam(lknt,1)=ksusy1+21
32719 idlam(lknt,2)=ifl
32720 idlam(lknt,3)=0
32721 ENDIF
32722 ENDIF
32723
32724C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
32725 IF(kfin.EQ.ksusy1+6.AND.pmas(kcin,1).GT.
32726 &pmas(pycomp(ksusy1+22),1)+pmas(4,1)) THEN
32727C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
32728C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
32729C...M*M = C1**2 * G**2/(16PI**2)
32730C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
32731 lknt=lknt+1
32732 xl=pylamf(xmi2,0d0,pmas(pycomp(ksusy1+22),1)**2)
32733 xlam(lknt)=c1**3/64d0/pi**2/xmi3*sqrt(xl)
32734 IF(xlam(lknt).EQ.0) xlam(lknt)=1d-3
32735 idlam(lknt,1)=ksusy1+22
32736 idlam(lknt,2)=4
32737 idlam(lknt,3)=0
32738 ENDIF
32739
32740 iknt=lknt
32741 xlam(0)=0d0
32742 DO 130 i=1,iknt
32743 IF(xlam(i).LT.0d0) xlam(i)=0d0
32744 xlam(0)=xlam(0)+xlam(i)
32745 130 CONTINUE
32746 IF(xlam(0).EQ.0d0) xlam(0)=1d-3
32747
32748 RETURN
32749 END
32750
32751C*********************************************************************
32752
32753C...PYGLUI
32754C...Calculates gluino decay modes.
32755
32756 SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)
32757
32758C...Double precision and integer declarations.
32759 IMPLICIT DOUBLE PRECISION(a-h, o-z)
32760 IMPLICIT INTEGER(I-N)
32761 INTEGER PYK,PYCHGE,PYCOMP
32762C...Parameter statement to help give large particle numbers.
32763 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
32764C...Commonblocks.
32765 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
32766 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
32767 common/pymssm/imss(0:99),rmss(0:99)
32768 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
32769 &sfmix(16,4)
32770 common/pyints/xxm(20)
32771 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/
32772
32773C...Local variables.
32774 INTEGER KFIN,KCIN,KF
32775 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
32776 &xmz,xmz2,axmj,axmi
32777 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
32778 DOUBLE PRECISION C1L,C1R,D1L,D1R
32779 DOUBLE PRECISION C2L,C2R,D2L,D2R
32780 DOUBLE PRECISION PYLAMF,XL
32781 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
32782 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
32783 DOUBLE PRECISION ALFA,BETA
32784 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
32785 DOUBLE PRECISION XLAM(0:200)
32786 INTEGER IDLAM(200,3)
32787 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
32788 DOUBLE PRECISION SR2
32789 DOUBLE PRECISION GAM
32790 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
32791 EXTERNAL pygaus,pyxxz5,pyxxw5,pyxxz2
32792 DOUBLE PRECISION PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
32793 DOUBLE PRECISION PREC
32794 INTEGER KFNCHI(4),KFCCHI(2)
32795 DATA pi/3.141592654d0/
32796 DATA sr2/1.4142136d0/
32797 DATA prec/1d-2/
32798 DATA kfnchi/1000022,1000023,1000025,1000035/
32799 DATA kfcchi/1000024,1000037/
32800
32801C...COUNT THE NUMBER OF DECAY MODES
32802 lknt=0
32803 IF(kfin.NE.ksusy1+21) RETURN
32804 kcin=pycomp(kfin)
32805
32806 xmw=pmas(24,1)
32807 xmw2=xmw**2
32808 xmz=pmas(23,1)
32809 xmz2=xmz**2
32810 xw=paru(102)
32811 tanw = sqrt(xw/(1d0-xw))
32812
32813 xmi=pmas(kcin,1)
32814 axmi=abs(xmi)
32815 xmi2=xmi**2
32816 aem=pyalem(xmi2)
32817 as =pyalps(xmi2)
32818 c1=aem/xw
32819 xmi3=xmi**3
32820 beta=atan(rmss(5))
32821
32822C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
32823
32824 IF(imss(11).EQ.1) THEN
32825 xmp=rmss(29)
32826 idg=39+ksusy1
32827 xmgr=pmas(pycomp(idg),1)
32828 xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
32829 IF(axmi.GT.xmgr) THEN
32830 lknt=lknt+1
32831 idlam(lknt,1)=idg
32832 idlam(lknt,2)=21
32833 idlam(lknt,3)=0
32834 xlam(lknt)=xfac
32835 ENDIF
32836 ENDIF
32837
32838C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
32839
32840 DO 110 ifl=1,6
32841 DO 100 ilr=1,2
32842 xmj=pmas(pycomp(ilr*ksusy1+ifl),1)
32843 axmj=abs(xmj)
32844 xmf=pmas(ifl,1)
32845 idu=3-(1+mod(ifl,2))
32846 IF(xmi.GE.axmj+xmf) THEN
32847C...Minus sign difference from gluino-quark-squark feynman rules
32848 al=sfmix(ifl,1)
32849 bl=-sfmix(ifl,3)
32850 ar=sfmix(ifl,2)
32851 br=-sfmix(ifl,4)
32852C...F1 -> F CHI
32853 IF(ilr.EQ.1) THEN
32854 ca=al
32855 cb=bl
32856C...F2 -> F CHI
32857 ELSE
32858 ca=ar
32859 cb=br
32860 ENDIF
32861 lknt=lknt+1
32862 xma2=xmj**2
32863 xmb2=xmf**2
32864 xl=pylamf(xmi2,xma2,xmb2)
32865 xlam(lknt)=4d0/8d0*as/4d0/xmi3*sqrt(xl)*((xmi2+xmb2-xma2)*
32866 & (ca**2+cb**2)-4d0*ca*cb*xmi*xmf)
32867 idlam(lknt,1)=ilr*ksusy1+ifl
32868 idlam(lknt,2)=-ifl
32869 idlam(lknt,3)=0
32870 lknt=lknt+1
32871 xlam(lknt)=xlam(lknt-1)
32872 idlam(lknt,1)=-idlam(lknt-1,1)
32873 idlam(lknt,2)=-idlam(lknt-1,2)
32874 idlam(lknt,3)=0
32875 ENDIF
32876 100 CONTINUE
32877 110 CONTINUE
32878
32879C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
32880C...GLUINO -> NI Q QBAR
32881 DO 160 ix=1,4
32882 xmj=smz(ix)
32883 axmj=abs(xmj)
32884 IF(xmi.GE.axmj) THEN
32885 xxm(1)=0d0
32886 xxm(2)=xmj
32887 xxm(3)=0d0
32888 xxm(4)=xmi
32889 xxm(5)=pmas(pycomp(ksusy1+1),1)
32890 xxm(6)=pmas(pycomp(ksusy2+1),1)
32891 xxm(7)=1d6
32892 xxm(8)=0d0
32893 xxm(9)=0d0
32894 xxm(10)=0d0
32895 s12min=0d0
32896 s12max=(xmi-axmj)**2
32897C...D-TYPE QUARKS
32898 xxm(11)=0d0
32899 xxm(12)=0d0
32900 xxm(13)=1d0
32901 xxm(14)=-sr2*(-0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
32902 xxm(15)=1d0
32903 xxm(16)=sr2*(-tanw*zmix(ix,1)/3d0)
32904 IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) GOTO 120
32905 IF(xmi.GE.axmj+2d0*pmas(1,1)) THEN
32906 lknt=lknt+1
32907 xlam(lknt)=c1*as/xmi3/(16d0*pi)*
32908 & pygaus(pyxxz5,s12min,s12max,1d-2)
32909 idlam(lknt,1)=kfnchi(ix)
32910 idlam(lknt,2)=1
32911 idlam(lknt,3)=-1
32912 ENDIF
32913 IF(xmi.GE.axmj+2d0*pmas(3,1)) THEN
32914 lknt=lknt+1
32915 xlam(lknt)=xlam(lknt-1)
32916 idlam(lknt,1)=kfnchi(ix)
32917 idlam(lknt,2)=3
32918 idlam(lknt,3)=-3
32919 ENDIF
32920 120 CONTINUE
32921 IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) GOTO 130
32922 IF(xmi.GE.axmj+2d0*pmas(5,1)) THEN
32923 CALL pytbbn(ix,80,-1d0/3d0,axmi,gam)
32924 lknt=lknt+1
32925 xlam(lknt)=gam
32926 idlam(lknt,1)=kfnchi(ix)
32927 idlam(lknt,2)=5
32928 idlam(lknt,3)=-5
32929 ENDIF
32930C...U-TYPE QUARKS
32931 130 CONTINUE
32932 xxm(5)=pmas(pycomp(ksusy1+2),1)
32933 xxm(6)=pmas(pycomp(ksusy2+2),1)
32934 xxm(13)=1d0
32935 xxm(14)=-sr2*(0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
32936 xxm(15)=1d0
32937 xxm(16)=sr2*(2d0*tanw*zmix(ix,1)/3d0)
32938 IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) GOTO 140
32939 IF(xmi.GE.axmj+2d0*pmas(2,1)) THEN
32940 lknt=lknt+1
32941 xlam(lknt)=c1*as/xmi3/(16d0*pi)*
32942 & pygaus(pyxxz5,s12min,s12max,1d-2)
32943 idlam(lknt,1)=kfnchi(ix)
32944 idlam(lknt,2)=2
32945 idlam(lknt,3)=-2
32946 ENDIF
32947 IF(xmi.GE.axmj+2d0*pmas(4,1)) THEN
32948 lknt=lknt+1
32949 xlam(lknt)=xlam(lknt-1)
32950 idlam(lknt,1)=kfnchi(ix)
32951 idlam(lknt,2)=4
32952 idlam(lknt,3)=-4
32953 ENDIF
32954 140 CONTINUE
32955C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
32956C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
32957 IF(xmi.GE.pmas(pycomp(ksusy1+6),1)+pmas(6,1)) GOTO 150
32958 xmf=pmas(6,1)
32959 IF(xmi.GE.axmj+2d0*xmf) THEN
32960 CALL pytbbn(ix,80,2d0/3d0,axmi,gam)
32961 lknt=lknt+1
32962 xlam(lknt)=gam
32963 idlam(lknt,1)=kfnchi(ix)
32964 idlam(lknt,2)=6
32965 idlam(lknt,3)=-6
32966 ENDIF
32967 150 CONTINUE
32968 ENDIF
32969 160 CONTINUE
32970
32971C...GLUINO -> CI Q QBAR'
32972 DO 190 ix=1,2
32973 xmj=smw(ix)
32974 axmj=abs(xmj)
32975 IF(xmi.GE.axmj) THEN
32976 s12min=0d0
32977 s12max=(axmi-axmj)**2
32978 xxm(1)=0d0
32979 xxm(2)=xmj
32980 xxm(3)=0d0
32981 xxm(4)=xmi
32982 xxm(5)=0d0
32983 xxm(6)=0d0
32984 xxm(9)=1d6
32985 xxm(10)=0d0
32986 xxm(7)=umix(ix,1)*sr2
32987 xxm(8)=vmix(ix,1)*sr2
32988 xxm(11)=pmas(pycomp(ksusy1+1),1)
32989 xxm(12)=pmas(pycomp(ksusy1+2),1)
32990 IF( xxm(11).LT.axmi .OR. xxm(12).LT.axmi ) GOTO 170
32991 IF(xmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
32992 lknt=lknt+1
32993 xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
32994 & pygaus(pyxxw5,s12min,s12max,prec)
32995 idlam(lknt,1)=kfcchi(ix)
32996 idlam(lknt,2)=1
32997 idlam(lknt,3)=-2
32998 lknt=lknt+1
32999 xlam(lknt)=xlam(lknt-1)
33000 idlam(lknt,1)=-idlam(lknt-1,1)
33001 idlam(lknt,2)=-idlam(lknt-1,2)
33002 idlam(lknt,3)=-idlam(lknt-1,3)
33003 ENDIF
33004 IF(xmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
33005 lknt=lknt+1
33006 xlam(lknt)=xlam(lknt-1)
33007 idlam(lknt,1)=kfcchi(ix)
33008 idlam(lknt,2)=3
33009 idlam(lknt,3)=-4
33010 lknt=lknt+1
33011 xlam(lknt)=xlam(lknt-1)
33012 idlam(lknt,1)=-idlam(lknt-1,1)
33013 idlam(lknt,2)=-idlam(lknt-1,2)
33014 idlam(lknt,3)=-idlam(lknt-1,3)
33015 ENDIF
33016 170 CONTINUE
33017
33018 IF(xmi.GE.pmas(pycomp(ksusy1+5),1)+pmas(5,1)) GOTO 180
33019 IF(xmi.GE.pmas(pycomp(ksusy1+6),1)+pmas(6,1)) GOTO 180
33020 xmf=pmas(6,1)
33021 xmfp=pmas(5,1)
33022 IF(xmi.GE.axmj+xmf+xmfp) THEN
33023 CALL pytbbc(ix,80,axmi,gam)
33024 lknt=lknt+1
33025 xlam(lknt)=gam
33026 idlam(lknt,1)=kfcchi(ix)
33027 idlam(lknt,2)=5
33028 idlam(lknt,3)=-6
33029 lknt=lknt+1
33030 xlam(lknt)=xlam(lknt-1)
33031 idlam(lknt,1)=-idlam(lknt-1,1)
33032 idlam(lknt,2)=-idlam(lknt-1,2)
33033 idlam(lknt,3)=-idlam(lknt-1,3)
33034 ENDIF
33035 180 CONTINUE
33036 ENDIF
33037 190 CONTINUE
33038
33039 iknt=lknt
33040 xlam(0)=0d0
33041 DO 200 i=1,iknt
33042 IF(xlam(i).LT.0d0) xlam(i)=0d0
33043 xlam(0)=xlam(0)+xlam(i)
33044 200 CONTINUE
33045 IF(xlam(0).EQ.0d0) xlam(0)=1d-6
33046
33047 RETURN
33048 END
33049
33050C*********************************************************************
33051
33052C...PYTECM
33053C...Finds the s-hat dependent eigenvalues of the inverse propagator
33054C...matrix for gamma, Z, technirho, and techniomega to optimize the
33055C...phase space generation.
33056
33057 SUBROUTINE pytecm(S1,S2)
33058
33059C...Double precision and integer declarations.
33060 IMPLICIT DOUBLE PRECISION(a-h, o-z)
33061 IMPLICIT INTEGER(I-N)
33062 INTEGER PYK,PYCHGE,PYCOMP
33063C...Parameter statement to help give large particle numbers.
33064 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
33065C...Commonblocks.
33066 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
33067 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
33068 common/pypars/mstp(200),parp(200),msti(200),pari(200)
33069 SAVE /pydat1/,/pydat2/,/pypars/
33070
33071C...Local variables.
33072 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
33073 &at(4,4),wi(4),fv1(4),fv2(4),fv3(4),sh,aem,tanw,ct2w,qupd,alprht,
33074 &far,fao,fzr,fzo,shr,r1,r2,s1,s2,wdtp(0:200),wdte(0:200,0:5)
33075 INTEGER i,j,ierr
33076
33077 SH=pmas(54,1)**2
33078 aem=pyalem(sh)
33079
33080 tanw=sqrt(paru(102)/(1d0-paru(102)))
33081 ct2w=(1d0-2d0*paru(102))/(2d0*paru(102)/tanw)
33082 qupd=2d0*parp(143)-1d0
33083
33084 alprht=2.91d0*(3d0/parp(144))
33085 far=sqrt(aem/alprht)
33086 fao=far*qupd
33087 fzr=far*ct2w
33088 fzo=-fao*tanw
33089
33090 ar(1,1) = sh
33091 ar(2,2) = sh-pmas(23,1)**2
33092 ar(3,3) = sh-pmas(54,1)**2
33093 ar(4,4) = sh-pmas(56,1)**2
33094 ar(1,2) = 0d0
33095 ar(2,1) = 0d0
33096 ar(1,3) = -sh*far
33097 ar(3,1) = ar(1,3)
33098 ar(1,4) = -sh*fao
33099 ar(4,1) = ar(1,4)
33100 ar(2,3) = -sh*fzr
33101 ar(3,2) = ar(2,3)
33102 ar(2,4) = -sh*fzo
33103 ar(4,2) = ar(2,4)
33104 ar(3,4) = 0d0
33105 ar(4,3) = 0d0
33106CCCCCCCC
33107 DO 110 i=1,4
33108 DO 100 j=1,4
33109 at(i,j)=0d0
33110 100 CONTINUE
33111 110 CONTINUE
33112 shr=sqrt(sh)
33113 CALL pywidt(23,sh,wdtp,wdte)
33114 at(2,2) = wdtp(0)*shr
33115 CALL pywidt(54,sh,wdtp,wdte)
33116 at(3,3) = wdtp(0)*shr
33117 CALL pywidt(56,sh,wdtp,wdte)
33118 at(4,4) = wdtp(0)*shr
33119CCCC
33120 CALL pyeicg(4,4,ar,at,wr,wi,0,zr,zi,fv1,fv2,fv3,ierr)
33121 DO 120 i=1,4
33122 wi(i)=sqrt(abs(sh-wr(i)))
33123 wr(i)=abs(wr(i))
33124 120 CONTINUE
33125 r1=min(wr(1),wr(2),wr(3),wr(4))
33126 r2=1d20
33127 s1=0d0
33128 s2=0d0
33129 DO 130 i=1,4
33130 IF(abs(wr(i)-r1).LT.1d-6) THEN
33131 s1=wi(i)
33132 GOTO 130
33133 ENDIF
33134 IF(wr(i).LE.r2) THEN
33135 r2=wr(i)
33136 s2=wi(i)
33137 ENDIF
33138 130 CONTINUE
33139 s1=s1**2
33140 s2=s2**2
33141 RETURN
33142 END
33143
33144
33145
33146C*********************************************************************
33147
33148C...PYEIGC
33149C...Finds eigenvalues of a general complex matrix
33150
33151 SUBROUTINE pyeicg(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
33152C
33153 INTEGER N,NM,IS1,IS2,IERR,MATZ
33154 DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
33155 X FV1(N),FV2(N),FV3(N)
33156C
33157C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
33158C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
33159C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
33160C OF A COMPLEX GENERAL MATRIX.
33161C
33162C ON INPUT
33163C
33164C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
33165C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33166C DIMENSION STATEMENT.
33167C
33168C N IS THE ORDER OF THE MATRIX A=(AR,AI).
33169C
33170C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33171C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
33172C
33173C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
33174C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
33175C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
33176C
33177C ON OUTPUT
33178C
33179C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33180C RESPECTIVELY, OF THE EIGENVALUES.
33181C
33182C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33183C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
33184C
33185C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
33186C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
33187C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
33188C
33189C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
33190C
33191C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33192C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33193C
33194C THIS VERSION DATED AUGUST 1983.
33195C
33196C ------------------------------------------------------------------
33197C
33198 IF (n .LE. nm) GO TO 10
33199 ierr = 10 * n
33200 GO TO 50
33201C
33202 10 CALL cbal(nm,n,ar,ai,is1,is2,fv1)
33203 CALL corth(nm,n,is1,is2,ar,ai,fv2,fv3)
33204 IF (matz .NE. 0) GO TO 20
33205C .......... FIND EIGENVALUES ONLY ..........
33206 CALL comqr(nm,n,is1,is2,ar,ai,wr,wi,ierr)
33207 GO TO 50
33208C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
33209 20 CALL comqr2(nm,n,is1,is2,fv2,fv3,ar,ai,wr,wi,zr,zi,ierr)
33210 IF (ierr .NE. 0) GO TO 50
33211 CALL cbabk2(nm,n,is1,is2,fv1,n,zr,zi)
33212 50 RETURN
33213 END
33214 SUBROUTINE cbabk2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
33215C
33216 INTEGER I,J,K,M,N,II,NM,IGH,LOW
33217 DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
33218 DOUBLE PRECISION S
33219C
33220C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33221C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
33222C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33223C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33224C
33225C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
33226C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
33227C BALANCED MATRIX DETERMINED BY CBAL.
33228C
33229C ON INPUT
33230C
33231C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33232C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33233C DIMENSION STATEMENT.
33234C
33235C N IS THE ORDER OF THE MATRIX.
33236C
33237C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
33238C
33239C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
33240C AND SCALING FACTORS USED BY CBAL.
33241C
33242C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
33243C
33244C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33245C RESPECTIVELY, OF THE EIGENVECTORS TO BE
33246C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
33247C
33248C ON OUTPUT
33249C
33250C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33251C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
33252C IN THEIR FIRST M COLUMNS.
33253C
33254C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33255C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33256C
33257C THIS VERSION DATED AUGUST 1983.
33258C
33259C ------------------------------------------------------------------
33260C
33261 IF (m .EQ. 0) GO TO 200
33262 IF (igh .EQ. low) GO TO 120
33263C
33264 DO 110 i = low, igh
33265 s = scale(i)
33266C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
33267C IF THE FOREGOING STATEMENT IS REPLACED BY
33268C S=1.0D0/SCALE(I). ..........
33269 DO 100 j = 1, m
33270 zr(i,j) = zr(i,j) * s
33271 zi(i,j) = zi(i,j) * s
33272 100 CONTINUE
33273C
33274 110 CONTINUE
33275C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
33276C IGH+1 STEP 1 UNTIL N DO -- ..........
33277 120 DO 140 ii = 1, n
33278 i = ii
33279 IF (i .GE. low .AND. i .LE. igh) GO TO 140
33280 IF (i .LT. low) i = low - ii
33281 k = scale(i)
33282 IF (k .EQ. i) GO TO 140
33283C
33284 DO 130 j = 1, m
33285 s = zr(i,j)
33286 zr(i,j) = zr(k,j)
33287 zr(k,j) = s
33288 s = zi(i,j)
33289 zi(i,j) = zi(k,j)
33290 zi(k,j) = s
33291 130 CONTINUE
33292C
33293 140 CONTINUE
33294C
33295 200 RETURN
33296 END
33297 SUBROUTINE cbal(NM,N,AR,AI,LOW,IGH,SCALE)
33298C
33299 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
33300 DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
33301 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
33302 LOGICAL NOCONV
33303C
33304C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33305C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
33306C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33307C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33308C
33309C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
33310C EIGENVALUES WHENEVER POSSIBLE.
33311C
33312C ON INPUT
33313C
33314C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33315C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33316C DIMENSION STATEMENT.
33317C
33318C N IS THE ORDER OF THE MATRIX.
33319C
33320C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33321C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
33322C
33323C ON OUTPUT
33324C
33325C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33326C RESPECTIVELY, OF THE BALANCED MATRIX.
33327C
33328C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
33329C ARE EQUAL TO ZERO IF
33330C (1) I IS GREATER THAN J AND
33331C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
33332C
33333C SCALE CONTAINS INFORMATION DETERMINING THE
33334C PERMUTATIONS AND SCALING FACTORS USED.
33335C
33336C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
33337C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
33338C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
33339C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
33340C SCALE(J) = P(J), FOR J = 1,...,LOW-1
33341C = D(J,J) J = LOW,...,IGH
33342C = P(J) J = IGH+1,...,N.
33343C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
33344C THEN 1 TO LOW-1.
33345C
33346C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
33347C
33348C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
33349C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
33350C K,L HAVE BEEN REVERSED.)
33351C
33352C ARITHMETIC IS REAL THROUGHOUT.
33353C
33354C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33355C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33356C
33357C THIS VERSION DATED AUGUST 1983.
33358C
33359C ------------------------------------------------------------------
33360C
33361 radix = 16.0d0
33362C
33363 b2 = radix * radix
33364 k = 1
33365 l = n
33366 GO TO 100
33367C .......... IN-LINE PROCEDURE FOR ROW AND
33368C COLUMN EXCHANGE ..........
33369 20 scale(m) = j
33370 IF (j .EQ. m) GO TO 50
33371C
33372 DO 30 i = 1, l
33373 f = ar(i,j)
33374 ar(i,j) = ar(i,m)
33375 ar(i,m) = f
33376 f = ai(i,j)
33377 ai(i,j) = ai(i,m)
33378 ai(i,m) = f
33379 30 CONTINUE
33380C
33381 DO 40 i = k, n
33382 f = ar(j,i)
33383 ar(j,i) = ar(m,i)
33384 ar(m,i) = f
33385 f = ai(j,i)
33386 ai(j,i) = ai(m,i)
33387 ai(m,i) = f
33388 40 CONTINUE
33389C
33390 50 GO TO (80,130), iexc
33391C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
33392C AND PUSH THEM DOWN ..........
33393 80 IF (l .EQ. 1) GO TO 280
33394 l = l - 1
33395C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
33396 100 DO 120 jj = 1, l
33397 j = l + 1 - jj
33398C
33399 DO 110 i = 1, l
33400 IF (i .EQ. j) GO TO 110
33401 IF (ar(j,i) .NE. 0.0d0 .OR. ai(j,i) .NE. 0.0d0) GO TO 120
33402 110 CONTINUE
33403C
33404 m = l
33405 iexc = 1
33406 GO TO 20
33407 120 CONTINUE
33408C
33409 GO TO 140
33410C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
33411C AND PUSH THEM LEFT ..........
33412 130 k = k + 1
33413C
33414 140 DO 170 j = k, l
33415C
33416 DO 150 i = k, l
33417 IF (i .EQ. j) GO TO 150
33418 IF (ar(i,j) .NE. 0.0d0 .OR. ai(i,j) .NE. 0.0d0) GO TO 170
33419 150 CONTINUE
33420C
33421 m = k
33422 iexc = 2
33423 GO TO 20
33424 170 CONTINUE
33425C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
33426 DO 180 i = k, l
33427 180 scale(i) = 1.0d0
33428C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
33429 190 noconv = .false.
33430C
33431 DO 270 i = k, l
33432 c = 0.0d0
33433 r = 0.0d0
33434C
33435 DO 200 j = k, l
33436 IF (j .EQ. i) GO TO 200
33437 c = c + dabs(ar(j,i)) + dabs(ai(j,i))
33438 r = r + dabs(ar(i,j)) + dabs(ai(i,j))
33439 200 CONTINUE
33440C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
33441 IF (c .EQ. 0.0d0 .OR. r .EQ. 0.0d0) GO TO 270
33442 g = r / radix
33443 f = 1.0d0
33444 s = c + r
33445 210 IF (c .GE. g) GO TO 220
33446 f = f * radix
33447 c = c * b2
33448 GO TO 210
33449 220 g = r * radix
33450 230 IF (c .LT. g) GO TO 240
33451 f = f / radix
33452 c = c / b2
33453 GO TO 230
33454C .......... NOW BALANCE ..........
33455 240 IF ((c + r) / f .GE. 0.95d0 * s) GO TO 270
33456 g = 1.0d0 / f
33457 scale(i) = scale(i) * f
33458 noconv = .true.
33459C
33460 DO 250 j = k, n
33461 ar(i,j) = ar(i,j) * g
33462 ai(i,j) = ai(i,j) * g
33463 250 CONTINUE
33464C
33465 DO 260 j = 1, l
33466 ar(j,i) = ar(j,i) * f
33467 ai(j,i) = ai(j,i) * f
33468 260 CONTINUE
33469C
33470 270 CONTINUE
33471C
33472 IF (noconv) GO TO 190
33473C
33474 280 low = k
33475 igh = l
33476 RETURN
33477 END
33478 SUBROUTINE cdiv(AR,AI,BR,BI,CR,CI)
33479 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
33480C
33481C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
33482C
33483 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
33484 s = dabs(br) + dabs(bi)
33485 ars = ar/s
33486 ais = ai/s
33487 brs = br/s
33488 bis = bi/s
33489 s = brs**2 + bis**2
33490 cr = (ars*brs + ais*bis)/s
33491 ci = (ais*brs - ars*bis)/s
33492 RETURN
33493 END
33494 SUBROUTINE comqr(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
33495C
33496 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
33497 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
33498 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
33499 x pythag
33500C
33501C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33502C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
33503C AND WILKINSON.
33504C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
33505C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33506C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33507C
33508C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
33509C UPPER HESSENBERG MATRIX BY THE QR METHOD.
33510C
33511C ON INPUT
33512C
33513C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33514C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33515C DIMENSION STATEMENT.
33516C
33517C N IS THE ORDER OF THE MATRIX.
33518C
33519C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33520C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33521C SET LOW=1, IGH=N.
33522C
33523C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33524C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33525C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
33526C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
33527C THE REDUCTION BY CORTH, IF PERFORMED.
33528C
33529C ON OUTPUT
33530C
33531C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
33532C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
33533C CALLING COMQR IF SUBSEQUENT CALCULATION OF
33534C EIGENVECTORS IS TO BE PERFORMED.
33535C
33536C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33537C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33538C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33539C FOR INDICES IERR+1,...,N.
33540C
33541C IERR IS SET TO
33542C ZERO FOR NORMAL RETURN,
33543C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33544C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33545C
33546C CALLS CDIV FOR COMPLEX DIVISION.
33547C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33548C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33549C
33550C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33551C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33552C
33553C THIS VERSION DATED AUGUST 1983.
33554C
33555C ------------------------------------------------------------------
33556C
33557 ierr = 0
33558 IF (low .EQ. igh) GO TO 180
33559C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33560 l = low + 1
33561C
33562 DO 170 i = l, igh
33563 ll = min0(i+1,igh)
33564 IF (hi(i,i-1) .EQ. 0.0d0) GO TO 170
33565 norm = pythag(hr(i,i-1),hi(i,i-1))
33566 yr = hr(i,i-1) / norm
33567 yi = hi(i,i-1) / norm
33568 hr(i,i-1) = norm
33569 hi(i,i-1) = 0.0d0
33570C
33571 DO 155 j = i, igh
33572 si = yr * hi(i,j) - yi * hr(i,j)
33573 hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
33574 hi(i,j) = si
33575 155 CONTINUE
33576C
33577 DO 160 j = low, ll
33578 si = yr * hi(j,i) + yi * hr(j,i)
33579 hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
33580 hi(j,i) = si
33581 160 CONTINUE
33582C
33583 170 CONTINUE
33584C .......... STORE ROOTS ISOLATED BY CBAL ..........
33585 180 DO 200 i = 1, n
33586 IF (i .GE. low .AND. i .LE. igh) GO TO 200
33587 wr(i) = hr(i,i)
33588 wi(i) = hi(i,i)
33589 200 CONTINUE
33590C
33591 en = igh
33592 tr = 0.0d0
33593 ti = 0.0d0
33594 itn = 30*n
33595C .......... SEARCH FOR NEXT EIGENVALUE ..........
33596 220 IF (en .LT. low) GO TO 1001
33597 its = 0
33598 enm1 = en - 1
33599C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33600C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
33601 240 DO 260 ll = low, en
33602 l = en + low - ll
33603 IF (l .EQ. low) GO TO 300
33604 tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
33605 x + dabs(hr(l,l)) + dabs(hi(l,l))
33606 tst2 = tst1 + dabs(hr(l,l-1))
33607 IF (tst2 .EQ. tst1) GO TO 300
33608 260 CONTINUE
33609C .......... FORM SHIFT ..........
33610 300 IF (l .EQ. en) GO TO 660
33611 IF (itn .EQ. 0) GO TO 1000
33612 IF (its .EQ. 10 .OR. its .EQ. 20) GO TO 320
33613 sr = hr(en,en)
33614 si = hi(en,en)
33615 xr = hr(enm1,en) * hr(en,enm1)
33616 xi = hi(enm1,en) * hr(en,enm1)
33617 IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) GO TO 340
33618 yr = (hr(enm1,enm1) - sr) / 2.0d0
33619 yi = (hi(enm1,enm1) - si) / 2.0d0
33620 CALL csroot(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
33621 IF (yr * zzr + yi * zzi .GE. 0.0d0) GO TO 310
33622 zzr = -zzr
33623 zzi = -zzi
33624 310 CALL cdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
33625 sr = sr - xr
33626 si = si - xi
33627 GO TO 340
33628C .......... FORM EXCEPTIONAL SHIFT ..........
33629 320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
33630 si = 0.0d0
33631C
33632 340 DO 360 i = low, en
33633 hr(i,i) = hr(i,i) - sr
33634 hi(i,i) = hi(i,i) - si
33635 360 CONTINUE
33636C
33637 tr = tr + sr
33638 ti = ti + si
33639 its = its + 1
33640 itn = itn - 1
33641C .......... REDUCE TO TRIANGLE (ROWS) ..........
33642 lp1 = l + 1
33643C
33644 DO 500 i = lp1, en
33645 sr = hr(i,i-1)
33646 hr(i,i-1) = 0.0d0
33647 norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
33648 xr = hr(i-1,i-1) / norm
33649 wr(i-1) = xr
33650 xi = hi(i-1,i-1) / norm
33651 wi(i-1) = xi
33652 hr(i-1,i-1) = norm
33653 hi(i-1,i-1) = 0.0d0
33654 hi(i,i-1) = sr / norm
33655C
33656 DO 490 j = i, en
33657 yr = hr(i-1,j)
33658 yi = hi(i-1,j)
33659 zzr = hr(i,j)
33660 zzi = hi(i,j)
33661 hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
33662 hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
33663 hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
33664 hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
33665 490 CONTINUE
33666C
33667 500 CONTINUE
33668C
33669 si = hi(en,en)
33670 IF (si .EQ. 0.0d0) GO TO 540
33671 norm = pythag(hr(en,en),si)
33672 sr = hr(en,en) / norm
33673 si = si / norm
33674 hr(en,en) = norm
33675 hi(en,en) = 0.0d0
33676C .......... INVERSE OPERATION (COLUMNS) ..........
33677 540 DO 600 j = lp1, en
33678 xr = wr(j-1)
33679 xi = wi(j-1)
33680C
33681 DO 580 i = l, j
33682 yr = hr(i,j-1)
33683 yi = 0.0d0
33684 zzr = hr(i,j)
33685 zzi = hi(i,j)
33686 IF (i .EQ. j) GO TO 560
33687 yi = hi(i,j-1)
33688 hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
33689 560 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
33690 hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
33691 hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
33692 580 CONTINUE
33693C
33694 600 CONTINUE
33695C
33696 IF (si .EQ. 0.0d0) GO TO 240
33697C
33698 DO 630 i = l, en
33699 yr = hr(i,en)
33700 yi = hi(i,en)
33701 hr(i,en) = sr * yr - si * yi
33702 hi(i,en) = sr * yi + si * yr
33703 630 CONTINUE
33704C
33705 GO TO 240
33706C .......... A ROOT FOUND ..........
33707 660 wr(en) = hr(en,en) + tr
33708 wi(en) = hi(en,en) + ti
33709 en = enm1
33710 GO TO 220
33711C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
33712C CONVERGED AFTER 30*N ITERATIONS ..........
33713 1000 ierr = en
33714 1001 RETURN
33715 END
33716 SUBROUTINE comqr2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
33717C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
33718C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
33719C
33720 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
33721 x itn,its,low,lp1,enm1,iend,ierr
33722 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
33723 X ORTR(IGH),ORTI(IGH)
33724 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
33725 X PYTHAG
33726C
33727C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33728C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
33729C AND WILKINSON.
33730C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
33731C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33732C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33733C
33734C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
33735C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
33736C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
33737C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
33738C THIS GENERAL MATRIX TO HESSENBERG FORM.
33739C
33740C ON INPUT
33741C
33742C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33743C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33744C DIMENSION STATEMENT.
33745C
33746C N IS THE ORDER OF THE MATRIX.
33747C
33748C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33749C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33750C SET LOW=1, IGH=N.
33751C
33752C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
33753C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
33754C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
33755C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
33756C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
33757C
33758C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33759C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33760C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
33761C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
33762C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
33763C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
33764C ARBITRARY.
33765C
33766C ON OUTPUT
33767C
33768C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
33769C HAVE BEEN DESTROYED.
33770C
33771C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33772C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33773C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33774C FOR INDICES IERR+1,...,N.
33775C
33776C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33777C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
33778C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
33779C THE EIGENVECTORS HAS BEEN FOUND.
33780C
33781C IERR IS SET TO
33782C ZERO FOR NORMAL RETURN,
33783C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33784C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33785C
33786C CALLS CDIV FOR COMPLEX DIVISION.
33787C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33788C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33789C
33790C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33791C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33792C
33793C THIS VERSION DATED OCTOBER 1989.
33794C
33795C ------------------------------------------------------------------
33796C
33797 ierr = 0
33798C .......... INITIALIZE EIGENVECTOR MATRIX ..........
33799 DO 101 j = 1, n
33800C
33801 DO 100 i = 1, n
33802 zr(i,j) = 0.0d0
33803 zi(i,j) = 0.0d0
33804 100 CONTINUE
33805 zr(j,j) = 1.0d0
33806 101 CONTINUE
33807C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
33808C FROM THE INFORMATION LEFT BY CORTH ..........
33809 iend = igh - low - 1
33810 IF (iend) 180, 150, 105
33811C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
33812 105 DO 140 ii = 1, iend
33813 i = igh - ii
33814 IF (ortr(i) .EQ. 0.0d0 .AND. orti(i) .EQ. 0.0d0) GO TO 140
33815 IF (hr(i,i-1) .EQ. 0.0d0 .AND. hi(i,i-1) .EQ. 0.0d0) GO TO 140
33816C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
33817 norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)
33818 ip1 = i + 1
33819C
33820 DO 110 k = ip1, igh
33821 ortr(k) = hr(k,i-1)
33822 orti(k) = hi(k,i-1)
33823 110 CONTINUE
33824C
33825 DO 130 j = i, igh
33826 sr = 0.0d0
33827 si = 0.0d0
33828C
33829 DO 115 k = i, igh
33830 sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
33831 si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
33832 115 CONTINUE
33833C
33834 sr = sr / norm
33835 si = si / norm
33836C
33837 DO 120 k = i, igh
33838 zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
33839 zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
33840 120 CONTINUE
33841C
33842 130 CONTINUE
33843C
33844 140 CONTINUE
33845C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33846 150 l = low + 1
33847C
33848 DO 170 i = l, igh
33849 ll = min0(i+1,igh)
33850 IF (hi(i,i-1) .EQ. 0.0d0) GO TO 170
33851 norm = pythag(hr(i,i-1),hi(i,i-1))
33852 yr = hr(i,i-1) / norm
33853 yi = hi(i,i-1) / norm
33854 hr(i,i-1) = norm
33855 hi(i,i-1) = 0.0d0
33856C
33857 DO 155 j = i, n
33858 si = yr * hi(i,j) - yi * hr(i,j)
33859 hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
33860 hi(i,j) = si
33861 155 CONTINUE
33862C
33863 DO 160 j = 1, ll
33864 si = yr * hi(j,i) + yi * hr(j,i)
33865 hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
33866 hi(j,i) = si
33867 160 CONTINUE
33868C
33869 DO 165 j = low, igh
33870 si = yr * zi(j,i) + yi * zr(j,i)
33871 zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
33872 zi(j,i) = si
33873 165 CONTINUE
33874C
33875 170 CONTINUE
33876C .......... STORE ROOTS ISOLATED BY CBAL ..........
33877 180 DO 200 i = 1, n
33878 IF (i .GE. low .AND. i .LE. igh) GO TO 200
33879 wr(i) = hr(i,i)
33880 wi(i) = hi(i,i)
33881 200 CONTINUE
33882C
33883 en = igh
33884 tr = 0.0d0
33885 ti = 0.0d0
33886 itn = 30*n
33887C .......... SEARCH FOR NEXT EIGENVALUE ..........
33888 220 IF (en .LT. low) GO TO 680
33889 its = 0
33890 enm1 = en - 1
33891C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33892C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
33893 240 DO 260 ll = low, en
33894 l = en + low - ll
33895 IF (l .EQ. low) GO TO 300
33896 tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
33897 x + dabs(hr(l,l)) + dabs(hi(l,l))
33898 tst2 = tst1 + dabs(hr(l,l-1))
33899 IF (tst2 .EQ. tst1) GO TO 300
33900 260 CONTINUE
33901C .......... FORM SHIFT ..........
33902 300 IF (l .EQ. en) GO TO 660
33903 IF (itn .EQ. 0) GO TO 1000
33904 IF (its .EQ. 10 .OR. its .EQ. 20) GO TO 320
33905 sr = hr(en,en)
33906 si = hi(en,en)
33907 xr = hr(enm1,en) * hr(en,enm1)
33908 xi = hi(enm1,en) * hr(en,enm1)
33909 IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) GO TO 340
33910 yr = (hr(enm1,enm1) - sr) / 2.0d0
33911 yi = (hi(enm1,enm1) - si) / 2.0d0
33912 CALL csroot(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
33913 IF (yr * zzr + yi * zzi .GE. 0.0d0) GO TO 310
33914 zzr = -zzr
33915 zzi = -zzi
33916 310 CALL cdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
33917 sr = sr - xr
33918 si = si - xi
33919 GO TO 340
33920C .......... FORM EXCEPTIONAL SHIFT ..........
33921 320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
33922 si = 0.0d0
33923C
33924 340 DO 360 i = low, en
33925 hr(i,i) = hr(i,i) - sr
33926 hi(i,i) = hi(i,i) - si
33927 360 CONTINUE
33928C
33929 tr = tr + sr
33930 ti = ti + si
33931 its = its + 1
33932 itn = itn - 1
33933C .......... REDUCE TO TRIANGLE (ROWS) ..........
33934 lp1 = l + 1
33935C
33936 DO 500 i = lp1, en
33937 sr = hr(i,i-1)
33938 hr(i,i-1) = 0.0d0
33939 norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
33940 xr = hr(i-1,i-1) / norm
33941 wr(i-1) = xr
33942 xi = hi(i-1,i-1) / norm
33943 wi(i-1) = xi
33944 hr(i-1,i-1) = norm
33945 hi(i-1,i-1) = 0.0d0
33946 hi(i,i-1) = sr / norm
33947C
33948 DO 490 j = i, n
33949 yr = hr(i-1,j)
33950 yi = hi(i-1,j)
33951 zzr = hr(i,j)
33952 zzi = hi(i,j)
33953 hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
33954 hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
33955 hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
33956 hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
33957 490 CONTINUE
33958C
33959 500 CONTINUE
33960C
33961 si = hi(en,en)
33962 IF (si .EQ. 0.0d0) GO TO 540
33963 norm = pythag(hr(en,en),si)
33964 sr = hr(en,en) / norm
33965 si = si / norm
33966 hr(en,en) = norm
33967 hi(en,en) = 0.0d0
33968 IF (en .EQ. n) GO TO 540
33969 ip1 = en + 1
33970C
33971 DO 520 j = ip1, n
33972 yr = hr(en,j)
33973 yi = hi(en,j)
33974 hr(en,j) = sr * yr + si * yi
33975 hi(en,j) = sr * yi - si * yr
33976 520 CONTINUE
33977C .......... INVERSE OPERATION (COLUMNS) ..........
33978 540 DO 600 j = lp1, en
33979 xr = wr(j-1)
33980 xi = wi(j-1)
33981C
33982 DO 580 i = 1, j
33983 yr = hr(i,j-1)
33984 yi = 0.0d0
33985 zzr = hr(i,j)
33986 zzi = hi(i,j)
33987 IF (i .EQ. j) GO TO 560
33988 yi = hi(i,j-1)
33989 hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
33990 560 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
33991 hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
33992 hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
33993 580 CONTINUE
33994C
33995 DO 590 i = low, igh
33996 yr = zr(i,j-1)
33997 yi = zi(i,j-1)
33998 zzr = zr(i,j)
33999 zzi = zi(i,j)
34000 zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
34001 zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
34002 zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
34003 zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
34004 590 CONTINUE
34005C
34006 600 CONTINUE
34007C
34008 IF (si .EQ. 0.0d0) GO TO 240
34009C
34010 DO 630 i = 1, en
34011 yr = hr(i,en)
34012 yi = hi(i,en)
34013 hr(i,en) = sr * yr - si * yi
34014 hi(i,en) = sr * yi + si * yr
34015 630 CONTINUE
34016C
34017 DO 640 i = low, igh
34018 yr = zr(i,en)
34019 yi = zi(i,en)
34020 zr(i,en) = sr * yr - si * yi
34021 zi(i,en) = sr * yi + si * yr
34022 640 CONTINUE
34023C
34024 GO TO 240
34025C .......... A ROOT FOUND ..........
34026 660 hr(en,en) = hr(en,en) + tr
34027 wr(en) = hr(en,en)
34028 hi(en,en) = hi(en,en) + ti
34029 wi(en) = hi(en,en)
34030 en = enm1
34031 GO TO 220
34032C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
34033C VECTORS OF UPPER TRIANGULAR FORM ..........
34034 680 norm = 0.0d0
34035C
34036 DO 720 i = 1, n
34037C
34038 DO 720 j = i, n
34039 tr = dabs(hr(i,j)) + dabs(hi(i,j))
34040 IF (tr .GT. norm) norm = tr
34041 720 CONTINUE
34042C
34043 IF (n .EQ. 1 .OR. norm .EQ. 0.0d0) GO TO 1001
34044C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
34045 DO 800 nn = 2, n
34046 en = n + 2 - nn
34047 xr = wr(en)
34048 xi = wi(en)
34049 hr(en,en) = 1.0d0
34050 hi(en,en) = 0.0d0
34051 enm1 = en - 1
34052C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
34053 DO 780 ii = 1, enm1
34054 i = en - ii
34055 zzr = 0.0d0
34056 zzi = 0.0d0
34057 ip1 = i + 1
34058C
34059 DO 740 j = ip1, en
34060 zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
34061 zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
34062 740 CONTINUE
34063C
34064 yr = xr - wr(i)
34065 yi = xi - wi(i)
34066 IF (yr .NE. 0.0d0 .OR. yi .NE. 0.0d0) GO TO 765
34067 tst1 = norm
34068 yr = tst1
34069 760 yr = 0.01d0 * yr
34070 tst2 = norm + yr
34071 IF (tst2 .GT. tst1) GO TO 760
34072 765 CONTINUE
34073 CALL cdiv(zzr,zzi,yr,yi,hr(i,en),hi(i,en))
34074C .......... OVERFLOW CONTROL ..........
34075 tr = dabs(hr(i,en)) + dabs(hi(i,en))
34076 IF (tr .EQ. 0.0d0) GO TO 780
34077 tst1 = tr
34078 tst2 = tst1 + 1.0d0/tst1
34079 IF (tst2 .GT. tst1) GO TO 780
34080 DO 770 j = i, en
34081 hr(j,en) = hr(j,en)/tr
34082 hi(j,en) = hi(j,en)/tr
34083 770 CONTINUE
34084C
34085 780 CONTINUE
34086C
34087 800 CONTINUE
34088C .......... END BACKSUBSTITUTION ..........
34089C .......... VECTORS OF ISOLATED ROOTS ..........
34090 DO 840 i = 1, n
34091 IF (i .GE. low .AND. i .LE. igh) GO TO 840
34092C
34093 DO 820 j = i, n
34094 zr(i,j) = hr(i,j)
34095 zi(i,j) = hi(i,j)
34096 820 CONTINUE
34097C
34098 840 CONTINUE
34099C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
34100C VECTORS OF ORIGINAL FULL MATRIX.
34101C FOR J=N STEP -1 UNTIL LOW DO -- ..........
34102 DO 880 jj = low, n
34103 j = n + low - jj
34104 m = min0(j,igh)
34105C
34106 DO 880 i = low, igh
34107 zzr = 0.0d0
34108 zzi = 0.0d0
34109C
34110 DO 860 k = low, m
34111 zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
34112 zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
34113 860 CONTINUE
34114C
34115 zr(i,j) = zzr
34116 zi(i,j) = zzi
34117 880 CONTINUE
34118C
34119 GO TO 1001
34120C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
34121C CONVERGED AFTER 30*N ITERATIONS ..........
34122 1000 ierr = en
34123 1001 RETURN
34124 END
34125 SUBROUTINE corth(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
34126C
34127 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
34128 DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
34129 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
34130C
34131C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
34132C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
34133C BY MARTIN AND WILKINSON.
34134C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
34135C
34136C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
34137C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
34138C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
34139C UNITARY SIMILARITY TRANSFORMATIONS.
34140C
34141C ON INPUT
34142C
34143C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
34144C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
34145C DIMENSION STATEMENT.
34146C
34147C N IS THE ORDER OF THE MATRIX.
34148C
34149C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
34150C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
34151C SET LOW=1, IGH=N.
34152C
34153C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34154C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
34155C
34156C ON OUTPUT
34157C
34158C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34159C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
34160C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
34161C IS STORED IN THE REMAINING TRIANGLES UNDER THE
34162C HESSENBERG MATRIX.
34163C
34164C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
34165C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
34166C
34167C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
34168C
34169C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
34170C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
34171C
34172C THIS VERSION DATED AUGUST 1983.
34173C
34174C ------------------------------------------------------------------
34175C
34176 la = igh - 1
34177 kp1 = low + 1
34178 IF (la .LT. kp1) GO TO 200
34179C
34180 DO 180 m = kp1, la
34181 h = 0.0d0
34182 ortr(m) = 0.0d0
34183 orti(m) = 0.0d0
34184 scale = 0.0d0
34185C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
34186 DO 90 i = m, igh
34187 90 scale = scale + dabs(ar(i,m-1)) + dabs(ai(i,m-1))
34188C
34189 IF (scale .EQ. 0.0d0) GO TO 180
34190 mp = m + igh
34191C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
34192 DO 100 ii = m, igh
34193 i = mp - ii
34194 ortr(i) = ar(i,m-1) / scale
34195 orti(i) = ai(i,m-1) / scale
34196 h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
34197 100 CONTINUE
34198C
34199 g = dsqrt(h)
34200 f = pythag(ortr(m),orti(m))
34201 IF (f .EQ. 0.0d0) GO TO 103
34202 h = h + f * g
34203 g = g / f
34204 ortr(m) = (1.0d0 + g) * ortr(m)
34205 orti(m) = (1.0d0 + g) * orti(m)
34206 GO TO 105
34207C
34208 103 ortr(m) = g
34209 ar(m,m-1) = scale
34210C .......... FORM (I-(U*UT)/H) * A ..........
34211 105 DO 130 j = m, n
34212 fr = 0.0d0
34213 fi = 0.0d0
34214C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
34215 DO 110 ii = m, igh
34216 i = mp - ii
34217 fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
34218 fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
34219 110 CONTINUE
34220C
34221 fr = fr / h
34222 fi = fi / h
34223C
34224 DO 120 i = m, igh
34225 ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i)
34226 ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i)
34227 120 CONTINUE
34228C
34229 130 CONTINUE
34230C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
34231 DO 160 i = 1, igh
34232 fr = 0.0d0
34233 fi = 0.0d0
34234C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
34235 DO 140 jj = m, igh
34236 j = mp - jj
34237 fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
34238 fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
34239 140 CONTINUE
34240C
34241 fr = fr / h
34242 fi = fi / h
34243C
34244 DO 150 j = m, igh
34245 ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j)
34246 ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j)
34247 150 CONTINUE
34248C
34249 160 CONTINUE
34250C
34251 ortr(m) = scale * ortr(m)
34252 orti(m) = scale * orti(m)
34253 ar(m,m-1) = -g * ar(m,m-1)
34254 ai(m,m-1) = -g * ai(m,m-1)
34255 180 CONTINUE
34256C
34257 200 RETURN
34258 END
34259 SUBROUTINE csroot(XR,XI,YR,YI)
34260 DOUBLE PRECISION XR,XI,YR,YI
34261C
34262C (YR,YI) = COMPLEX DSQRT(XR,XI)
34263C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
34264C
34265 DOUBLE PRECISION S,TR,TI,PYTHAG
34266 tr = xr
34267 ti = xi
34268 s = dsqrt(0.5d0*(pythag(tr,ti) + dabs(tr)))
34269 IF (tr .GE. 0.0d0) yr = s
34270 IF (ti .LT. 0.0d0) s = -s
34271 IF (tr .LE. 0.0d0) yi = s
34272 IF (tr .LT. 0.0d0) yr = 0.5d0*(ti/yi)
34273 IF (tr .GT. 0.0d0) yi = 0.5d0*(ti/yr)
34274 RETURN
34275 END
34276 DOUBLE PRECISION FUNCTION pythag(A,B)
34277 DOUBLE PRECISION A,B
34278C
34279C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
34280C
34281 DOUBLE PRECISION P,R,S,T,U
34282 p = dmax1(dabs(a),dabs(b))
34283 IF (p .EQ. 0.0d0) GO TO 20
34284 r = (dmin1(dabs(a),dabs(b))/p)**2
34285 10 CONTINUE
34286 t = 4.0d0 + r
34287 IF (t .EQ. 4.0d0) GO TO 20
34288 s = r/t
34289 u = 1.0d0 + 2.0d0*s
34290 p = u*p
34291 r = (s/u)**2 * r
34292 GO TO 10
34293 20 pythag = p
34294 RETURN
34295 END
34296
34297C*********************************************************************
34298
34299C...PYTBBN
34300C...Calculates the three-body decay of gluinos into
34301C...neutralinos and third generation fermions.
34302
34303 SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)
34304
34305C...Double precision and integer declarations.
34306 IMPLICIT DOUBLE PRECISION(a-h, o-z)
34307 IMPLICIT INTEGER(I-N)
34308 INTEGER PYK,PYCHGE,PYCOMP
34309C...Parameter statement to help give large particle numbers.
34310 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
34311C...Commonblocks.
34312 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34313 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34314 common/pymssm/imss(0:99),rmss(0:99)
34315 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
34316 &sfmix(16,4)
34317 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
34318
34319C...Local variables.
34320 EXTERNAL pysimp,pylamf
34321 DOUBLE PRECISION PYSIMP,PYLAMF
34322 INTEGER LIN,NN
34323 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
34324 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
34325 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
34326 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
34327 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
34328 DOUBLE PRECISION XLN1,XLN2,B1,B2
34329 DOUBLE PRECISION E,XMGLU,GAM
34330 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
34331 SAVE hrb,hlb,flb,frb
34332 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
34333 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
34334 SAVE hlt,hrt,flt,frt
34335 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
34336 &fld(4),frd(4)
34337 SAVE amc,amn,an,zn,flu,fru,fld,frd
34338 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
34339 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
34340 SAVE amsb,amst
34341 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
34342 DOUBLE PRECISION ROT1(4,4)
34343 LOGICAL IFIRST
34344 SAVE ifirst
34345 DATA ifirst/.true./
34346
34347 tanb=rmss(5)
34348 sinb=tanb/sqrt(1d0+tanb**2)
34349 cosb=sinb/tanb
34350 xw=paru(102)
34351 sinw=sqrt(xw)
34352 cosw=sqrt(1d0-xw)
34353 tanw=sinw/cosw
34354 amw=pmas(24,1)
34355 cosc=sfmix(5,1)
34356 sinc=sfmix(5,3)
34357 cosa=sfmix(6,1)
34358 sina=sfmix(6,3)
34359 ambot=0d0
34360 amtop=pyrnmt(pmas(6,1))
34361 w2=sqrt(2d0)
34362 fakt1=ambot/w2/amw/cosb
34363 fakt2=amtop/w2/amw/sinb
34364 IF(ifirst) THEN
34365 DO 110 ii=1,4
34366 amn(ii)=smz(ii)
34367 DO 100 j=1,4
34368 rot1(ii,j)=0d0
34369 an(ii,j)=0d0
34370 100 CONTINUE
34371 110 CONTINUE
34372 rot1(1,1)=cosw
34373 rot1(1,2)=-sinw
34374 rot1(2,1)=-rot1(1,2)
34375 rot1(2,2)=rot1(1,1)
34376 rot1(3,3)=cosb
34377 rot1(3,4)=sinb
34378 rot1(4,3)=-rot1(3,4)
34379 rot1(4,4)=rot1(3,3)
34380 DO 140 ii=1,4
34381 DO 130 j=1,4
34382 DO 120 jj=1,4
34383 an(ii,j)=an(ii,j)+zmix(ii,jj)*rot1(jj,j)
34384 120 CONTINUE
34385 130 CONTINUE
34386 140 CONTINUE
34387 DO 150 j=1,4
34388 zn(1)=-fakt2*(-sinb*an(j,3)+cosb*an(j,4))
34389 zn(2)=-2d0*w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
34390 zn(3)=-2*w2/3d0*sinw*an(j,1)-w2*(0.5d0-2d0/3d0*
34391 & xw)*an(j,2)/cosw
34392 hrt(j)=zn(1)*cosa-zn(3)*sina
34393 hlt(j)=zn(1)*cosa+zn(2)*sina
34394 flt(j)=zn(3)*cosa+zn(1)*sina
34395 frt(j)=zn(2)*cosa-zn(1)*sina
34396 flu(j)=zn(3)
34397 fru(j)=zn(2)
34398 zn(1)=-fakt1*(cosb*an(j,3)+sinb*an(j,4))
34399 zn(2)=w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
34400 zn(3)=w2/3d0*sinw*an(j,1)+w2*(0.5d0-xw/3d0)*an(j,2)/cosw
34401 hrb(j)=zn(1)*cosc-zn(3)*sinc
34402 hlb(j)=zn(1)*cosc+zn(2)*sinc
34403 flb(j)=zn(3)*cosc+zn(1)*sinc
34404 frb(j)=zn(2)*cosc-zn(1)*sinc
34405 fld(j)=zn(3)
34406 frd(j)=zn(2)
34407 150 CONTINUE
34408 amst(1)=pmas(pycomp(ksusy1+6),1)
34409 amst(2)=pmas(pycomp(ksusy2+6),1)
34410 amsb(1)=pmas(pycomp(ksusy1+5),1)
34411 amsb(2)=pmas(pycomp(ksusy2+5),1)
34412 ifirst=.false.
34413 ENDIF
34414
34415 IF(nint(3d0*e).EQ.2) THEN
34416 hl=hlt(i)
34417 hr=hrt(i)
34418 fl=flt(i)
34419 fr=frt(i)
34420 cosd=sfmix(6,1)
34421 sind=sfmix(6,3)
34422 xms2(1)=pmas(pycomp(ksusy1+6),1)**2
34423 xms2(2)=pmas(pycomp(ksusy2+6),1)**2
34424 xm=pmas(6,1)
34425 ELSE
34426 hl=hlb(i)
34427 hr=hrb(i)
34428 fl=flb(i)
34429 fr=frb(i)
34430 cosd=sfmix(5,1)
34431 sind=sfmix(5,3)
34432 xms2(1)=pmas(pycomp(ksusy1+5),1)**2
34433 xms2(2)=pmas(pycomp(ksusy2+5),1)**2
34434 xm=pmas(5,1)
34435 ENDIF
34436 cosd2=cosd*cosd
34437 sind2=sind*sind
34438 cos2d=cosd2-sind2
34439 sin2d=sind*cosd*2d0
34440 hl2=hl*hl
34441 hr2=hr*hr
34442 fl2=fl*fl
34443 fr2=fr*fr
34444 ff=fl*fr
34445 hh=hl*hr
34446 hfl=hl*fl
34447 hfr=hr*fr
34448 hrfl=hr*fl
34449 hlfr=hl*fr
34450 xm2=xm*xm
34451 xmg=xmglu
34452 xmg2=xmg*xmg
34453 alphaw=pyalem(xmg2)
34454 alphas=pyalps(xmg2)
34455 xmr=amn(i)
34456 xmr2=xmr*xmr
34457 xmq4=xmg*xm2*xmr
34458 xm24=(xmg2+xm2)*(xm2+xmr2)
34459 smin=4d0*xm2
34460 smax=(xmg-abs(xmr))**2
34461 xmqa=xmg2+2d0*xm2+xmr2
34462 DO 170 lin=1,nn-1
34463 sbar=smin+dble(lin)*(smax-smin)/dble(nn)
34464 grs=sbar-xmqa
34465 w=pylamf(xmg2,xmr2,sbar)*(0.25d0-xm2/sbar)
34466 w=dsqrt(w)
34467 xln1=log(abs((grs/2d0+xms2(1)-w)/(grs/2d0+xms2(1)+w)))
34468 xln2=log(abs((grs/2d0+xms2(2)-w)/(grs/2d0+xms2(2)+w)))
34469 b1=1d0/(grs/2d0+xms2(1)-w)-1d0/(grs/2d0+xms2(1)+w)
34470 b2=1d0/(grs/2d0+xms2(2)-w)-1d0/(grs/2d0+xms2(2)+w)
34471 g(0)=-2d0*(hl2+fl2+hr2+fr2+(hfr-hfl)*sin2d
34472 & +2d0*(ff*sind2-hh*cosd2))*w
34473 g(1)=((hl2+fl2)*(xmqa-2d0*xms2(1)-2d0*xm*xmg*sin2d)
34474 & +4d0*hfl*xm*xmr)*xln1
34475 & +((hl2+fl2)*((xmqa-xms2(1))*xms2(1)-xm24
34476 & +2d0*xm*xmg*(xm2+xmr2-xms2(1))*sin2d)
34477 & -4d0*hfl*xmr*xm*(xmg2+xm2-xms2(1))
34478 & +8d0*hfl*xmq4*sin2d)*b1
34479 g(2)=((hr2+fr2)*(xmqa-2d0*xms2(2)+2d0*xm*xmg*sin2d)
34480 & +4d0*hfr*xmr*xm)*xln2
34481 & +((hr2+fr2)*((xmqa-xms2(2))*xms2(2)-xm24
34482 & +2d0*xmg*xm*sin2d*(xms2(2)-xm2-xmr2))
34483 & +4d0*hfr*xm*xmr*(xms2(2)-xmg2-xm2)
34484 & -8d0*hfr*xmq4*sin2d)*b2
34485 g(3)=(2d0*hfl*sin2d*(xms2(1)*(grs+xms2(1))+xm2*(sbar-xmg2-xmr2)
34486 & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hl2*sind2+fl2*cosd2)*sbar
34487 & -2d0*xmg*xm*hfl*(sbar+xmr2-xmg2)
34488 & +xmr*xm*(hl2+fl2)*sin2d*(sbar+xmg2-xmr2)
34489 & -4d0*xmq4*(hl2-fl2)*cos2d)/(grs+2d0*xms2(1))*xln1
34490 g(4)=4d0*cos2d*xm*xmg/(xms2(1)-xms2(2))*
34491 & (((hlfr+hrfl)*(xm2+xmr2)+2d0*xm*xmr*(hh+ff))*(xln1-xln2)
34492 & +(hlfr+hrfl)*(xms2(2)*xln2-xms2(1)*xln1))
34493 g(5)=(2d0*(hh*cosd2-ff*sind2)
34494 & *((xms2(2)*(xms2(2)+grs)+xm2*xm2+xmg2*xmr2)*xln2
34495 & +(xms2(1)*(xms2(1)+grs)+xm2*xm2+xmg2*xmr2)*xln1)
34496 & +xm*((hh-ff)*sin2d*xmg-(hrfl-hlfr)*xmr)
34497 & *((grs+xms2(1)*2d0)*xln1-(grs+xms2(2)*2d0)*xln2)
34498 & +((hrfl-hlfr)*xmr*(sin2d*xmg*(sbar-4d0*xm2)
34499 & +cos2d*xm*(sbar+xmg2-xmr2))
34500 & +2d0*(ff*cosd2-hh*sind2)*xm2*(sbar-xmg2-xmr2))
34501 & *(xln1+xln2))/(grs+xms2(1)+xms2(2))
34502 g(6)=(-2d0*hfr*sin2d*(xms2(2)*(grs+xms2(2))+xm2*(sbar-xmg2-xmr2)
34503 & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hr2*sind2+fr2*cosd2)*sbar
34504 & -2d0*xmg*xm*hfr*(sbar+xmr2-xmg2)
34505 & -xmr*xm*(hr2+fr2)*sin2d*(sbar+xmg2-xmr2)
34506 & -4d0*xmq4*(hr2-fr2)*cos2d)/(grs+2d0*xms2(2))*xln2
34507 summe(lin)=0d0
34508 DO 160 j=0,6
34509 summe(lin)=summe(lin)+g(j)
34510 160 CONTINUE
34511 170 CONTINUE
34512 summe(0)=0d0
34513 summe(nn)=0d0
34514 gam = alphaw * alphas * pysimp(summe,smin,smax,nn)
34515 &/ (16d0 * paru(1) * paru(102) * xmglu**3)
34516
34517 RETURN
34518 END
34519
34520C*********************************************************************
34521
34522C...PYTBBC
34523C...Calculates the three-body decay of gluinos into
34524C...charginos and third generation fermions.
34525
34526 SUBROUTINE pytbbc(I,NN,XMGLU,GAM)
34527
34528C...Double precision and integer declarations.
34529 IMPLICIT DOUBLE PRECISION(a-h, o-z)
34530 IMPLICIT INTEGER(I-N)
34531 INTEGER PYK,PYCHGE,PYCOMP
34532C...Parameter statement to help give large particle numbers.
34533 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
34534C...Commonblocks.
34535 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34536 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34537 common/pymssm/imss(0:99),rmss(0:99)
34538 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
34539 &sfmix(16,4)
34540 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
34541
34542C...Local variables.
34543 EXTERNAL pysimp,pylamf
34544 DOUBLE PRECISION PYSIMP,PYLAMF
34545 INTEGER I,NN,LIN
34546 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
34547 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
34548 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
34549 DOUBLE PRECISION SUMME(0:100),A(4,8)
34550 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
34551 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
34552 DOUBLE PRECISION XMGLU,GAM
34553 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
34554 &ddd(2),eee(2),fff(2)
34555 SAVE xx1,xx2,aaa,bbb,ccc,ddd,eee,fff
34556 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
34557 DOUBLE PRECISION AMC(2),AMN(4)
34558 SAVE amc,amn
34559 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
34560 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
34561 SAVE amsb,amst
34562 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
34563 LOGICAL IFIRST
34564 SAVE ifirst
34565 DATA ifirst/.true./
34566
34567 tanb=rmss(5)
34568 sinb=tanb/sqrt(1d0+tanb**2)
34569 cosb=sinb/tanb
34570 xw=paru(102)
34571 sinw=sqrt(xw)
34572 cosw=sqrt(1d0-xw)
34573 amw=pmas(24,1)
34574 cosc=sfmix(5,1)
34575 sinc=sfmix(5,3)
34576 cosa=sfmix(6,1)
34577 sina=sfmix(6,3)
34578 ambot=0d0
34579 amtop=pyrnmt(pmas(6,1))
34580 w2=sqrt(2d0)
34581 amw=pmas(24,1)
34582 fakt1=ambot/w2/amw/cosb
34583 fakt2=amtop/w2/amw/sinb
34584 IF(ifirst) THEN
34585 amc(1)=smw(1)
34586 amc(2)=smw(2)
34587 DO 100 jj=1,2
34588 ccc(jj)=fakt1*umix(jj,2)*sinc-umix(jj,1)*cosc
34589 eee(jj)=fakt2*vmix(jj,2)*cosc
34590 ddd(jj)=fakt1*umix(jj,2)*cosc+umix(jj,1)*sinc
34591 fff(jj)=fakt2*vmix(jj,2)*sinc
34592 xx1(jj)=fakt2*vmix(jj,2)*sina-vmix(jj,1)*cosa
34593 aaa(jj)=fakt1*umix(jj,2)*cosa
34594 xx2(jj)=fakt2*vmix(jj,2)*cosa+vmix(jj,1)*sina
34595 bbb(jj)=fakt1*umix(jj,2)*sina
34596 100 CONTINUE
34597 amst(1)=pmas(pycomp(ksusy1+6),1)
34598 amst(2)=pmas(pycomp(ksusy2+6),1)
34599 amsb(1)=pmas(pycomp(ksusy1+5),1)
34600 amsb(2)=pmas(pycomp(ksusy2+5),1)
34601 ifirst=.false.
34602 ENDIF
34603 amtop=pmas(6,1)
34604
34605 ulr(1)=xx1(i)*xx1(i)+aaa(i)*aaa(i)
34606 ulr(2)=xx2(i)*xx2(i)+bbb(i)*bbb(i)
34607 vlr(1)=ccc(i)*ccc(i)+eee(i)*eee(i)
34608 vlr(2)=ddd(i)*ddd(i)+fff(i)*fff(i)
34609
34610 cos2a=cosa**2-sina**2
34611 sin2a=sina*cosa*2d0
34612 cos2c=cosc**2-sinc**2
34613 sin2c=sinc*cosc*2d0
34614
34615 xmg=xmglu
34616 xmt=amtop
34617 xmb=0d0
34618 xmr=amc(i)
34619 xmg2=xmg*xmg
34620 alphaw=pyalem(xmg2)
34621 alphas=pyalps(xmg2)
34622 xmt2=xmt*xmt
34623 xmb2=xmb*xmb
34624 xmr2=xmr*xmr
34625 xmq2=xmg2+xmt2+xmb2+xmr2
34626 xmq4=xmg*xmt*xmb*xmr
34627 xmq3=xmg2*xmr2+xmt2*xmb2
34628 xmgbtr=(xmg2+xmb2)*(xmt2+xmr2)
34629 xmgtbr=(xmg2+xmt2)*(xmb2+xmr2)
34630
34631 xmst(1)=amst(1)*amst(1)
34632 xmst(2)=amst(1)*amst(1)
34633 xmst(3)=amst(2)*amst(2)
34634 xmst(4)=amst(2)*amst(2)
34635 xmsb(1)=amsb(1)*amsb(1)
34636 xmsb(2)=amsb(2)*amsb(2)
34637 xmsb(3)=amsb(1)*amsb(1)
34638 xmsb(4)=amsb(2)*amsb(2)
34639
34640 a(1,1)=-cosa*sinc*ccc(i)*aaa(i)-sina*cosc*eee(i)*xx1(i)
34641 a(1,2)=xmg*xmb*(cosa*cosc*ccc(i)*aaa(i)+sina*sinc*eee(i)*xx1(i))
34642 a(1,3)=-xmg*xmr*(cosa*cosc*ccc(i)*xx1(i)+sina*sinc*eee(i)*aaa(i))
34643 a(1,4)=xmb*xmr*(cosa*sinc*ccc(i)*xx1(i)+sina*cosc*eee(i)*aaa(i))
34644 a(1,5)=xmg*xmt*(cosa*cosc*eee(i)*xx1(i)+sina*sinc*ccc(i)*aaa(i))
34645 a(1,6)=-xmt*xmb*(cosa*sinc*eee(i)*xx1(i)+sina*cosc*ccc(i)*aaa(i))
34646 a(1,7)=xmt*xmr*(cosa*sinc*eee(i)*aaa(i)+sina*cosc*ccc(i)*xx1(i))
34647 a(1,8)=-xmq4*(cosa*cosc*eee(i)*aaa(i)+sina*sinc*ccc(i)*xx1(i))
34648
34649 a(2,1)=-cosa*cosc*ddd(i)*aaa(i)-sina*sinc*fff(i)*xx1(i)
34650 a(2,2)=-xmg*xmb*(cosa*sinc*ddd(i)*aaa(i)+sina*cosc*fff(i)*xx1(i))
34651 a(2,3)=xmg*xmr*(cosa*sinc*ddd(i)*xx1(i)+sina*cosc*fff(i)*aaa(i))
34652 a(2,4)=xmb*xmr*(cosa*cosc*ddd(i)*xx1(i)+sina*sinc*fff(i)*aaa(i))
34653 a(2,5)=xmg*xmt*(cosa*sinc*fff(i)*xx1(i)+sina*cosc*ddd(i)*aaa(i))
34654 a(2,6)=xmt*xmb*(cosa*cosc*fff(i)*xx1(i)+sina*sinc*ddd(i)*aaa(i))
34655 a(2,7)=-xmt*xmr*(cosa*cosc*fff(i)*aaa(i)+sina*sinc*ddd(i)*xx1(i))
34656 a(2,8)=-xmq4*(cosa*sinc*fff(i)*aaa(i)+sina*cosc*ddd(i)*xx1(i))
34657
34658 a(3,1)=-cosa*cosc*eee(i)*xx2(i)-sina*sinc*ccc(i)*bbb(i)
34659 a(3,2)=xmg*xmb*(cosa*sinc*eee(i)*xx2(i)+sina*cosc*ccc(i)*bbb(i))
34660 a(3,3)=xmg*xmr*(cosa*sinc*eee(i)*bbb(i)+sina*cosc*ccc(i)*xx2(i))
34661 a(3,4)=-xmb*xmr*(cosa*cosc*eee(i)*bbb(i)+sina*sinc*ccc(i)*xx2(i))
34662 a(3,5)=-xmg*xmt*(cosa*sinc*ccc(i)*bbb(i)+sina*cosc*eee(i)*xx2(i))
34663 a(3,6)=xmt*xmb*(cosa*cosc*ccc(i)*bbb(i)+sina*sinc*eee(i)*xx2(i))
34664 a(3,7)=xmt*xmr*(cosa*cosc*ccc(i)*xx2(i)+sina*sinc*eee(i)*bbb(i))
34665 a(3,8)=-xmq4*(cosa*sinc*ccc(i)*xx2(i)+sina*cosc*eee(i)*bbb(i))
34666
34667 a(4,1)=-cosa*sinc*fff(i)*xx2(i)-sina*cosc*ddd(i)*bbb(i)
34668 a(4,2)=-xmg*xmb*(cosa*cosc*fff(i)*xx2(i)+sina*sinc*ddd(i)*bbb(i))
34669 a(4,3)=-xmg*xmr*(cosa*cosc*fff(i)*bbb(i)+sina*sinc*ddd(i)*xx2(i))
34670 a(4,4)=-xmb*xmr*(cosa*sinc*fff(i)*bbb(i)+sina*cosc*ddd(i)*xx2(i))
34671 a(4,5)=-xmg*xmt*(cosa*cosc*ddd(i)*bbb(i)+sina*sinc*fff(i)*xx2(i))
34672 a(4,6)=-xmt*xmb*(cosa*sinc*ddd(i)*bbb(i)+sina*cosc*fff(i)*xx2(i))
34673 a(4,7)=-xmt*xmr*(cosa*sinc*ddd(i)*xx2(i)+sina*cosc*fff(i)*bbb(i))
34674 a(4,8)=-xmq4*(cosa*cosc*ddd(i)*xx2(i)+sina*sinc*fff(i)*bbb(i))
34675
34676 smax=(xmg-abs(xmr))**2
34677 smin=(xmb+xmt)**2+0.1d0
34678
34679 DO 120 lin=0,nn-1
34680 sbar=smin+dble(lin)*(smax-smin)/dble(nn)
34681 am=(xmg2-xmr2)*(xmt2-xmb2)/2d0/sbar
34682 grs=sbar-xmq2
34683 w=pylamf(sbar,xmb2,xmt2)*pylamf(sbar,xmg2,xmr2)
34684 w=dsqrt(w)/2d0/sbar
34685 ant1=log(abs((grs/2d0+am+xmst(1)-w)/(grs/2d0+am+xmst(1)+w)))
34686 ant2=log(abs((grs/2d0+am+xmst(3)-w)/(grs/2d0+am+xmst(3)+w)))
34687 anb1=log(abs((grs/2d0-am+xmsb(1)-w)/(grs/2d0-am+xmsb(1)+w)))
34688 anb2=log(abs((grs/2d0-am+xmsb(2)-w)/(grs/2d0-am+xmsb(2)+w)))
34689 summe(lin)=-ulr(1)*w+(ulr(1)*(xmq2/2d0-xmst(1)-xmg*xmt*sin2a)
34690 & +2d0*xx1(i)*aaa(i)*xmr*xmb)*ant1
34691 & +(ulr(1)/2d0*(xmst(1)*(xmq2-xmst(1))-xmgtbr
34692 & -2d0*xmg*xmt*sin2a*(xmst(1)-xmb2-xmr2))
34693 & +2d0*xx1(i)*aaa(i)*xmr*xmb*(xmst(1)-xmg2-xmt2)
34694 & +4d0*sin2a*xx1(i)*aaa(i)*xmq4)
34695 & *(1d0/(grs/2d0+am+xmst(1)-w)-1d0/(grs/2d0+am+xmst(1)+w))
34696 summe(lin)=summe(lin)-ulr(2)*w
34697 & +(ulr(2)*(xmq2/2d0-xmst(3)+xmg*xmt*sin2a)
34698 & -2d0*xx2(i)*bbb(i)*xmr*xmb)*ant2
34699 & +(ulr(2)/2d0*(xmst(3)*(xmq2-xmst(3))-xmgtbr
34700 & +2d0*xmg*xmt*sin2a*(xmst(3)-xmb2-xmr2))
34701 & -2d0*xx2(i)*bbb(i)*xmr*xmb*(xmst(3)-xmg2-xmt2)
34702 & +4d0*sin2a*xx2(i)*bbb(i)*xmq4)
34703 & *(1d0/(grs/2d0+am+xmst(3)-w)-1d0/(grs/2d0+am+xmst(3)+w))
34704 summe(lin)=summe(lin)-vlr(1)*w
34705 & +(vlr(1)*(xmq2/2d0-xmsb(1)-xmg*xmb*sin2c)
34706 & +2d0*ccc(i)*eee(i)*xmr*xmt)*anb1
34707 & +(vlr(1)/2d0*(xmsb(1)*(xmq2-xmsb(1))-xmgbtr
34708 & -2d0*xmg*xmb*sin2c*(xmsb(1)-xmt2-xmr2))
34709 & +2d0*ccc(i)*eee(i)*xmr*xmt*(xmsb(1)-xmg2-xmb2)
34710 & +4d0*sin2c*ccc(i)*eee(i)*xmq4)
34711 & *(1d0/(grs/2d0-am+xmsb(1)-w)-1d0/(grs/2d0-am+xmsb(1)+w))
34712 summe(lin)=summe(lin)-vlr(2)*w
34713 & +(vlr(2)*(xmq2/2d0-xmsb(2)+xmg*xmb*sin2c)
34714 & -2d0*ddd(i)*fff(i)*xmr*xmt)*anb2
34715 & +(vlr(2)/2d0*(xmsb(2)*(xmq2-xmsb(2))-xmgbtr
34716 & +2d0*xmg*xmb*sin2c*(xmsb(2)-xmt2-xmr2))
34717 & -2d0*ddd(i)*fff(i)*xmr*xmt*(xmsb(2)-xmg2-xmb2)
34718 & +4d0*sin2c*ddd(i)*fff(i)*xmq4)
34719 & *(1d0/(grs/2d0-am+xmsb(2)-w)-1d0/(grs/2d0-am+xmsb(2)+w))
34720 summe(lin)=summe(lin)+2d0*xmg*xmt*cos2a/(xmst(3)-xmst(1))
34721 & *((aaa(i)*bbb(i)-xx1(i)*xx2(i))
34722 & *((xmst(3)-xmb2-xmr2)*ant2-(xmst(1)-xmb2-xmr2)*ant1)
34723 & +2d0*(aaa(i)*xx2(i)-xx1(i)*bbb(i))*xmb*xmr*(ant2-ant1))
34724 summe(lin)=summe(lin)+2d0*xmg*xmb*cos2c/(xmsb(2)-xmsb(1))
34725 & *((eee(i)*fff(i)-ccc(i)*ddd(i))
34726 & *((xmsb(2)-xmt2-xmr2)*anb2-(xmsb(1)-xmt2-xmr2)*anb1)
34727 & +2d0*(eee(i)*ddd(i)-ccc(i)*fff(i))*xmt*xmr*(anb2-anb1))
34728 DO 110 j=1,4
34729 summe(lin)=summe(lin)-2d0*a(j,1)*w
34730 & +((-a(j,1)*(xmsb(j)*(grs+xmsb(j))+xmq3)
34731 & +a(j,2)*(xmsb(j)-xmt2-xmr2)+a(j,3)*(sbar-xmb2-xmt2)
34732 & +a(j,4)*(xmsb(j)+sbar-xmb2-xmr2)
34733 & -a(j,5)*(xmsb(j)+sbar-xmg2-xmt2)+a(j,6)*(xmg2+xmr2-sbar)
34734 & -a(j,7)*(xmsb(j)-xmg2-xmb2)+2d0*a(j,8))
34735 & *log(abs((grs/2d0+xmsb(j)-am-w)/(grs/2d0+xmsb(j)-am+w)))
34736 & -(a(j,1)*(xmst(j)*(grs+xmst(j))+xmq3)
34737 & +a(j,2)*(xmst(j)+sbar-xmg2-xmb2)-a(j,3)*(sbar-xmb2-xmt2)
34738 & +a(j,4)*(xmst(j)-xmg2-xmt2)-a(j,5)*(xmst(j)-xmr2-xmb2)
34739 & -a(j,6)*(xmg2+xmr2-sbar)
34740 & -a(j,7)*(xmst(j)+sbar-xmt2-xmr2)-2d0*a(j,8))
34741 & *log(abs((grs/2d0+xmst(j)+am-w)/(grs/2d0+xmst(j)+am+w))))
34742 & /(grs+xmsb(j)+xmst(j))
34743 110 CONTINUE
34744 120 CONTINUE
34745 summe(nn)=0d0
34746 gam= alphaw * alphas * pysimp(summe,smin,smax,nn)
34747 &/ (16d0 * paru(1) * paru(102) * xmglu**3)
34748
34749 RETURN
34750 END
34751
34752C*********************************************************************
34753
34754C...PYNJDC
34755C...Calculates decay widths for the neutralinos (admixtures of
34756C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
34757
34758C...Input: KCIN = KF code for particle
34759C...Output: XLAM = widths
34760C... IDLAM = KF codes for decay particles
34761C... IKNT = number of decay channels defined
34762C...AUTHOR: STEPHEN MRENNA
34763C...Last change:
34764C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
34765C...when CHIGAMMA .NE. 0
34766C...10 FEB 96: Calculate this decay for small tan(beta)
34767
34768 SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)
34769
34770C...Double precision and integer declarations.
34771 IMPLICIT DOUBLE PRECISION(a-h, o-z)
34772 IMPLICIT INTEGER(I-N)
34773 INTEGER PYK,PYCHGE,PYCOMP
34774C...Parameter statement to help give large particle numbers.
34775 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
34776C...Commonblocks.
34777 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34778 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34779 common/pymssm/imss(0:99),rmss(0:99)
34780 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
34781 &sfmix(16,4)
34782 common/pyints/xxm(20)
34783 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/
34784
34785C...Local variables.
34786 INTEGER KFIN,KCIN
34787 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
34788 &xmz,xmz2,axmj,axmi
34789 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
34790 DOUBLE PRECISION S12MIN,S12MAX
34791 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
34792 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
34793 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
34794 DOUBLE PRECISION PYX2XH,PYX2XG
34795 DOUBLE PRECISION XLAM(0:200)
34796 INTEGER IDLAM(200,3)
34797 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
34798 INTEGER ITH(3),KF1,KF2
34799 INTEGER ITHC
34800 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
34801 DOUBLE PRECISION SR2
34802 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
34803 DOUBLE PRECISION GAMCON,XMT1,XMT2
34804 DOUBLE PRECISION PYALEM,PI,PYALPS
34805 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
34806 DOUBLE PRECISION RAT1,RAT2
34807 DOUBLE PRECISION T3T,CA,CB,FCOL
34808 DOUBLE PRECISION ALFA,BETA,TANB
34809 DOUBLE PRECISION PYXXGA
34810 EXTERNAL pyxxw5,pygaus,pyxxz5
34811 DOUBLE PRECISION PYXXW5,PYGAUS,PYXXZ5
34812 DOUBLE PRECISION PREC
34813 INTEGER KFNCHI(4),KFCCHI(2)
34814 DATA etah/1d0,1d0,-1d0/
34815 DATA ith/25,35,36/
34816 DATA ithc/37/
34817 DATA prec/1d-2/
34818 DATA pi/3.141592654d0/
34819 DATA sr2/1.4142136d0/
34820 DATA kfnchi/1000022,1000023,1000025,1000035/
34821 DATA kfcchi/1000024,1000037/
34822
34823C...COUNT THE NUMBER OF DECAY MODES
34824 lknt=0
34825
34826 xmw=pmas(24,1)
34827 xmw2=xmw**2
34828 xmz=pmas(23,1)
34829 xmz2=xmz**2
34830 xw=1d0-xmw2/xmz2
34831 tanw = sqrt(xw/(1d0-xw))
34832
34833C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
34834 kcin=pycomp(kfin)
34835 ix=1
34836 IF(kfin.EQ.kfnchi(2)) ix=2
34837 IF(kfin.EQ.kfnchi(3)) ix=3
34838 IF(kfin.EQ.kfnchi(4)) ix=4
34839
34840 xmi=smz(ix)
34841 xmi2=xmi**2
34842 axmi=abs(xmi)
34843 aem=pyalem(xmi2)
34844 as =pyalps(xmi2)
34845 c1=aem/xw
34846 xmi3=abs(xmi**3)
34847
34848 tanb=rmss(5)
34849 beta=atan(tanb)
34850 alfa=rmss(18)
34851 cbeta=cos(beta)
34852 sbeta=tanb*cbeta
34853 calfa=cos(alfa)
34854 salfa=sin(alfa)
34855
34856C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
34857 IF(ix.EQ.1.AND.imss(11).EQ.0) GOTO 260
34858
34859C...FORCE CHI0_2 -> CHI0_1 + GAMMA
34860 IF(ix.EQ.2 .AND. imss(10).NE.0 ) THEN
34861 xmj=smz(1)
34862 axmj=abs(xmj)
34863 lknt=lknt+1
34864 gamcon=aem**3/8d0/pi/xmw2/xw
34865 xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
34866 xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
34867 xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
34868 idlam(lknt,1)=ksusy1+22
34869 idlam(lknt,2)=22
34870 idlam(lknt,3)=0
34871 WRITE(mstu(11),*) 'FORCED N2 -> N1 + GAMMA ',xlam(lknt)
34872 GOTO 300
34873 ENDIF
34874
34875C...GRAVITINO DECAY MODES
34876
34877 IF(imss(11).EQ.1) THEN
34878 xmp=rmss(29)
34879 idg=39+ksusy1
34880 xmgr=pmas(pycomp(idg),1)
34881 sinw=sqrt(xw)
34882 cosw=sqrt(1d0-xw)
34883 xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
34884 IF(axmi.GT.xmgr+pmas(22,1)) THEN
34885 lknt=lknt+1
34886 idlam(lknt,1)=idg
34887 idlam(lknt,2)=22
34888 idlam(lknt,3)=0
34889 xlam(lknt)=xfac*(zmix(ix,1)*cosw+zmix(ix,2)*sinw)**2
34890 ENDIF
34891 IF(axmi.GT.xmgr+xmz) THEN
34892 lknt=lknt+1
34893 idlam(lknt,1)=idg
34894 idlam(lknt,2)=23
34895 idlam(lknt,3)=0
34896 xlam(lknt)=xfac*((zmix(ix,1)*sinw-zmix(ix,2)*cosw)**2 +
34897 $ .5d0*(zmix(ix,3)*cbeta-zmix(ix,4)*sbeta)**2)*(1d0-xmz2/xmi2)**4
34898 ENDIF
34899 IF(axmi.GT.xmgr+pmas(25,1)) THEN
34900 lknt=lknt+1
34901 idlam(lknt,1)=idg
34902 idlam(lknt,2)=25
34903 idlam(lknt,3)=0
34904 xlam(lknt)=xfac*((zmix(ix,3)*salfa-zmix(ix,4)*calfa)**2)*
34905 $ .5d0*(1d0-pmas(25,1)**2/xmi2)**4
34906 ENDIF
34907 IF(axmi.GT.xmgr+pmas(35,1)) THEN
34908 lknt=lknt+1
34909 idlam(lknt,1)=idg
34910 idlam(lknt,2)=35
34911 idlam(lknt,3)=0
34912 xlam(lknt)=xfac*((zmix(ix,3)*calfa+zmix(ix,4)*salfa)**2)*
34913 $ .5d0*(1d0-pmas(35,1)**2/xmi2)**4
34914 ENDIF
34915 IF(axmi.GT.xmgr+pmas(36,1)) THEN
34916 lknt=lknt+1
34917 idlam(lknt,1)=idg
34918 idlam(lknt,2)=36
34919 idlam(lknt,3)=0
34920 xlam(lknt)=xfac*((zmix(ix,3)*sbeta+zmix(ix,4)*cbeta)**2)*
34921 $ .5d0*(1d0-pmas(36,1)**2/xmi2)**4
34922 ENDIF
34923 IF(ix.EQ.1) GOTO 260
34924 ENDIF
34925
34926 DO 180 ij=1,ix-1
34927 xmj=smz(ij)
34928 axmj=abs(xmj)
34929 xmj2=xmj**2
34930
34931C...CHI0_I -> CHI0_J + GAMMA
34932 IF(axmi.GE.axmj.AND.sbeta/cbeta.LE.2d0) THEN
34933 rat1=zmix(ij,1)**2+zmix(ij,2)**2
34934 rat1=rat1/( 1d-6+zmix(ix,3)**2+zmix(ix,4)**2 )
34935 rat2=zmix(ix,1)**2+zmix(ix,2)**2
34936 rat2=rat2/( 1d-6+zmix(ij,3)**2+zmix(ij,4)**2 )
34937 IF((rat1.GT. 0.90d0 .AND. rat1.LT. 1.10d0) .OR.
34938 & (rat2.GT. 0.90d0 .AND. rat2.LT. 1.10d0)) THEN
34939 lknt=lknt+1
34940 idlam(lknt,1)=kfnchi(ij)
34941 idlam(lknt,2)=22
34942 idlam(lknt,3)=0
34943 gamcon=aem**3/8d0/pi/xmw2/xw
34944 xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
34945 xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
34946 xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
34947 ENDIF
34948 ENDIF
34949
34950C...CHI0_I -> CHI0_J + Z0
34951 IF(axmi.GE.axmj+xmz) THEN
34952 lknt=lknt+1
34953 gl=-0.5d0*(zmix(ix,3)*zmix(ij,3)-zmix(ix,4)*zmix(ij,4))
34954 gr=-gl
34955 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gl,gr)
34956 idlam(lknt,1)=kfnchi(ij)
34957 idlam(lknt,2)=23
34958 idlam(lknt,3)=0
34959 ELSEIF(axmi.GE.axmj) THEN
34960 fid=11
34961 ei=kchg(fid,1)/3d0
34962 t3=-0.5d0
34963 xxm(1)=0d0
34964 xxm(2)=xmj
34965 xxm(3)=0d0
34966 xxm(4)=xmi
34967 xxm(5)=pmas(pycomp(ksusy1+11),1)
34968 xxm(6)=pmas(pycomp(ksusy2+11),1)
34969 xxm(7)=xmz
34970 xxm(8)=pmas(23,2)
34971 xxm(9)=-0.5d0*(zmix(ix,3)*zmix(ij,3)-zmix(ix,4)*zmix(ij,4))
34972 xxm(10)=-xxm(9)
34973 xxm(11)=(t3-ei*xw)/(1d0-xw)
34974 xxm(12)=-ei*xw/(1d0-xw)
34975 xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
34976 xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
34977 xxm(15)=sr2*tanw*(ei*zmix(ix,1))
34978 xxm(16)=sr2*tanw*(ei*zmix(ij,1))
34979 s12min=0d0
34980 s12max=(axmi-axmj)**2
34981
34982C...CHARGED LEPTONS
34983 IF( xxm(5).LT.axmi ) THEN
34984 xxm(5)=1d6
34985 ENDIF
34986 IF(xxm(6).LT.axmi ) THEN
34987 xxm(6)=1d6
34988 ENDIF
34989 IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
34990 lknt=lknt+1
34991 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
34992 & pygaus(pyxxz5,s12min,s12max,1d-3)
34993 idlam(lknt,1)=kfnchi(ij)
34994 idlam(lknt,2)=11
34995 idlam(lknt,3)=-11
34996 IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
34997 lknt=lknt+1
34998 xlam(lknt)=xlam(lknt-1)
34999 idlam(lknt,1)=kfnchi(ij)
35000 idlam(lknt,2)=13
35001 idlam(lknt,3)=-13
35002 ENDIF
35003 ENDIF
35004 100 CONTINUE
35005 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
35006 xxm(5)=pmas(pycomp(ksusy1+15),1)
35007 xxm(6)=pmas(pycomp(ksusy2+15),1)
35008 ELSE
35009 xxm(6)=pmas(pycomp(ksusy1+15),1)
35010 xxm(5)=pmas(pycomp(ksusy2+15),1)
35011 ENDIF
35012 IF( xxm(5).LT.axmi ) THEN
35013 xxm(5)=1d6
35014 ENDIF
35015 IF(xxm(6).LT.axmi ) THEN
35016 xxm(6)=1d6
35017 ENDIF
35018
35019 IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
35020 lknt=lknt+1
35021 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35022 & pygaus(pyxxz5,s12min,s12max,1d-3)
35023 idlam(lknt,1)=kfnchi(ij)
35024 idlam(lknt,2)=15
35025 idlam(lknt,3)=-15
35026 ENDIF
35027
35028C...NEUTRINOS
35029 110 CONTINUE
35030 fid=12
35031 ei=kchg(fid,1)/3d0
35032 t3=0.5d0
35033 xxm(5)=pmas(pycomp(ksusy1+12),1)
35034 xxm(6)=1d6
35035 xxm(11)=(t3-ei*xw)/(1d0-xw)
35036 xxm(12)=-ei*xw/(1d0-xw)
35037 xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
35038 xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
35039 xxm(15)=sr2*tanw*(ei*zmix(ix,1))
35040 xxm(16)=sr2*tanw*(ei*zmix(ij,1))
35041
35042 IF( xxm(5).LT.axmi ) THEN
35043 xxm(5)=1d6
35044 ENDIF
35045
35046 lknt=lknt+1
35047 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35048 & pygaus(pyxxz5,s12min,s12max,1d-3)
35049 idlam(lknt,1)=kfnchi(ij)
35050 idlam(lknt,2)=12
35051 idlam(lknt,3)=-12
35052 lknt=lknt+1
35053 xlam(lknt)=xlam(lknt-1)
35054 idlam(lknt,1)=kfnchi(ij)
35055 idlam(lknt,2)=14
35056 idlam(lknt,3)=-14
35057 120 CONTINUE
35058 xxm(5)=pmas(pycomp(ksusy1+16),1)
35059 IF( xxm(5).LT.axmi ) THEN
35060 xxm(5)=1d6
35061 ENDIF
35062 lknt=lknt+1
35063 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35064 & pygaus(pyxxz5,s12min,s12max,1d-3)
35065 idlam(lknt,1)=kfnchi(ij)
35066 idlam(lknt,2)=16
35067 idlam(lknt,3)=-16
35068
35069C...D-TYPE QUARKS
35070 130 CONTINUE
35071 xxm(5)=pmas(pycomp(ksusy1+1),1)
35072 xxm(6)=pmas(pycomp(ksusy2+1),1)
35073 fid=1
35074 ei=kchg(fid,1)/3d0
35075 t3=-0.5d0
35076
35077 xxm(11)=(t3-ei*xw)/(1d0-xw)
35078 xxm(12)=-ei*xw/(1d0-xw)
35079 xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
35080 xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
35081 xxm(15)=sr2*tanw*(ei*zmix(ix,1))
35082 xxm(16)=sr2*tanw*(ei*zmix(ij,1))
35083
35084 IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) GOTO 140
35085 IF( xxm(5).LT.axmi ) THEN
35086 xxm(5)=1d6
35087 ELSEIF( xxm(6).LT.axmi ) THEN
35088 xxm(6)=1d6
35089 ENDIF
35090 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
35091 lknt=lknt+1
35092 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35093 & pygaus(pyxxz5,s12min,s12max,1d-3)*3d0
35094 idlam(lknt,1)=kfnchi(ij)
35095 idlam(lknt,2)=1
35096 idlam(lknt,3)=-1
35097 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
35098 lknt=lknt+1
35099 xlam(lknt)=xlam(lknt-1)
35100 idlam(lknt,1)=kfnchi(ij)
35101 idlam(lknt,2)=3
35102 idlam(lknt,3)=-3
35103 ENDIF
35104 ENDIF
35105 140 CONTINUE
35106 IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
35107 xxm(5)=pmas(pycomp(ksusy1+5),1)
35108 xxm(6)=pmas(pycomp(ksusy2+5),1)
35109 ELSE
35110 xxm(6)=pmas(pycomp(ksusy1+5),1)
35111 xxm(5)=pmas(pycomp(ksusy2+5),1)
35112 ENDIF
35113 IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) GOTO 150
35114 IF(xxm(5).LT.axmi) THEN
35115 xxm(5)=1d6
35116 ELSEIF(xxm(6).LT.axmi) THEN
35117 xxm(6)=1d6
35118 ENDIF
35119 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
35120 lknt=lknt+1
35121 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35122 & pygaus(pyxxz5,s12min,s12max,1d-3)*3d0
35123 idlam(lknt,1)=kfnchi(ij)
35124 idlam(lknt,2)=5
35125 idlam(lknt,3)=-5
35126 ENDIF
35127
35128C...U-TYPE QUARKS
35129 150 CONTINUE
35130 xxm(5)=pmas(pycomp(ksusy1+2),1)
35131 xxm(6)=pmas(pycomp(ksusy2+2),1)
35132 fid=2
35133 ei=kchg(fid,1)/3d0
35134 t3=0.5d0
35135
35136 xxm(11)=(t3-ei*xw)/(1d0-xw)
35137 xxm(12)=-ei*xw/(1d0-xw)
35138 xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
35139 xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
35140 xxm(15)=sr2*tanw*(ei*zmix(ix,1))
35141 xxm(16)=sr2*tanw*(ei*zmix(ij,1))
35142
35143 IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) GOTO 160
35144 IF(xxm(5).LT.axmi) THEN
35145 xxm(5)=1d6
35146 ELSEIF(xxm(6).LT.axmi) THEN
35147 xxm(6)=1d6
35148 ENDIF
35149 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
35150 lknt=lknt+1
35151 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35152 & pygaus(pyxxz5,s12min,s12max,1d-3)*3d0
35153 idlam(lknt,1)=kfnchi(ij)
35154 idlam(lknt,2)=2
35155 idlam(lknt,3)=-2
35156 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
35157 lknt=lknt+1
35158 xlam(lknt)=xlam(lknt-1)
35159 idlam(lknt,1)=kfnchi(ij)
35160 idlam(lknt,2)=4
35161 idlam(lknt,3)=-4
35162 ENDIF
35163 ENDIF
35164 160 CONTINUE
35165 ENDIF
35166
35167C...CHI0_I -> CHI0_J + H0_K
35168 eh(1)=sin(alfa)
35169 eh(2)=cos(alfa)
35170 eh(3)=-sin(beta)
35171 dh(1)=cos(alfa)
35172 dh(2)=-sin(alfa)
35173 dh(3)=cos(beta)
35174
35175 qij=zmix(ix,3)*zmix(ij,2)+zmix(ij,3)*zmix(ix,2)-
35176 & tanw*(zmix(ix,3)*zmix(ij,1)+zmix(ij,3)*zmix(ix,1))
35177 rij=zmix(ix,4)*zmix(ij,2)+zmix(ij,4)*zmix(ix,2)-
35178 & tanw*(zmix(ix,4)*zmix(ij,1)+zmix(ij,4)*zmix(ix,1))
35179
35180 DO 170 ih=1,3
35181 xmh=pmas(ith(ih),1)
35182 xmh2=xmh**2
35183 IF(axmi.GE.axmj+xmh) THEN
35184 lknt=lknt+1
35185 xl=pylamf(xmi2,xmj2,xmh2)
35186 f21k=0.5d0*(qij*eh(ih)+rij*dh(ih))
35187 f12k=f21k
35188C...SIGN OF MASSES I,J
35189 xmk=xmj
35190 IF(ih.EQ.3) xmk=-xmk
35191 xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,f12k,f21k)
35192 idlam(lknt,1)=kfnchi(ij)
35193 idlam(lknt,2)=ith(ih)
35194 idlam(lknt,3)=0
35195 ENDIF
35196 170 CONTINUE
35197 180 CONTINUE
35198
35199C...CHI0_I -> CHI+_J + W-
35200 DO 220 ij=1,2
35201 xmj=smw(ij)
35202 axmj=abs(xmj)
35203 xmj2=xmj**2
35204 IF(axmi.GE.axmj+xmw) THEN
35205 lknt=lknt+1
35206 gl=zmix(ix,2)*vmix(ij,1)-zmix(ix,4)*vmix(ij,2)/sr2
35207 gr=zmix(ix,2)*umix(ij,1)+zmix(ix,3)*umix(ij,2)/sr2
35208 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gl,gr)
35209 idlam(lknt,1)=kfcchi(ij)
35210 idlam(lknt,2)=-24
35211 idlam(lknt,3)=0
35212 lknt=lknt+1
35213 xlam(lknt)=xlam(lknt-1)
35214 idlam(lknt,1)=-kfcchi(ij)
35215 idlam(lknt,2)=24
35216 idlam(lknt,3)=0
35217 ELSEIF(axmi.GE.axmj) THEN
35218 s12min=0d0
35219 s12max=(axmi-axmj)**2
35220 xxm(5)=zmix(ix,2)*vmix(ij,1)-zmix(ix,4)*vmix(ij,2)/sr2
35221 xxm(6)=zmix(ix,2)*umix(ij,1)+zmix(ix,3)*umix(ij,2)/sr2
35222
35223C...LEPTONS
35224 fid=11
35225 ei=kchg(fid,1)/3d0
35226 t3=-0.5d0
35227 xxm(7)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*umix(ij,1)
35228 fid=12
35229 ei=kchg(fid,1)/3d0
35230 t3=0.5d0
35231 xxm(8)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*vmix(ij,1)
35232
35233 xxm(1)=0d0
35234 xxm(2)=xmj
35235 xxm(3)=0d0
35236 xxm(4)=xmi
35237 xxm(9)=pmas(24,1)
35238 xxm(10)=pmas(24,2)
35239 xxm(11)=pmas(pycomp(ksusy1+11),1)
35240 xxm(12)=pmas(pycomp(ksusy1+12),1)
35241 IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) GOTO 190
35242 IF(xxm(11).LT.axmi) THEN
35243 xxm(11)=1d6
35244 ELSEIF(xxm(12).LT.axmi) THEN
35245 xxm(12)=1d6
35246 ENDIF
35247 IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
35248 lknt=lknt+1
35249 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35250 & pygaus(pyxxw5,s12min,s12max,prec)
35251 idlam(lknt,1)=kfcchi(ij)
35252 idlam(lknt,2)=11
35253 idlam(lknt,3)=-12
35254 lknt=lknt+1
35255 xlam(lknt)=xlam(lknt-1)
35256 idlam(lknt,1)=-idlam(lknt-1,1)
35257 idlam(lknt,2)=-idlam(lknt-1,2)
35258 idlam(lknt,3)=-idlam(lknt-1,3)
35259 IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
35260 lknt=lknt+1
35261 xlam(lknt)=xlam(lknt-1)
35262 idlam(lknt,1)=kfcchi(ij)
35263 idlam(lknt,2)=13
35264 idlam(lknt,3)=-14
35265 lknt=lknt+1
35266 xlam(lknt)=xlam(lknt-1)
35267 idlam(lknt,1)=-idlam(lknt-1,1)
35268 idlam(lknt,2)=-idlam(lknt-1,2)
35269 idlam(lknt,3)=-idlam(lknt-1,3)
35270 ENDIF
35271 ENDIF
35272 190 CONTINUE
35273 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
35274 xxm(11)=pmas(pycomp(ksusy1+15),1)
35275 xxm(12)=pmas(pycomp(ksusy1+16),1)
35276 ELSE
35277 xxm(11)=pmas(pycomp(ksusy2+15),1)
35278 xxm(12)=pmas(pycomp(ksusy1+16),1)
35279 ENDIF
35280
35281 IF(xxm(11).LT.axmi) THEN
35282 xxm(11)=1d6
35283 ENDIF
35284 IF(xxm(12).LT.axmi) THEN
35285 xxm(12)=1d6
35286 ENDIF
35287 IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
35288 lknt=lknt+1
35289 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35290 & pygaus(pyxxw5,s12min,s12max,prec)
35291 xlam(lknt)=xlam(lknt-1)
35292 idlam(lknt,1)=kfcchi(ij)
35293 idlam(lknt,2)=15
35294 idlam(lknt,3)=-16
35295 lknt=lknt+1
35296 xlam(lknt)=xlam(lknt-1)
35297 idlam(lknt,1)=-idlam(lknt-1,1)
35298 idlam(lknt,2)=-idlam(lknt-1,2)
35299 idlam(lknt,3)=-idlam(lknt-1,3)
35300 ENDIF
35301
35302C...NOW, DO THE QUARKS
35303 200 CONTINUE
35304 fid=1
35305 ei=kchg(fid,1)/3d0
35306 t3=-0.5d0
35307 xxm(7)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*umix(ij,1)
35308 fid=2
35309 ei=kchg(fid,1)/3d0
35310 t3=0.5d0
35311 xxm(8)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*vmix(ij,1)
35312
35313 xxm(11)=pmas(pycomp(ksusy1+1),1)
35314 xxm(12)=pmas(pycomp(ksusy1+2),1)
35315 IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) GOTO 210
35316 IF(xxm(11).LT.axmi) THEN
35317 xxm(11)=1d6
35318 ELSEIF(xxm(12).LT.axmi) THEN
35319 xxm(12)=1d6
35320 ENDIF
35321 IF(axmi.GE.axmj+pmas(2,1)+pmas(1,1)) THEN
35322 lknt=lknt+1
35323 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
35324 & pygaus(pyxxw5,s12min,s12max,prec)
35325 idlam(lknt,1)=kfcchi(ij)
35326 idlam(lknt,2)=1
35327 idlam(lknt,3)=-2
35328 lknt=lknt+1
35329 xlam(lknt)=xlam(lknt-1)
35330 idlam(lknt,1)=-idlam(lknt-1,1)
35331 idlam(lknt,2)=-idlam(lknt-1,2)
35332 idlam(lknt,3)=-idlam(lknt-1,3)
35333 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
35334 lknt=lknt+1
35335 xlam(lknt)=xlam(lknt-1)
35336 idlam(lknt,1)=kfcchi(ij)
35337 idlam(lknt,2)=3
35338 idlam(lknt,3)=-4
35339 lknt=lknt+1
35340 xlam(lknt)=xlam(lknt-1)
35341 idlam(lknt,1)=-idlam(lknt-1,1)
35342 idlam(lknt,2)=-idlam(lknt-1,2)
35343 idlam(lknt,3)=-idlam(lknt-1,3)
35344 ENDIF
35345 ENDIF
35346 210 CONTINUE
35347 ENDIF
35348 220 CONTINUE
35349 230 CONTINUE
35350
35351C...CHI0_I -> CHI+_I + H-
35352 DO 240 ij=1,2
35353 xmj=smw(ij)
35354 axmj=abs(xmj)
35355 xmj2=xmj**2
35356 xmhp=pmas(ithc,1)
35357 xmhp2=xmhp**2
35358 IF(axmi.GE.axmj+xmhp) THEN
35359 lknt=lknt+1
35360 gl=cbeta*(zmix(ix,4)*vmix(ij,1)+(zmix(ix,2)+
35361 & zmix(ix,1)*tanw)*vmix(ij,2)/sr2)
35362 gr=sbeta*(zmix(ix,3)*umix(ij,1)-(zmix(ix,2)+
35363 & zmix(ix,1)*tanw)*umix(ij,2)/sr2)
35364 xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gl,gr)
35365 idlam(lknt,1)=kfcchi(ij)
35366 idlam(lknt,2)=-ithc
35367 idlam(lknt,3)=0
35368 lknt=lknt+1
35369 xlam(lknt)=xlam(lknt-1)
35370 idlam(lknt,1)=-idlam(lknt-1,1)
35371 idlam(lknt,2)=-idlam(lknt-1,2)
35372 idlam(lknt,3)=-idlam(lknt-1,3)
35373 ELSE
35374
35375 ENDIF
35376 240 CONTINUE
35377
35378C...2-BODY DECAYS TO FERMION SFERMION
35379 DO 250 j=1,16
35380 IF(j.GE.7.AND.j.LE.10) GOTO 250
35381 kf1=ksusy1+j
35382 kf2=ksusy2+j
35383 xmsf1=pmas(pycomp(kf1),1)
35384 xmsf2=pmas(pycomp(kf2),1)
35385 xmf=pmas(j,1)
35386 IF(j.LE.6) THEN
35387 fcol=3d0
35388 ELSE
35389 fcol=1d0
35390 ENDIF
35391
35392 ei=kchg(j,1)/3d0
35393 t3t=sign(1d0,ei)
35394 IF(j.EQ.12.OR.j.EQ.14.OR.j.EQ.16) t3t=1d0
35395 IF(mod(j,2).EQ.0) THEN
35396 bl=t3t*zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-t3t)
35397 al=xmf*zmix(ix,4)/xmw/sbeta
35398 ar=-2d0*ei*tanw*zmix(ix,1)
35399 br=al
35400 ELSE
35401 bl=t3t*zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-t3t)
35402 al=xmf*zmix(ix,3)/xmw/cbeta
35403 ar=-2d0*ei*tanw*zmix(ix,1)
35404 br=al
35405 ENDIF
35406
35407C...D~ D_L
35408 IF(axmi.GE.xmf+xmsf1) THEN
35409 lknt=lknt+1
35410 xma2=xmsf1**2
35411 xmb2=xmf**2
35412 xl=pylamf(xmi2,xma2,xmb2)
35413 ca=al*sfmix(j,1)+ar*sfmix(j,2)
35414 cb=bl*sfmix(j,1)+br*sfmix(j,2)
35415 xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
35416 & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
35417 idlam(lknt,1)=kf1
35418 idlam(lknt,2)=-j
35419 idlam(lknt,3)=0
35420 lknt=lknt+1
35421 xlam(lknt)=xlam(lknt-1)
35422 idlam(lknt,1)=-idlam(lknt-1,1)
35423 idlam(lknt,2)=-idlam(lknt-1,2)
35424 idlam(lknt,3)=0
35425 ENDIF
35426
35427C...D~ D_R
35428 IF(axmi.GE.xmf+xmsf2) THEN
35429 lknt=lknt+1
35430 xma2=xmsf2**2
35431 xmb2=xmf**2
35432 ca=al*sfmix(j,3)+ar*sfmix(j,4)
35433 cb=bl*sfmix(j,3)+br*sfmix(j,4)
35434 xl=pylamf(xmi2,xma2,xmb2)
35435 xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
35436 & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
35437 idlam(lknt,1)=kf2
35438 idlam(lknt,2)=-j
35439 idlam(lknt,3)=0
35440 lknt=lknt+1
35441 xlam(lknt)=xlam(lknt-1)
35442 idlam(lknt,1)=-idlam(lknt-1,1)
35443 idlam(lknt,2)=-idlam(lknt-1,2)
35444 idlam(lknt,3)=0
35445 ENDIF
35446 250 CONTINUE
35447 260 CONTINUE
35448C...3-BODY DECAY TO Q Q~ GLUINO
35449 xmj=pmas(pycomp(ksusy1+21),1)
35450 IF(axmi.GE.xmj) THEN
35451 axmj=abs(xmj)
35452 xxm(1)=0d0
35453 xxm(2)=xmj
35454 xxm(3)=0d0
35455 xxm(4)=xmi
35456 xxm(5)=pmas(pycomp(ksusy1+1),1)
35457 xxm(6)=pmas(pycomp(ksusy2+1),1)
35458 xxm(7)=1d6
35459 xxm(8)=0d0
35460 xxm(9)=0d0
35461 xxm(10)=0d0
35462 s12min=0d0
35463 s12max=(axmi-axmj)**2
35464C...ALL QUARKS BUT T
35465 xxm(11)=0d0
35466 xxm(12)=0d0
35467 xxm(13)=1d0
35468 xxm(14)=-sr2*(-0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
35469 xxm(15)=1d0
35470 xxm(16)=sr2*(-tanw*zmix(ix,1)/3d0)
35471 IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) GOTO 270
35472 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
35473 lknt=lknt+1
35474 xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
35475 & pygaus(pyxxz5,s12min,s12max,1d-3)
35476 idlam(lknt,1)=ksusy1+21
35477 idlam(lknt,2)=1
35478 idlam(lknt,3)=-1
35479 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
35480 lknt=lknt+1
35481 xlam(lknt)=xlam(lknt-1)
35482 idlam(lknt,1)=ksusy1+21
35483 idlam(lknt,2)=3
35484 idlam(lknt,3)=-3
35485 ENDIF
35486 ENDIF
35487 270 CONTINUE
35488 IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
35489 xxm(5)=pmas(pycomp(ksusy1+5),1)
35490 xxm(6)=pmas(pycomp(ksusy2+5),1)
35491 ELSE
35492 xxm(6)=pmas(pycomp(ksusy1+5),1)
35493 xxm(5)=pmas(pycomp(ksusy2+5),1)
35494 ENDIF
35495 IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) GOTO 280
35496 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
35497 lknt=lknt+1
35498 xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
35499 & pygaus(pyxxz5,s12min,s12max,1d-3)
35500 idlam(lknt,1)=ksusy1+21
35501 idlam(lknt,2)=5
35502 idlam(lknt,3)=-5
35503 ENDIF
35504C...U-TYPE QUARKS
35505 280 CONTINUE
35506 xxm(5)=pmas(pycomp(ksusy1+2),1)
35507 xxm(6)=pmas(pycomp(ksusy2+2),1)
35508 xxm(13)=1d0
35509 xxm(14)=-sr2*(0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
35510 xxm(15)=1d0
35511 xxm(16)=sr2*(2d0*tanw*zmix(ix,1)/3d0)
35512 IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) GOTO 290
35513 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
35514 lknt=lknt+1
35515 xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
35516 & pygaus(pyxxz5,s12min,s12max,1d-3)
35517 idlam(lknt,1)=ksusy1+21
35518 idlam(lknt,2)=2
35519 idlam(lknt,3)=-2
35520 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
35521 lknt=lknt+1
35522 xlam(lknt)=xlam(lknt-1)
35523 idlam(lknt,1)=ksusy1+21
35524 idlam(lknt,2)=4
35525 idlam(lknt,3)=-4
35526 ENDIF
35527 ENDIF
35528 290 CONTINUE
35529 ENDIF
35530
35531 300 iknt=lknt
35532 xlam(0)=0d0
35533 DO 310 i=1,iknt
35534 IF(xlam(i).LT.0d0) xlam(i)=0d0
35535 xlam(0)=xlam(0)+xlam(i)
35536 310 CONTINUE
35537 IF(xlam(0).EQ.0d0) xlam(0)=1d-6
35538
35539 RETURN
35540 END
35541
35542C*********************************************************************
35543
35544C...PYCJDC
35545C...Calculate decay widths for the charginos (admixtures of
35546C...charged Wino and charged Higgsino.
35547
35548C...Input: KCIN = KF code for particle
35549C...Output: XLAM = widths
35550C... IDLAM = KF codes for decay particles
35551C... IKNT = number of decay channels defined
35552C...AUTHOR: STEPHEN MRENNA
35553C...Last change:
35554C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
35555C...when CHIENU .NE. 0
35556
35557 SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)
35558
35559C...Double precision and integer declarations.
35560 IMPLICIT DOUBLE PRECISION(a-h, o-z)
35561 IMPLICIT INTEGER(I-N)
35562 INTEGER PYK,PYCHGE,PYCOMP
35563C...Parameter statement to help give large particle numbers.
35564 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
35565C...Commonblocks.
35566 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
35567 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
35568 common/pymssm/imss(0:99),rmss(0:99)
35569 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
35570 &sfmix(16,4)
35571 common/pyints/xxm(20)
35572 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/
35573
35574C...Local variables.
35575 INTEGER KFIN,KCIN
35576 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
35577 &xmz,xmz2,axmj,axmi
35578 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
35579 DOUBLE PRECISION S12MIN,S12MAX
35580 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
35581 DOUBLE PRECISION PYLAMF,XL
35582 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
35583 DOUBLE PRECISION PYX2XH,PYX2XG
35584 DOUBLE PRECISION XLAM(0:200)
35585 INTEGER IDLAM(200,3)
35586 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
35587 INTEGER ITH(3)
35588 INTEGER ITHC
35589 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
35590 DOUBLE PRECISION SR2
35591 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
35592
35593 DOUBLE PRECISION PYALEM,PI,PYALPS
35594 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
35595 DOUBLE PRECISION CA,CB,FCOL
35596 INTEGER KF1,KF2,ISF
35597 INTEGER KFNCHI(4),KFCCHI(2)
35598
35599 DOUBLE PRECISION TEMP
35600 EXTERNAL pygaus,pyxxz5,pyxxw5,pyxxz2
35601 DOUBLE PRECISION PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
35602 DOUBLE PRECISION PREC
35603 DATA ith/25,35,36/
35604 DATA ithc/37/
35605 DATA etah/1d0,1d0,-1d0/
35606 DATA sr2/1.4142136d0/
35607 DATA pi/3.141592654d0/
35608 DATA prec/1d-2/
35609 DATA kfnchi/1000022,1000023,1000025,1000035/
35610 DATA kfcchi/1000024,1000037/
35611
35612C...COUNT THE NUMBER OF DECAY MODES
35613 lknt=0
35614 xmw=pmas(24,1)
35615 xmw2=xmw**2
35616 xmz=pmas(23,1)
35617 xmz2=xmz**2
35618 xw=1d0-xmw2/xmz2
35619 tanw = sqrt(xw/(1d0-xw))
35620
35621C...1 OR 2 DEPENDING ON CHARGINO TYPE
35622 ix=1
35623 IF(kfin.EQ.kfcchi(2)) ix=2
35624 kcin=pycomp(kfin)
35625
35626 xmi=smw(ix)
35627 xmi2=xmi**2
35628 axmi=abs(xmi)
35629 aem=pyalem(xmi2)
35630 as =pyalps(xmi2)
35631 c1=aem/xw
35632 xmi3=abs(xmi**3)
35633 tanb=rmss(5)
35634 beta=atan(tanb)
35635 cbeta=cos(beta)
35636 sbeta=tanb*cbeta
35637 alfa=rmss(18)
35638
35639C...GRAVITINO DECAY MODES
35640
35641 IF(imss(11).EQ.1) THEN
35642 xmp=rmss(29)
35643 idg=39+ksusy1
35644 xmgr=pmas(pycomp(idg),1)
35645 sinw=sqrt(xw)
35646 cosw=sqrt(1d0-xw)
35647 xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
35648 IF(axmi.GT.xmgr+xmw) THEN
35649 lknt=lknt+1
35650 idlam(lknt,1)=idg
35651 idlam(lknt,2)=24
35652 idlam(lknt,3)=0
35653 xlam(lknt)=xfac*(.5d0*(vmix(ix,1)**2+umix(ix,1)**2)+
35654 & .5d0*((vmix(ix,2)*sbeta)**2+(umix(ix,2)*cbeta)**2))*
35655 & (1d0-xmw2/xmi2)**4
35656 ENDIF
35657 IF(axmi.GT.xmgr+pmas(37,1)) THEN
35658 lknt=lknt+1
35659 idlam(lknt,1)=idg
35660 idlam(lknt,2)=37
35661 idlam(lknt,3)=0
35662 xlam(lknt)=xfac*(.5d0*((vmix(ix,2)*cbeta)**2+
35663 & (umix(ix,2)*sbeta)**2))
35664 & *(1d0-pmas(37,1)**2/xmi2)**4
35665 ENDIF
35666 ENDIF
35667
35668C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
35669 IF(ix.EQ.1) GOTO 150
35670 xmj=smw(1)
35671 axmj=abs(xmj)
35672 xmj2=xmj**2
35673
35674C...CHI_2+ -> CHI_1+ + Z0
35675 IF(axmi.GE.axmj+xmz) THEN
35676 lknt=lknt+1
35677 gl=vmix(2,1)*vmix(1,1)+0.5d0*vmix(2,2)*vmix(1,2)
35678 gr=umix(2,1)*umix(1,1)+0.5d0*umix(2,2)*umix(1,2)
35679 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gl,gr)
35680 idlam(lknt,1)=kfcchi(1)
35681 idlam(lknt,2)=23
35682 idlam(lknt,3)=0
35683
35684C...CHARGED LEPTONS
35685 ELSEIF(axmi.GE.axmj) THEN
35686 xxm(5)=-(vmix(2,1)*vmix(1,1)+0.5d0*vmix(2,2)*vmix(1,2))
35687 xxm(6)=-(umix(2,1)*umix(1,1)+0.5d0*umix(2,2)*umix(1,2))
35688 xxm(9)=xmz
35689 xxm(10)=pmas(23,2)
35690 xxm(1)=0d0
35691 xxm(2)=xmj
35692 xxm(3)=0d0
35693 xxm(4)=xmi
35694 s12min=0d0
35695 s12max=(axmj-axmi)**2
35696 xxm(7)= (-0.5d0+xw)/(1d0-xw)
35697 xxm(8)= xw/(1d0-xw)
35698 xxm(11)=pmas(pycomp(ksusy1+12),1)
35699 xxm(12)=vmix(2,1)*vmix(1,1)
35700 IF( xxm(11).LT.axmi ) THEN
35701 xxm(11)=1d6
35702 ENDIF
35703 IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
35704 lknt=lknt+1
35705 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35706 & pygaus(pyxxz2,s12min,s12max,prec)
35707 idlam(lknt,1)=kfcchi(1)
35708 idlam(lknt,2)=11
35709 idlam(lknt,3)=-11
35710 IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
35711 lknt=lknt+1
35712 xlam(lknt)=xlam(lknt-1)
35713 idlam(lknt,1)=kfcchi(1)
35714 idlam(lknt,2)=13
35715 idlam(lknt,3)=-13
35716 IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
35717 lknt=lknt+1
35718 xlam(lknt)=xlam(lknt-1)
35719 idlam(lknt,1)=kfcchi(1)
35720 idlam(lknt,2)=15
35721 idlam(lknt,3)=-15
35722 ENDIF
35723 ENDIF
35724 ENDIF
35725
35726C...NEUTRINOS
35727 100 CONTINUE
35728 xxm(7)= (0.5d0)/(1d0-xw)
35729 xxm(8)= 0d0
35730 xxm(11)=pmas(pycomp(ksusy1+11),1)
35731 xxm(12)=umix(2,1)*umix(1,1)
35732 IF( xxm(11).LT.axmi ) THEN
35733 xxm(11)=1d6
35734 ENDIF
35735 IF(axmi.GE.axmj+2d0*pmas(12,1)) THEN
35736 lknt=lknt+1
35737 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
35738 & pygaus(pyxxz2,s12min,s12max,prec)
35739 idlam(lknt,1)=kfcchi(1)
35740 idlam(lknt,2)=12
35741 idlam(lknt,3)=-12
35742 lknt=lknt+1
35743 xlam(lknt)=xlam(lknt-1)
35744 idlam(lknt,1)=kfcchi(1)
35745 idlam(lknt,2)=14
35746 idlam(lknt,3)=-14
35747 lknt=lknt+1
35748 xlam(lknt)=xlam(lknt-1)
35749 idlam(lknt,1)=kfcchi(1)
35750 idlam(lknt,2)=16
35751 idlam(lknt,3)=-16
35752 ENDIF
35753
35754C...D-TYPE QUARKS
35755 110 CONTINUE
35756 xxm(7)= (-0.5d0+xw/3d0)/(1d0-xw)
35757 xxm(8)= xw/3d0/(1d0-xw)
35758 xxm(11)=pmas(pycomp(ksusy1+2),1)
35759 xxm(12)=vmix(2,1)*vmix(1,1)
35760 IF( xxm(11).LT.axmi ) GOTO 120
35761 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
35762 lknt=lknt+1
35763 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
35764 & pygaus(pyxxz2,s12min,s12max,prec)
35765 idlam(lknt,1)=kfcchi(1)
35766 idlam(lknt,2)=1
35767 idlam(lknt,3)=-1
35768 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
35769 lknt=lknt+1
35770 xlam(lknt)=xlam(lknt-1)
35771 idlam(lknt,1)=kfcchi(1)
35772 idlam(lknt,2)=3
35773 idlam(lknt,3)=-3
35774 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
35775 lknt=lknt+1
35776 xlam(lknt)=xlam(lknt-1)
35777 idlam(lknt,1)=kfcchi(1)
35778 idlam(lknt,2)=5
35779 idlam(lknt,3)=-5
35780 ENDIF
35781 ENDIF
35782 ENDIF
35783
35784C...U-TYPE QUARKS
35785 120 CONTINUE
35786 xxm(7)= (0.5d0-2d0*xw/3d0)/(1d0-xw)
35787 xxm(8)= -2d0*xw/3d0/(1d0-xw)
35788 xxm(11)=pmas(pycomp(ksusy1+1),1)
35789 xxm(12)=umix(2,1)*umix(1,1)
35790 IF( xxm(11).LT.axmi ) GOTO 130
35791 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
35792 lknt=lknt+1
35793 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
35794 & pygaus(pyxxz2,s12min,s12max,prec)
35795 idlam(lknt,1)=kfcchi(1)
35796 idlam(lknt,2)=2
35797 idlam(lknt,3)=-2
35798 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
35799 lknt=lknt+1
35800 xlam(lknt)=xlam(lknt-1)
35801 idlam(lknt,1)=kfcchi(1)
35802 idlam(lknt,2)=4
35803 idlam(lknt,3)=-4
35804 ENDIF
35805 ENDIF
35806 130 CONTINUE
35807 ENDIF
35808
35809C...CHI_2+ -> CHI_1+ + H0_K
35810 eh(2)=cos(alfa)
35811 eh(1)=sin(alfa)
35812 eh(3)=-sbeta
35813 dh(2)=-sin(alfa)
35814 dh(1)=cos(alfa)
35815 dh(3)=cos(beta)
35816 DO 140 ih=1,3
35817 xmh=pmas(ith(ih),1)
35818 xmh2=xmh**2
35819C...NO 3-BODY OPTION
35820 IF(axmi.GE.axmj+xmh) THEN
35821 lknt=lknt+1
35822 xl=pylamf(xmi2,xmj2,xmh2)
35823 f21k=(vmix(2,1)*umix(1,2)*eh(ih) -
35824 & vmix(2,2)*umix(1,1)*dh(ih))/sr2
35825 f12k=(vmix(1,1)*umix(2,2)*eh(ih) -
35826 & vmix(1,2)*umix(2,1)*dh(ih))/sr2
35827 xmk=xmj*etah(ih)
35828 xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,f12k,f21k)
35829 idlam(lknt,1)=kfcchi(1)
35830 idlam(lknt,2)=ith(ih)
35831 idlam(lknt,3)=0
35832 ENDIF
35833 140 CONTINUE
35834
35835C...CHI1 JUMPS TO HERE
35836 150 CONTINUE
35837
35838C...CHI+_I -> CHI0_J + W+
35839 DO 180 ij=1,4
35840 xmj=smz(ij)
35841 axmj=abs(xmj)
35842 xmj2=xmj**2
35843 IF(axmi.GE.axmj+xmw) THEN
35844 lknt=lknt+1
35845 gl=zmix(ij,2)*vmix(ix,1)-zmix(ij,4)*vmix(ix,2)/sr2
35846 gr=zmix(ij,2)*umix(ix,1)+zmix(ij,3)*umix(ix,2)/sr2
35847 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gl,gr)
35848 idlam(lknt,1)=kfnchi(ij)
35849 idlam(lknt,2)=24
35850 idlam(lknt,3)=0
35851
35852C...LEPTONS
35853 ELSEIF(axmi.GE.axmj) THEN
35854 xmf1=0d0
35855 xmf2=0d0
35856 s12min=(xmf1+xmf2)**2
35857 s12max=(axmj-axmi)**2
35858 xxm(5)=-1d0/sr2*zmix(ij,4)*vmix(ix,2)+zmix(ij,2)*vmix(ix,1)
35859 xxm(6)= 1d0/sr2*zmix(ij,3)*umix(ix,2)+zmix(ij,2)*umix(ix,1)
35860 fid=11
35861 ei=kchg(fid,1)/3d0
35862 t3=-0.5d0
35863 xxm(7)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*umix(ix,1)
35864 fid=12
35865 ei=kchg(fid,1)/3d0
35866 t3=0.5d0
35867 xxm(8)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*vmix(ix,1)
35868
35869 xxm(4)=xmi
35870 xxm(1)=xmf1
35871 xxm(2)=xmj
35872 xxm(3)=xmf2
35873 xxm(9)=pmas(24,1)
35874 xxm(10)=pmas(24,2)
35875 xxm(11)=pmas(pycomp(ksusy1+11),1)
35876 xxm(12)=pmas(pycomp(ksusy1+12),1)
35877
35878C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
35879C...--> 1/(16PI)/M**3*(AEM/XW)**2
35880
35881 IF(xxm(11).LT.axmi) THEN
35882 xxm(11)=1d6
35883 ENDIF
35884 IF(xxm(12).LT.axmi) THEN
35885 xxm(12)=1d6
35886 ENDIF
35887 IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
35888 lknt=lknt+1
35889 temp=pygaus(pyxxw5,s12min,s12max,prec)
35890 xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
35891 idlam(lknt,1)=kfnchi(ij)
35892 idlam(lknt,2)=-11
35893 idlam(lknt,3)=12
35894
35895C...ONLY DECAY CHI+1 -> E+ NU_E
35896 IF( imss(12).NE. 0 ) GOTO 220
35897 IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
35898 lknt=lknt+1
35899 xxm(11)=pmas(pycomp(ksusy1+13),1)
35900 xxm(12)=pmas(pycomp(ksusy1+14),1)
35901 IF(xxm(11).LT.axmi) THEN
35902 xxm(11)=1d6
35903 ELSEIF(xxm(12).LT.axmi) THEN
35904 xxm(12)=1d6
35905 ENDIF
35906 temp=pygaus(pyxxw5,s12min,s12max,prec)
35907 xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
35908 idlam(lknt,1)=kfnchi(ij)
35909 idlam(lknt,2)=-13
35910 idlam(lknt,3)=14
35911 IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
35912 lknt=lknt+1
35913 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
35914 xxm(11)=pmas(pycomp(ksusy1+15),1)
35915 ELSE
35916 xxm(11)=pmas(pycomp(ksusy2+15),1)
35917 ENDIF
35918 xxm(12)=pmas(pycomp(ksusy1+16),1)
35919 IF(xxm(11).LT.axmi) THEN
35920 xxm(11)=1d6
35921 ENDIF
35922 IF(xxm(12).LT.axmi) THEN
35923 xxm(12)=1d6
35924 ENDIF
35925 temp=pygaus(pyxxw5,s12min,s12max,prec)
35926 xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
35927 idlam(lknt,1)=kfnchi(ij)
35928 idlam(lknt,2)=-15
35929 idlam(lknt,3)=16
35930 ENDIF
35931 ENDIF
35932 ENDIF
35933
35934C...NOW, DO THE QUARKS
35935 160 CONTINUE
35936 fid=1
35937 ei=kchg(fid,1)/3d0
35938 t3=-0.5d0
35939 xxm(7)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*umix(ix,1)
35940 fid=1
35941 ei=kchg(fid,1)/3d0
35942 t3=0.5d0
35943 xxm(8)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*vmix(ix,1)
35944
35945 xxm(11)=pmas(pycomp(ksusy1+1),1)
35946 xxm(12)=pmas(pycomp(ksusy1+2),1)
35947 IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) GOTO 170
35948 IF(xxm(11).LT.axmi) THEN
35949 xxm(11)=1d6
35950 ELSEIF(xxm(12).LT.axmi) THEN
35951 xxm(12)=1d6
35952 ENDIF
35953 IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
35954 lknt=lknt+1
35955 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
35956 & pygaus(pyxxw5,s12min,s12max,prec)
35957 idlam(lknt,1)=kfnchi(ij)
35958 idlam(lknt,2)=-1
35959 idlam(lknt,3)=2
35960 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
35961 lknt=lknt+1
35962 xlam(lknt)=xlam(lknt-1)
35963 idlam(lknt,1)=kfnchi(ij)
35964 idlam(lknt,2)=-3
35965 idlam(lknt,3)=4
35966 ENDIF
35967 ENDIF
35968 170 CONTINUE
35969 ENDIF
35970 180 CONTINUE
35971
35972C...CHI+_I -> CHI0_J + H+
35973 DO 190 ij=1,4
35974 xmj=smz(ij)
35975 axmj=abs(xmj)
35976 xmj2=xmj**2
35977 xmhp=pmas(ithc,1)
35978 xmhp2=xmhp**2
35979 IF(axmi.GE.axmj+xmhp) THEN
35980 lknt=lknt+1
35981 gl=cbeta*(zmix(ij,4)*vmix(ix,1)+(zmix(ij,2)+
35982 & zmix(ij,1)*tanw)*vmix(ix,2)/sr2)
35983 gr=sbeta*(zmix(ij,3)*umix(ix,1)-(zmix(ij,2)+
35984 & zmix(ij,1)*tanw)*umix(ix,2)/sr2)
35985 xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gl,gr)
35986 idlam(lknt,1)=kfnchi(ij)
35987 idlam(lknt,2)=ithc
35988 idlam(lknt,3)=0
35989 ELSE
35990
35991 ENDIF
35992 190 CONTINUE
35993
35994C...2-BODY DECAYS TO FERMION SFERMION
35995 DO 200 j=1,16
35996 IF(j.GE.7.AND.j.LE.10) GOTO 200
35997 IF(mod(j,2).EQ.0) THEN
35998 kf1=ksusy1+j-1
35999 ELSE
36000 kf1=ksusy1+j+1
36001 ENDIF
36002 kf2=kf1+ksusy1
36003 xmsf1=pmas(pycomp(kf1),1)
36004 xmsf2=pmas(pycomp(kf2),1)
36005 xmf=pmas(j,1)
36006 IF(j.LE.6) THEN
36007 fcol=3d0
36008 ELSE
36009 fcol=1d0
36010 ENDIF
36011
36012C...U~ D_L
36013 IF(mod(j,2).EQ.0) THEN
36014 xmfp=pmas(j-1,1)
36015 al=umix(ix,1)
36016 bl=-xmf*vmix(ix,2)/xmw/sbeta/sr2
36017 ar=-xmfp*umix(ix,2)/xmw/cbeta/sr2
36018 br=0d0
36019 isf=j-1
36020 ELSE
36021 xmfp=pmas(j+1,1)
36022 al=vmix(ix,1)
36023 bl=-xmf*umix(ix,2)/xmw/cbeta/sr2
36024 br=0d0
36025 ar=-xmfp*vmix(ix,2)/xmw/sbeta/sr2
36026 isf=j+1
36027 ENDIF
36028
36029C...~U_L D
36030 IF(axmi.GE.xmf+xmsf1) THEN
36031 lknt=lknt+1
36032 xma2=xmsf1**2
36033 xmb2=xmf**2
36034 xl=pylamf(xmi2,xma2,xmb2)
36035 ca=al*sfmix(isf,1)+ar*sfmix(isf,2)
36036 cb=bl*sfmix(isf,1)+br*sfmix(isf,2)
36037 xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
36038 & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
36039 idlam(lknt,3)=0
36040 IF(mod(j,2).EQ.0) THEN
36041 idlam(lknt,1)=-kf1
36042 idlam(lknt,2)=j
36043 ELSE
36044 idlam(lknt,1)=kf1
36045 idlam(lknt,2)=-j
36046 ENDIF
36047 ENDIF
36048
36049C...U~ D_R
36050 IF(axmi.GE.xmf+xmsf2) THEN
36051 lknt=lknt+1
36052 xma2=xmsf2**2
36053 xmb2=xmf**2
36054 ca=al*sfmix(isf,3)+ar*sfmix(isf,4)
36055 cb=bl*sfmix(isf,3)+br*sfmix(isf,4)
36056 xl=pylamf(xmi2,xma2,xmb2)
36057 xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
36058 & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
36059 idlam(lknt,3)=0
36060 IF(mod(j,2).EQ.0) THEN
36061 idlam(lknt,1)=-kf2
36062 idlam(lknt,2)=j
36063 ELSE
36064 idlam(lknt,1)=kf2
36065 idlam(lknt,2)=-j
36066 ENDIF
36067 ENDIF
36068 200 CONTINUE
36069
36070C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
36071C...A 2-BODY -- 2-BODY CHAIN
36072 xmj=pmas(pycomp(ksusy1+21),1)
36073 IF(axmi.GE.xmj) THEN
36074 axmj=abs(xmj)
36075 s12min=0d0
36076 s12max=(axmi-axmj)**2
36077 xxm(1)=0d0
36078 xxm(2)=xmj
36079 xxm(3)=0d0
36080 xxm(4)=xmi
36081 xxm(5)=0d0
36082 xxm(6)=0d0
36083 xxm(9)=1d6
36084 xxm(10)=0d0
36085 xxm(7)=umix(ix,1)*sr2
36086 xxm(8)=vmix(ix,1)*sr2
36087 xxm(11)=pmas(pycomp(ksusy1+1),1)
36088 xxm(12)=pmas(pycomp(ksusy1+2),1)
36089 IF( xxm(11).LT.axmi .OR. xxm(12).LT.axmi ) GOTO 210
36090 IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
36091 lknt=lknt+1
36092 xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
36093 & pygaus(pyxxw5,s12min,s12max,prec)
36094 idlam(lknt,1)=ksusy1+21
36095 idlam(lknt,2)=-1
36096 idlam(lknt,3)=2
36097 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
36098 lknt=lknt+1
36099 xlam(lknt)=xlam(lknt-1)
36100 idlam(lknt,1)=ksusy1+21
36101 idlam(lknt,2)=-3
36102 idlam(lknt,3)=4
36103 ENDIF
36104 ENDIF
36105 210 CONTINUE
36106 ENDIF
36107
36108 220 iknt=lknt
36109 xlam(0)=0d0
36110 DO 230 i=1,iknt
36111 xlam(0)=xlam(0)+xlam(i)
36112 IF(xlam(i).LT.0d0) THEN
36113 WRITE(mstu(11),*) ' XLAM(I) = ',xlam(i),kcin,
36114 & (idlam(i,j),j=1,3)
36115 xlam(i)=0d0
36116 ENDIF
36117 230 CONTINUE
36118 IF(xlam(0).EQ.0d0) THEN
36119 xlam(0)=1d-6
36120 WRITE(mstu(11),*) ' XLAM(0) = ',xlam(0)
36121 WRITE(mstu(11),*) lknt
36122 WRITE(mstu(11),*) (xlam(j),j=1,lknt)
36123 ENDIF
36124
36125 RETURN
36126 END
36127
36128C*********************************************************************
36129
36130C...PYXXZ5
36131C...Calculates chi0 -> chi0 + f + ~f.
36132
36133 FUNCTION pyxxz5(X)
36134
36135C...Double precision and integer declarations.
36136 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36137 IMPLICIT INTEGER(I-N)
36138 INTEGER PYK,PYCHGE,PYCOMP
36139C...Parameter statement to help give large particle numbers.
36140 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36141C...Commonblocks.
36142 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36143 common/pyints/xxm(20)
36144 SAVE /pydat1/,/pyints/
36145
36146C...Local variables.
36147 DOUBLE PRECISION PYXXZ5,X
36148 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
36149 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
36150 DOUBLE PRECISION SIJ
36151 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
36152 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
36153 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36154 INTEGER I
36155 DATA sr2/1.4142136d0/
36156
36157C...Statement functions.
36158C...Integral from x to y of (t-a)(b-t) dt.
36159 tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
36160C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36161 tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
36162 &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
36163C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36164 tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
36165 &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
36166C...Integral from x to y of (t-a)/(b-t) dt.
36167 utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
36168C...Integral from x to y of 1/(t-a) dt.
36169 tprop(x,y,a)=log(abs((x-a)/(y-a)))
36170
36171 xm12=xxm(1)**2
36172 xm22=xxm(2)**2
36173 xm32=xxm(3)**2
36174 s=xxm(4)**2
36175 s13=x
36176
36177 s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
36178 s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
36179 &( (x-xm22-s)**2 -4d0*xm22*s ) )
36180
36181 s23min=(s23ave-s23del)
36182 s23max=(s23ave+s23del)
36183
36184 xmv=xxm(7)
36185 xmg=xxm(8)
36186 xmsd=xxm(5)**2
36187 xmsu=xxm(6)**2
36188 ol=xxm(9)
36189 or=xxm(10)
36190 ol2=ol**2
36191 or2=or**2
36192 le=xxm(11)
36193 re=xxm(12)
36194 le2=le**2
36195 re2=re**2
36196 fli=xxm(13)
36197 flj=xxm(14)
36198 fri=xxm(15)
36199 frj=xxm(16)
36200
36201 wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
36202 sij=2d0*xxm(2)*xxm(4)*s13
36203
36204 IF(xmv.LE.1000d0) THEN
36205 ww=2d0*(le2+re2)*(ol2)*( 2d0*tint(s23max,s23min,xm22,s)
36206 & +sij*(s23max-s23min) )/wprop2
36207 IF(xxm(5).LE.10000d0) THEN
36208 wfl1=2d0*fli*flj*ol*le*( 2d0*tint2(s23max,s23min,xm22,s,xmsd)
36209 & + sij*tprop(s23max,s23min,xmsd) )
36210 wfl1=wfl1*(s13-xmv**2)/wprop2
36211 ELSE
36212 wfl1=0d0
36213 ENDIF
36214 IF(xxm(6).LE.10000d0) THEN
36215 wfl2=2d0*fri*frj*or*re*( 2d0*tint2(s23max,s23min,xm22,s,xmsu)
36216 & + sij*tprop(s23max,s23min,xmsu) )
36217 wfl2=wfl2*(s13-xmv**2)/wprop2
36218 ELSE
36219 wfl2=0d0
36220 ENDIF
36221 ELSE
36222 ww=0d0
36223 wfl1=0d0
36224 wfl2=0d0
36225 ENDIF
36226 IF(xxm(5).LE.10000d0) THEN
36227 wf1=0.5d0*(fli*flj)**2*( 2d0*tint3(s23max,s23min,xm22,s,xmsd)
36228 & + sij*utint(s23max,s23min,xmsd,xm22+s-s13-xmsd) )
36229 ELSE
36230 wf1=0d0
36231 ENDIF
36232 IF(xxm(6).LE.10000d0) THEN
36233 wf2=0.5d0*(fri*frj)**2*( 2d0*tint3(s23max,s23min,xm22,s,xmsu)
36234 & + sij*utint(s23max,s23min,xmsu,xm22+s-s13-xmsu) )
36235 ELSE
36236 wf2=0d0
36237 ENDIF
36238
36239C...WFL1=0.0
36240C...WFL2=0.0
36241 pyxxz5=(ww+wf1+wf2+wfl1+wfl2)
36242 IF(pyxxz5.LT.0d0) THEN
36243 WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ5 '
36244 WRITE(mstu(11),*) xxm(1),xxm(2),xxm(3),xxm(4)
36245 WRITE(mstu(11),*) (xxm(i),i=5,8)
36246 WRITE(mstu(11),*) (xxm(i),i=9,12)
36247 WRITE(mstu(11),*) (xxm(i),i=13,16)
36248 WRITE(mstu(11),*) ww,wf1,wf2,wfl1,wfl2
36249 WRITE(mstu(11),*) s23min,s23max
36250 pyxxz5=0d0
36251 ENDIF
36252
36253 RETURN
36254 END
36255
36256C*********************************************************************
36257
36258C...PYXXW5
36259C...Calculates chi0(+) -> chi+(0) + f + ~f'.
36260
36261 FUNCTION pyxxw5(X)
36262
36263C...Double precision and integer declarations.
36264 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36265 IMPLICIT INTEGER(I-N)
36266 INTEGER PYK,PYCHGE,PYCOMP
36267C...Parameter statement to help give large particle numbers.
36268 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36269C...Commonblocks.
36270 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36271 common/pyints/xxm(20)
36272 SAVE /pydat1/,/pyints/
36273
36274C...Local variables.
36275 DOUBLE PRECISION PYXXW5,X
36276 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
36277 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
36278 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
36279 DOUBLE PRECISION SIJ
36280 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36281 INTEGER IK
36282 SAVE ik
36283 DATA ik/0/
36284 DATA sr2/1.4142136d0/
36285
36286C...Statement functions.
36287C...Integral from x to y of (t-a)(b-t) dt.
36288 tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
36289C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36290 tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
36291 &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
36292C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36293 tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
36294 &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
36295C...Integral from x to y of (t-a)/(b-t) dt.
36296 utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
36297C...Integral from x to y of 1/(t-a) dt.
36298 tprop(x,y,a)=log(abs((x-a)/(y-a)))
36299
36300 xm12=xxm(1)**2
36301 xm22=xxm(2)**2
36302 xm32=xxm(3)**2
36303 s=xxm(4)**2
36304 s13=x
36305 IF(xxm(1).EQ.0.AND.xxm(3).EQ.0d0) THEN
36306 s23ave=0.5d0*(xm22+s-s13)
36307 s23del=0.5d0*sqrt( (x-xm22-s)**2-4d0*xm22*s )
36308 ELSE
36309 s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
36310 s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
36311 & ( (x-xm22-s)**2 -4d0*xm22*s ) )
36312 ENDIF
36313 s23min=(s23ave-s23del)
36314 s23max=(s23ave+s23del)
36315 IF(s23del.LT.1d-3) THEN
36316 pyxxw5=0d0
36317 RETURN
36318 ENDIF
36319 xmv=xxm(9)
36320 xmg=xxm(10)
36321 xmsd=xxm(11)**2
36322 xmsu=xxm(12)**2
36323 ol=xxm(5)
36324 or=xxm(6)
36325 fld=xxm(7)
36326 flu=xxm(8)
36327
36328 wprop2=((s13-xmv**2)**2+(xmv*xmg)**2)
36329 sij=s13*xxm(2)*xxm(4)
36330 IF(xmv.LE.1000d0) THEN
36331 ww=(or**2+ol**2)*tint(s23max,s23min,xm22,s)
36332 & -2d0*ol*or*sij*(s23max-s23min)
36333 ww=ww/wprop2
36334 IF(xxm(11).LE.10000d0) THEN
36335 wwd=ol*sij*tprop(s23max,s23min,xmsd)
36336 & -or*tint2(s23max,s23min,xm22,s,xmsd)
36337 wwd=-wwd*sr2*fld
36338 wwd=wwd*(s13-xmv**2)/wprop2
36339 ELSE
36340 wwd=0d0
36341 ENDIF
36342 IF(xxm(12).LE.10000d0) THEN
36343 wwu=or*sij*tprop(s23max,s23min,xmsu)
36344 & -ol*tint2(s23max,s23min,xm22,s,xmsu)
36345 wwu=wwu*sr2*flu
36346 wwu=wwu*(s13-xmv**2)/wprop2
36347 ELSE
36348 wwu=0d0
36349 ENDIF
36350 ELSE
36351 ww=0d0
36352 wwd=0d0
36353 wwu=0d0
36354 ENDIF
36355 IF(xxm(12).LE.10000d0) THEN
36356 wu=0.5d0*flu**2*tint3(s23max,s23min,xm22,s,xmsu)
36357 ELSE
36358 wu=0d0
36359 ENDIF
36360 IF(xxm(11).LE.10000d0) THEN
36361 wd=0.5d0*fld**2*tint3(s23max,s23min,xm22,s,xmsd)
36362 ELSE
36363 wd=0d0
36364 ENDIF
36365 IF(xxm(11).LE.10000d0.AND.xxm(12).LE.10000d0) THEN
36366 wud=flu*fld*sij*utint(s23max,s23min,xmsd,xm22+s-s13-xmsu)
36367 ELSE
36368 wud=0d0
36369 ENDIF
36370
36371 pyxxw5=ww+wu+wd+wwu+wwd+wud
36372
36373 IF(pyxxw5.LT.0d0) THEN
36374 IF(ik.EQ.0) THEN
36375 WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXW5 '
36376 WRITE(mstu(11),*) ww,wu,wd
36377 WRITE(mstu(11),*) wwd,wwu,wud
36378 WRITE(mstu(11),*) sqrt(s13)
36379 WRITE(mstu(11),*) tint(s23max,s23min,xm22,s)
36380 ik=1
36381 ENDIF
36382 pyxxw5=0d0
36383 ENDIF
36384
36385 RETURN
36386 END
36387
36388C*********************************************************************
36389
36390C...PYXXGA
36391C...Calculates chi0_i -> chi0_j + gamma.
36392
36393 FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)
36394
36395C...Double precision and integer declarations.
36396 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36397 IMPLICIT INTEGER(I-N)
36398 INTEGER PYK,PYCHGE,PYCOMP
36399
36400C...Local variables.
36401 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
36402 DOUBLE PRECISION F1,F2
36403
36404 f1=(1d0+xmtr/(1d0-xmtr)*log(xmtr))/(1d0-xmtr)
36405 f2=(1d0+xmtl/(1d0-xmtl)*log(xmtl))/(1d0-xmtl)
36406 pyxxga=c0*((xm1**2-xm2**2)/xm1)**3
36407 pyxxga=pyxxga*(2d0/3d0*(f1+f2)-13d0/12d0)**2
36408
36409 RETURN
36410 END
36411
36412C*********************************************************************
36413
36414C...PYX2XG
36415C...Calculates the decay rate for ino -> ino + gauge boson.
36416
36417 FUNCTION pyx2xg(C1,XM1,XM2,XM3,GL,GR)
36418
36419C...Double precision and integer declarations.
36420 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36421 IMPLICIT INTEGER(I-N)
36422 INTEGER PYK,PYCHGE,PYCOMP
36423
36424C...Local variables.
36425 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
36426 DOUBLE PRECISION XL,PYLAMF,C1
36427 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
36428
36429 xmi2=xm1**2
36430 xmi3=abs(xm1**3)
36431 xmj2=xm2**2
36432 xmv2=xm3**2
36433 xl=pylamf(xmi2,xmj2,xmv2)
36434 pyx2xg=c1/8d0/xmi3*sqrt(xl)
36435 &*((gl**2+gr**2)*(xl+3d0*xmv2*(xmi2+xmj2-xmv2))-
36436 &12d0*gl*gr*xm1*xm2*xmv2)
36437
36438 RETURN
36439 END
36440
36441C*********************************************************************
36442
36443C...PYX2XH
36444C...Calculates the decay rate for ino -> ino + H.
36445
36446 FUNCTION pyx2xh(C1,XM1,XM2,XM3,GL,GR)
36447
36448C...Double precision and integer declarations.
36449 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36450 IMPLICIT INTEGER(I-N)
36451 INTEGER PYK,PYCHGE,PYCOMP
36452
36453C...Local variables.
36454 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
36455 DOUBLE PRECISION XL,PYLAMF,C1
36456 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
36457
36458 xmi2=xm1**2
36459 xmi3=abs(xm1**3)
36460 xmj2=xm2**2
36461 xmv2=xm3**2
36462 xl=pylamf(xmi2,xmj2,xmv2)
36463 pyx2xh=c1/8d0/xmi3*sqrt(xl)
36464 &*((gl**2+gr**2)*(xmi2+xmj2-xmv2)+
36465 &4d0*gl*gr*xm1*xm2)
36466
36467 RETURN
36468 END
36469
36470C*********************************************************************
36471
36472C...PYXXZ2
36473C...Calculates chi+ -> chi+ + f + ~f.
36474
36475 FUNCTION pyxxz2(X)
36476
36477C...Double precision and integer declarations.
36478 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36479 IMPLICIT INTEGER(I-N)
36480 INTEGER PYK,PYCHGE,PYCOMP
36481C...Parameter statement to help give large particle numbers.
36482 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36483C...Commonblocks.
36484 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36485 common/pyints/xxm(20)
36486 SAVE /pydat1/,/pyints/
36487
36488C...Local variables.
36489 DOUBLE PRECISION PYXXZ2,X
36490 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
36491 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
36492 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
36493 DOUBLE PRECISION SIJ
36494 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
36495 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
36496 INTEGER I
36497 DATA sr2/1.4142136d0/
36498
36499C...Statement functions.
36500C...Integral from x to y of (t-a)(b-t) dt.
36501 tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
36502C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
36503 tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
36504 &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
36505C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
36506 tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
36507 &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
36508C...Integral from x to y of 1/(t-a) dt.
36509 tprop(x,y,a)=log(abs((x-a)/(y-a)))
36510
36511 xm12=xxm(1)**2
36512 xm22=xxm(2)**2
36513 xm32=xxm(3)**2
36514 s=xxm(4)**2
36515 s13=x
36516 IF(xxm(1).EQ.0.AND.xxm(3).EQ.0d0) THEN
36517 s23ave=0.5d0*(xm22+s-s13)
36518 s23del=0.5d0*sqrt( (x-xm22-s)**2-4d0*xm22*s )
36519 ELSE
36520 s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
36521 s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
36522 & ( (x-xm22-s)**2 -4d0*xm22*s ) )
36523 ENDIF
36524 s23min=(s23ave-s23del)
36525 s23max=(s23ave+s23del)
36526 IF(s23del.LT.1d-3) THEN
36527 pyxxz2=0d0
36528 RETURN
36529 ENDIF
36530
36531 xmv=xxm(9)
36532 xmg=xxm(10)
36533 xmsl=xxm(11)**2
36534 ol=xxm(5)
36535 or=xxm(6)
36536 ol2=ol**2
36537 or2=or**2
36538 le=xxm(7)
36539 re=xxm(8)
36540 le2=le**2
36541 re2=re**2
36542 ct=xxm(12)
36543
36544 wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
36545 sij=xxm(2)*xxm(4)*s13
36546 ww=(le2+re2)*(or2+ol2)*2d0*tint(s23max,s23min,xm22,s)
36547 &- 4d0*(le2+re2)*ol*or*sij*(s23max-s23min)
36548 ww=ww/wprop2
36549 IF(xmsl.GT.1d4*s) THEN
36550 wd=0d0
36551 wwd=0d0
36552 ELSE
36553 wd=0.5d0*ct**2*tint3(s23max,s23min,xm22,s,xmsl)
36554 wwd=ol*tint2(s23max,s23min,xm22,s,xmsl)-
36555 & or*sij*tprop(s23max,s23min,xmsl)
36556 wwd=2d0*wwd*le*ct*(s13-xmv**2)/wprop2
36557 ENDIF
36558
36559 pyxxz2=(ww+wd+wwd)
36560 IF(pyxxz2.LT.0d0) THEN
36561 WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ2 '
36562 WRITE(mstu(11),*) ww,wd,wwd
36563 WRITE(mstu(11),*) s23min,s23max
36564 WRITE(mstu(11),*) (xxm(i),i=1,4)
36565 WRITE(mstu(11),*) (xxm(i),i=5,8)
36566 WRITE(mstu(11),*) (xxm(i),i=9,12)
36567 pyxxz2=0d0
36568 ENDIF
36569
36570 RETURN
36571 END
36572
36573C*********************************************************************
36574
36575C...PYHEXT
36576C...Calculates the non-standard decay modes of the Higgs boson.
36577
36578 SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)
36579
36580C...Double precision and integer declarations.
36581 IMPLICIT DOUBLE PRECISION(a-h, o-z)
36582 IMPLICIT INTEGER(I-N)
36583 INTEGER PYK,PYCHGE,PYCOMP
36584C...Parameter statement to help give large particle numbers.
36585 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36586C...Commonblocks.
36587 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36588 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36589 common/pypars/mstp(200),parp(200),msti(200),pari(200)
36590 common/pymssm/imss(0:99),rmss(0:99)
36591 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
36592 &sfmix(16,4)
36593 SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/,/pyssmt/
36594
36595C...Local variables.
36596 INTEGER KFIN
36597 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
36598 &XMZ,XMZ2,AXMJ,AXMI
36599 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
36600 DOUBLE PRECISION S12MIN,S12MAX
36601 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
36602 DOUBLE PRECISION PYLAMF,XL,CF,EI
36603 INTEGER IDU,IC,ILR,IFL
36604 DOUBLE PRECISION TANW,XW,AEM,C1,AS
36605 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
36606 DOUBLE PRECISION XLAM(0:200)
36607 INTEGER IDLAM(200,3)
36608 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
36609 INTEGER ITH(4)
36610 INTEGER KFNCHI(4),KFCCHI(2)
36611 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
36612 DOUBLE PRECISION SR2
36613 DOUBLE PRECISION BETA,ALFA
36614 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
36615 DOUBLE PRECISION PYALEM,PI,PYALPS
36616 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
36617 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
36618 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
36619 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
36620 DATA ith/25,35,36,37/
36621 DATA etah/1d0,1d0,-1d0/
36622 DATA sr2/1.4142136d0/
36623 DATA pi/3.141592654d0/
36624 DATA kfnchi/1000022,1000023,1000025,1000035/
36625 DATA kfcchi/1000024,1000037/
36626
36627C...COUNT THE NUMBER OF DECAY MODES
36628 lknt=iknt
36629
36630 xmw=pmas(24,1)
36631 xmw2=xmw**2
36632 xmz=pmas(23,1)
36633 xmz2=xmz**2
36634 xw=paru(102)
36635 tanw = sqrt(xw/(1d0-xw))
36636 cw=sqrt(1d0-xw)
36637
36638C...1 - 4 DEPENDING ON Higgs species.
36639 ih=1
36640 IF(kfin.EQ.ith(2)) ih=2
36641 IF(kfin.EQ.ith(3)) ih=3
36642 IF(kfin.EQ.ith(4)) ih=4
36643
36644 xmi=pmas(kfin,1)
36645 xmi2=xmi**2
36646 axmi=abs(xmi)
36647 aem=pyalem(xmi2)
36648 as =pyalps(xmi2)
36649 c1=aem/xw
36650 xmi3=abs(xmi**3)
36651
36652 tanb=rmss(5)
36653 beta=atan(tanb)
36654 cbeta=cos(beta)
36655 sbeta=tanb*cbeta
36656 alfa=rmss(18)
36657 cosa=cos(alfa)
36658 sina=sin(alfa)
36659 atrit=rmss(16)
36660 atrib=rmss(15)
36661 atril=rmss(17)
36662 xmuz=-rmss(4)
36663
36664 IF(ih.EQ.4) GOTO 180
36665
36666C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36667C...H0_K -> CHI0_I + CHI0_J
36668 eh(1)=sina
36669 eh(2)=cosa
36670 eh(3)=-sbeta
36671 dh(1)=cosa
36672 dh(2)=-sina
36673 dh(3)=cbeta
36674 DO 110 ij=1,4
36675 xmj=smz(ij)
36676 axmj=abs(xmj)
36677 DO 100 ik=1,ij
36678 xmk=smz(ik)
36679 axmk=abs(xmk)
36680 IF(axmi.GE.axmj+axmk) THEN
36681 lknt=lknt+1
36682 f21k=0.5d0*
36683 & eh(ih)*( zmix(ik,3)*zmix(ij,2)+zmix(ij,3)*zmix(ik,2)
36684 & -tanw*(zmix(ik,3)*zmix(ij,1)+zmix(ij,3)*zmix(ik,1)) )+
36685 & 0.5d0*dh(ih)*( zmix(ik,4)*zmix(ij,2)+zmix(ij,4)*zmix(ik,2)
36686 & -tanw*(zmix(ik,4)*zmix(ij,1)+zmix(ij,4)*zmix(ik,1)) )
36687 f12k=0.5d0*
36688 & eh(ih)*(zmix(ij,3)*zmix(ik,2)+zmix(ik,3)*zmix(ij,2)
36689 & -tanw*(zmix(ij,3)*zmix(ik,1)+zmix(ik,3)*zmix(ij,1)))+
36690 & 0.5d0*dh(ih)*( zmix(ij,4)*zmix(ik,2)+zmix(ik,4)*zmix(ij,2)
36691 & -tanw*(zmix(ij,4)*zmix(ik,1)+zmix(ik,4)*zmix(ij,1)) )
36692C...SIGN OF MASSES I,J
36693 xml=xmk*etah(ih)
36694 xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,f12k,f21k)
36695 IF(ij.EQ.ik) xlam(lknt)=xlam(lknt)*0.5d0
36696 idlam(lknt,1)=kfnchi(ij)
36697 idlam(lknt,2)=kfnchi(ik)
36698 idlam(lknt,3)=0
36699 ENDIF
36700 100 CONTINUE
36701 110 CONTINUE
36702
36703C...H0_K -> CHI+_I CHI-_J
36704 DO 130 ij=1,2
36705 xmj=smw(ij)
36706 axmj=abs(xmj)
36707 DO 120 ik=1,2
36708 xmk=smw(ik)
36709 axmk=abs(xmk)
36710 IF(axmi.GE.axmj+axmk) THEN
36711 lknt=lknt+1
36712 f21k=(vmix(ij,1)*umix(ik,2)*eh(ih) -
36713 & vmix(ij,2)*umix(ik,1)*dh(ih))/sr2
36714 f12k=(vmix(ik,1)*umix(ij,2)*eh(ih) -
36715 & vmix(ik,2)*umix(ij,1)*dh(ih))/sr2
36716 xml=-xmk*etah(ih)
36717 xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,f12k,f21k)
36718 idlam(lknt,1)=kfcchi(ij)
36719 idlam(lknt,2)=-kfcchi(ik)
36720 idlam(lknt,3)=0
36721 ENDIF
36722 120 CONTINUE
36723 130 CONTINUE
36724
36725C...HIGGS TO SFERMION SFERMION
36726 DO 160 ifl=1,16
36727 IF(ifl.GE.7.AND.ifl.LE.10) GOTO 160
36728 ij=ksusy1+ifl
36729 xmjl=pmas(pycomp(ij),1)
36730 xmjr=pmas(pycomp(ij+ksusy1),1)
36731 IF(axmi.GE.2d0*min(xmjl,xmjr)) THEN
36732 xmj=xmjl
36733 xmj2=xmj**2
36734 xl=pylamf(xmi2,xmj2,xmj2)
36735 xmf=pmas(ifl,1)
36736 ei=kchg(ifl,1)/3d0
36737 idu=2-mod(ifl,2)
36738
36739 IF(ih.EQ.1) THEN
36740 IF(idu.EQ.1) THEN
36741 ghll=-xmz/cw*(0.5d0+ei*xw)*sin(alfa+beta)+
36742 & xmf**2/xmw*sina/cbeta
36743 ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)+
36744 & xmf**2/xmw*sina/cbeta
36745 IF(ifl.EQ.5) THEN
36746 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
36747 & atrib*sina)
36748 ELSEIF(ifl.EQ.15) THEN
36749 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
36750 & atril*sina)
36751 ELSE
36752 ghlr=0d0
36753 ENDIF
36754 ELSE
36755 ghll=xmz/cw*(0.5d0-ei*xw)*sin(alfa+beta)-
36756 & xmf**2/xmw*cosa/sbeta
36757 ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)-
36758 & xmf**2/xmw*cosa/sbeta
36759 IF(ifl.EQ.6) THEN
36760 ghlr=xmf/2d0/xmw/sbeta*(xmuz*sina-
36761 & atrit*cosa)
36762 ELSE
36763 ghlr=0d0
36764 ENDIF
36765 ENDIF
36766
36767 ELSEIF(ih.EQ.2) THEN
36768 IF(idu.EQ.1) THEN
36769 ghll=xmz/cw*(0.5d0+ei*xw)*cos(alfa+beta)-
36770 & xmf**2/xmw*cosa/cbeta
36771 ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
36772 & xmf**2/xmw*cosa/cbeta
36773 IF(ifl.EQ.5) THEN
36774 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
36775 & atrib*cosa)
36776 ELSEIF(ifl.EQ.15) THEN
36777 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
36778 & atril*cosa)
36779 ELSE
36780 ghlr=0d0
36781 ENDIF
36782 ELSE
36783 ghll=-xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)-
36784 & xmf**2/xmw*sina/sbeta
36785 ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
36786 & xmf**2/xmw*sina/sbeta
36787 IF(ifl.EQ.6) THEN
36788 ghlr=-xmf/2d0/xmw/sbeta*(xmuz*cosa+
36789 & atrit*sina)
36790 ELSE
36791 ghlr=0d0
36792 ENDIF
36793 ENDIF
36794
36795 ELSEIF(ih.EQ.3) THEN
36796 ghll=0d0
36797 ghrr=0d0
36798 ghlr=0d0
36799 IF(idu.EQ.1) THEN
36800 IF(ifl.EQ.5) THEN
36801 ghlr=xmf/2d0/xmw*(atrib*tanb-xmuz)
36802 ELSEIF(ifl.EQ.15) THEN
36803 ghlr=xmf/2d0/xmw*(atril*tanb-xmuz)
36804 ENDIF
36805 ELSE
36806 IF(ifl.EQ.6) THEN
36807 ghlr=xmf/2d0/xmw*(atrit/tanb-xmuz)
36808 ENDIF
36809 ENDIF
36810 ENDIF
36811 IF(ih.EQ.3) GOTO 140
36812
36813 al=sfmix(ifl,1)**2
36814 ar=sfmix(ifl,2)**2
36815 alr=sfmix(ifl,1)*sfmix(ifl,2)
36816 IF(ifl.LE.6) THEN
36817 cf=3d0
36818 ELSE
36819 cf=1d0
36820 ENDIF
36821
36822 IF(axmi.GE.2d0*xmj) THEN
36823 lknt=lknt+1
36824 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36825 & (ghll*al+ghrr*ar
36826 & +2d0*ghlr*alr)**2
36827 idlam(lknt,1)=ij
36828 idlam(lknt,2)=-ij
36829 idlam(lknt,3)=0
36830 ENDIF
36831
36832 IF(axmi.GE.2d0*xmjr) THEN
36833 lknt=lknt+1
36834 al=sfmix(ifl,3)**2
36835 ar=sfmix(ifl,4)**2
36836 alr=sfmix(ifl,3)*sfmix(ifl,4)
36837 xmj=xmjr
36838 xmj2=xmj**2
36839 xl=pylamf(xmi2,xmj2,xmj2)
36840 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36841 & (ghll*al+ghrr*ar
36842 & +2d0*ghlr*alr)**2
36843 idlam(lknt,1)=ij+ksusy1
36844 idlam(lknt,2)=-(ij+ksusy1)
36845 idlam(lknt,3)=0
36846 ENDIF
36847 140 CONTINUE
36848
36849 IF(axmi.GE.xmjl+xmjr) THEN
36850 lknt=lknt+1
36851 al=sfmix(ifl,1)*sfmix(ifl,3)
36852 ar=sfmix(ifl,2)*sfmix(ifl,4)
36853 alr=sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,2)*sfmix(ifl,3)
36854 xmj=xmjr
36855 xmj2=xmj**2
36856 xl=pylamf(xmi2,xmj2,xmjl**2)
36857 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36858 & (ghll*al+ghrr*ar)**2
36859 idlam(lknt,1)=ij
36860 idlam(lknt,2)=-(ij+ksusy1)
36861 idlam(lknt,3)=0
36862 lknt=lknt+1
36863 idlam(lknt,1)=-ij
36864 idlam(lknt,2)=ij+ksusy1
36865 idlam(lknt,3)=0
36866 xlam(lknt)=xlam(lknt-1)
36867 ENDIF
36868 ENDIF
36869 150 CONTINUE
36870 160 CONTINUE
36871 170 CONTINUE
36872
36873 GOTO 230
36874 180 CONTINUE
36875
36876C...H+ -> CHI+_I + CHI0_J
36877 DO 200 ij=1,4
36878 xmj=smz(ij)
36879 axmj=abs(xmj)
36880 xmj2=xmj**2
36881 DO 190 ik=1,2
36882 xmk=smw(ik)
36883 axmk=abs(xmk)
36884 xmk2=xmk**2
36885 IF(axmi.GE.axmj+axmk) THEN
36886 lknt=lknt+1
36887 gl=cbeta*(zmix(ij,4)*vmix(ik,1)+(zmix(ij,2)+zmix(ij,1)*
36888 & tanw)*vmix(ik,2)/sr2)
36889 gr=sbeta*(zmix(ij,3)*umix(ik,1)-(zmix(ij,2)+zmix(ij,1)*
36890 & tanw)*umix(ik,2)/sr2)
36891 xlam(lknt)=pyh2xx(c1,xmi,xmj,-xmk,gl,gr)
36892 idlam(lknt,1)=kfnchi(ij)
36893 idlam(lknt,2)=kfcchi(ik)
36894 idlam(lknt,3)=0
36895 ENDIF
36896 190 CONTINUE
36897 200 CONTINUE
36898
36899 gl=-xmw/sr2*(sin(2d0*beta)-pmas(6,1)**2/tanb/xmw2)
36900 gr=-pmas(6,1)/sr2/xmw*(xmuz-atrit/tanb)
36901 al=0d0
36902 ar=0d0
36903 cf=3d0
36904
36905C...H+ -> T_1 B_1~
36906 xm1=pmas(pycomp(ksusy1+6),1)
36907 xm2=pmas(pycomp(ksusy1+5),1)
36908 IF(xmi.GE.xm1+xm2) THEN
36909 xl=pylamf(xmi2,xm1**2,xm2**2)
36910 lknt=lknt+1
36911 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36912 & (gl*sfmix(6,1)*sfmix(5,1)+gr*sfmix(6,2)*sfmix(5,1))**2
36913 idlam(lknt,1)=ksusy1+6
36914 idlam(lknt,2)=-(ksusy1+5)
36915 idlam(lknt,3)=0
36916 ENDIF
36917
36918C...H+ -> T_2 B_1~
36919 xm1=pmas(pycomp(ksusy2+6),1)
36920 xm2=pmas(pycomp(ksusy1+5),1)
36921 IF(xmi.GE.xm1+xm2) THEN
36922 xl=pylamf(xmi2,xm1**2,xm2**2)
36923 lknt=lknt+1
36924 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36925 & (gl*sfmix(6,3)*sfmix(5,1)+gr*sfmix(6,4)*sfmix(5,1))**2
36926 idlam(lknt,1)=ksusy2+6
36927 idlam(lknt,2)=-(ksusy1+5)
36928 idlam(lknt,3)=0
36929 ENDIF
36930
36931C...H+ -> T_1 B_2~
36932 xm1=pmas(pycomp(ksusy1+6),1)
36933 xm2=pmas(pycomp(ksusy2+5),1)
36934 IF(xmi.GE.xm1+xm2) THEN
36935 xl=pylamf(xmi2,xm1**2,xm2**2)
36936 lknt=lknt+1
36937 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36938 & (gl*sfmix(6,1)*sfmix(5,3)+gr*sfmix(6,2)*sfmix(5,3))**2
36939 idlam(lknt,1)=ksusy1+6
36940 idlam(lknt,2)=-(ksusy2+5)
36941 idlam(lknt,3)=0
36942 ENDIF
36943
36944C...H+ -> T_2 B_2~
36945 xm1=pmas(pycomp(ksusy2+6),1)
36946 xm2=pmas(pycomp(ksusy2+5),1)
36947 IF(xmi.GE.xm1+xm2) THEN
36948 xl=pylamf(xmi2,xm1**2,xm2**2)
36949 lknt=lknt+1
36950 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
36951 & (gl*sfmix(6,3)*sfmix(5,3)+gr*sfmix(6,4)*sfmix(5,3))**2
36952 idlam(lknt,1)=ksusy2+6
36953 idlam(lknt,2)=-(ksusy2+5)
36954 idlam(lknt,3)=0
36955 ENDIF
36956
36957C...H+ -> UL DL~
36958 gl=-xmw/sr2*sin(2d0*beta)
36959 DO 210 ij=1,3,2
36960 xm1=pmas(pycomp(ksusy1+ij),1)
36961 xm2=pmas(pycomp(ksusy1+ij+1),1)
36962 IF(xmi.GE.xm1+xm2) THEN
36963 xl=pylamf(xmi2,xm1**2,xm2**2)
36964 lknt=lknt+1
36965 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2
36966 idlam(lknt,1)=-(ksusy1+ij)
36967 idlam(lknt,2)=ksusy1+ij+1
36968 idlam(lknt,3)=0
36969 ENDIF
36970 210 CONTINUE
36971
36972C...H+ -> EL~ NUL
36973 cf=1d0
36974 DO 220 ij=11,13,2
36975 xm1=pmas(pycomp(ksusy1+ij),1)
36976 xm2=pmas(pycomp(ksusy1+ij+1),1)
36977 IF(xmi.GE.xm1+xm2) THEN
36978 xl=pylamf(xmi2,xm1**2,xm2**2)
36979 lknt=lknt+1
36980 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2
36981 idlam(lknt,1)=-(ksusy1+ij)
36982 idlam(lknt,2)=ksusy1+ij+1
36983 idlam(lknt,3)=0
36984 ENDIF
36985 220 CONTINUE
36986
36987C...H+ -> TAU1 NUTAUL
36988 xm1=pmas(pycomp(ksusy1+15),1)
36989 xm2=pmas(pycomp(ksusy1+16),1)
36990 IF(xmi.GE.xm1+xm2) THEN
36991 xl=pylamf(xmi2,xm1**2,xm2**2)
36992 lknt=lknt+1
36993 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2*sfmix(15,1)**2
36994 idlam(lknt,1)=-(ksusy1+15)
36995 idlam(lknt,2)= ksusy1+16
36996 idlam(lknt,3)=0
36997 ENDIF
36998
36999C...H+ -> TAU2 NUTAUL
37000 xm1=pmas(pycomp(ksusy2+15),1)
37001 xm2=pmas(pycomp(ksusy1+16),1)
37002 IF(xmi.GE.xm1+xm2) THEN
37003 xl=pylamf(xmi2,xm1**2,xm2**2)
37004 lknt=lknt+1
37005 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2*sfmix(15,3)**2
37006 idlam(lknt,1)=-(ksusy2+15)
37007 idlam(lknt,2)= ksusy1+16
37008 idlam(lknt,3)=0
37009 ENDIF
37010
37011 230 CONTINUE
37012 iknt=lknt
37013 xlam(0)=0d0
37014 DO 240 i=1,iknt
37015 IF(xlam(i).LE.0d0) xlam(i)=0d0
37016 xlam(0)=xlam(0)+xlam(i)
37017 240 CONTINUE
37018 IF(xlam(0).EQ.0d0) xlam(0)=1d-6
37019
37020 RETURN
37021 END
37022
37023C*********************************************************************
37024
37025C...PYH2XX
37026C...Calculates the decay rate for a Higgs to an ino pair.
37027
37028 FUNCTION pyh2xx(C1,XM1,XM2,XM3,GL,GR)
37029
37030C...Double precision and integer declarations.
37031 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37032 IMPLICIT INTEGER(I-N)
37033 INTEGER PYK,PYCHGE,PYCOMP
37034C...Commonblocks.
37035 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37036 SAVE /pydat1/
37037
37038C...Local variables.
37039 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
37040 DOUBLE PRECISION XL,PYLAMF,C1
37041 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
37042
37043 xmi2=xm1**2
37044 xmi3=abs(xm1**3)
37045 xmj2=xm2**2
37046 xmk2=xm3**2
37047 xl=pylamf(xmi2,xmj2,xmk2)
37048 pyh2xx=c1/4d0/xmi3*sqrt(xl)
37049 &*((gl**2+gr**2)*(xmi2-xmj2-xmk2)-
37050 &4d0*gl*gr*xm3*xm2)
37051 IF(pyh2xx.LT.0d0) THEN
37052 WRITE(mstu(11),*) ' NEGATIVE WIDTH IN PYH2XX '
37053 WRITE(mstu(11),*) xmi2,xmj2,xmk2,gl,gr,xm1,xm2,xm3
37054 stop
37055 ENDIF
37056
37057 RETURN
37058 END
37059
37060C*********************************************************************
37061
37062C...PYGAUS
37063C...Integration by adaptive Gaussian quadrature.
37064C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
37065
37066 FUNCTION pygaus(F, A, B, EPS)
37067
37068C...Double precision and integer declarations.
37069 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37070 IMPLICIT INTEGER(I-N)
37071 INTEGER PYK,PYCHGE,PYCOMP
37072
37073C...Local declarations.
37074 EXTERNAL f
37075 DOUBLE PRECISION F,W(12), X(12)
37076 DATA x( 1) /9.6028985649753623d-1/, w( 1) /1.0122853629037626d-1/
37077 DATA x( 2) /7.9666647741362674d-1/, w( 2) /2.2238103445337447d-1/
37078 DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
37079 DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
37080 DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
37081 DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
37082 DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
37083 DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
37084 DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
37085 DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
37086 DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
37087 DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
37088
37089C...The Gaussian quadrature algorithm.
37090 h = 0d0
37091 IF(b .EQ. a) GO TO 140
37092 const = 5d-3 / abs(b-a)
37093 bb = a
37094 100 CONTINUE
37095 aa = bb
37096 bb = b
37097 110 CONTINUE
37098 c1 = 0.5d0*(bb+aa)
37099 c2 = 0.5d0*(bb-aa)
37100 s8 = 0d0
37101 DO 120 i = 1, 4
37102 u = c2*x(i)
37103 s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
37104 120 CONTINUE
37105 s16 = 0d0
37106 DO 130 i = 5, 12
37107 u = c2*x(i)
37108 s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
37109 130 CONTINUE
37110 s16 = c2*s16
37111 IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
37112 h = h + s16
37113 IF(bb .NE. b) GO TO 100
37114 ELSE
37115 bb = c1
37116 IF(1d0 + const*abs(c2) .NE. 1d0) GO TO 110
37117 h = 0d0
37118 CALL pyerrm(18,'(PYGAUS:) too high accuracy required')
37119 GO TO 140
37120 ENDIF
37121 140 CONTINUE
37122 pygaus = h
37123
37124 RETURN
37125 END
37126
37127C*********************************************************************
37128
37129C...PYSIMP
37130C...Simpson formula for an integral.
37131
37132 FUNCTION pysimp(Y,X0,X1,N)
37133
37134C...Double precision and integer declarations.
37135 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37136 IMPLICIT INTEGER(I-N)
37137 INTEGER PYK,PYCHGE,PYCOMP
37138
37139C...Local variables.
37140 DOUBLE PRECISION Y,X0,X1,H,S
37141 dimension y(0:n)
37142
37143 s=0d0
37144 h=(x1-x0)/n
37145 DO 100 i=0,n-2,2
37146 s=s+y(i)+4d0*y(i+1)+y(i+2)
37147 100 CONTINUE
37148 pysimp=s*h/3d0
37149
37150 RETURN
37151 END
37152
37153C*********************************************************************
37154
37155C...PYLAMF
37156C...The standard lambda function.
37157
37158 FUNCTION pylamf(X,Y,Z)
37159
37160C...Double precision and integer declarations.
37161 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37162 IMPLICIT INTEGER(I-N)
37163 INTEGER PYK,PYCHGE,PYCOMP
37164
37165C...Local variables.
37166 DOUBLE PRECISION PYLAMF,X,Y,Z
37167
37168 pylamf=(x-(y+z))**2-4d0*y*z
37169 IF(pylamf.LT.0d0) pylamf=0d0
37170
37171 RETURN
37172 END
37173
37174C*********************************************************************
37175
37176C...PYTBDY
37177C...Generates 3-body decays of gauginos.
37178
37179 SUBROUTINE pytbdy(XM)
37180
37181C...Double precision and integer declarations.
37182 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37183 IMPLICIT INTEGER(I-N)
37184 INTEGER PYK,PYCHGE,PYCOMP
37185C...Parameter statement to help give large particle numbers.
37186 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
37187C...Commonblocks.
37188 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37189 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37190 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37191 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
37192 common/pypars/mstp(200),parp(200),msti(200),pari(200)
37193 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pypars/
37194
37195C...Local variables.
37196 DOUBLE PRECISION XM(5)
37197 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
37198 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
37199 DOUBLE PRECISION CPHI1,SPHI1
37200 DOUBLE PRECISION S23DEL,EPS
37201 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
37202 parameter(r=0.61803399d0,c=1d0-r,tol=1d-3)
37203 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
37204 DATA eps/1d-6/
37205
37206C...GENERATE S12
37207 s12min=(xm(1)+xm(2))**2
37208 s12max=(xm(5)-xm(3))**2
37209 yjaco1=s12max-s12min
37210
37211C...FIND S12*
37212 ax=s12min
37213 cx=s12max
37214 bx=s12min+0.5d0*yjaco1
37215 x0=ax
37216 x3=cx
37217 IF(abs(cx-bx).GT.abs(bx-ax))THEN
37218 x1=bx
37219 x2=bx+c*(cx-bx)
37220 ELSE
37221 x2=bx
37222 x1=bx-c*(bx-ax)
37223 ENDIF
37224
37225C...SOLVE FOR F1 AND F2
37226 s23df1=(x1-xm(2)**2-xm(1)**2)**2
37227 &-(2d0*xm(1)*xm(2))**2
37228 s23df2=(x1-xm(3)**2-xm(5)**2)**2
37229 &-(2d0*xm(3)*xm(5))**2
37230 s23df1=s23df1*eps
37231 s23df2=s23df2*eps
37232 s23del=sqrt(s23df1*s23df2)/(2d0*x1)
37233 f1=-2d0*s23del/eps
37234 s23df1=(x2-xm(2)**2-xm(1)**2)**2
37235 &-(2d0*xm(1)*xm(2))**2
37236 s23df2=(x2-xm(3)**2-xm(5)**2)**2
37237 &-(2d0*xm(3)*xm(5))**2
37238 s23df1=s23df1*eps
37239 s23df2=s23df2*eps
37240 s23del=sqrt(s23df1*s23df2)/(2d0*x2)
37241 f2=-2d0*s23del/eps
37242
37243 100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2)))THEN
37244 IF(f2.LT.f1)THEN
37245 x0=x1
37246 x1=x2
37247 x2=r*x1+c*x3
37248 f1=f2
37249 s23df1=(x2-xm(2)**2-xm(1)**2)**2
37250 & -(2d0*xm(1)*xm(2))**2
37251 s23df2=(x2-xm(3)**2-xm(5)**2)**2
37252 & -(2d0*xm(3)*xm(5))**2
37253 s23df1=s23df1*eps
37254 s23df2=s23df2*eps
37255 s23del=sqrt(s23df1*s23df2)/(2d0*x2)
37256 f2=-2d0*s23del/eps
37257 ELSE
37258 x3=x2
37259 x2=x1
37260 x1=r*x2+c*x0
37261 f2=f1
37262 s23df1=(x1-xm(2)**2-xm(1)**2)**2
37263 & -(2d0*xm(1)*xm(2))**2
37264 s23df2=(x1-xm(3)**2-xm(5)**2)**2
37265 & -(2d0*xm(3)*xm(5))**2
37266 s23df1=s23df1*eps
37267 s23df2=s23df2*eps
37268 s23del=sqrt(s23df1*s23df2)/(2d0*x1)
37269 f1=-2d0*s23del/eps
37270 ENDIF
37271 GOTO 100
37272 ENDIF
37273C...WE WANT THE MAXIMUM, NOT THE MINIMUM
37274 IF(f1.LT.f2)THEN
37275 golden=-f1
37276 xmin=x1
37277 ELSE
37278 golden=-f2
37279 xmin=x2
37280 ENDIF
37281
37282 iknt=0
37283 110 s12=s12min+pyr(0)*yjaco1
37284 iknt=iknt+1
37285C...GENERATE S23
37286 s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
37287 &*(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
37288 s23df1=(s12-xm(2)**2-xm(1)**2)**2
37289 &-(2d0*xm(1)*xm(2))**2
37290 s23df2=(s12-xm(3)**2-xm(5)**2)**2
37291 &-(2d0*xm(3)*xm(5))**2
37292 s23df1=s23df1*eps
37293 s23df2=s23df2*eps
37294 s23del=sqrt(s23df1*s23df2)/(2d0*s12)
37295 s23del=s23del/eps
37296 s23min=s23ave-s23del
37297 s23max=s23ave+s23del
37298 yjaco2=s23max-s23min
37299 s23=s23min+pyr(0)*yjaco2
37300
37301C...CHECK THE SAMPLING
37302 IF(iknt.GT.100) THEN
37303 WRITE(mstu(11),*) ' IKNT > 100 IN PYTBDY '
37304 GOTO 120
37305 ENDIF
37306 IF(yjaco2.LT.pyr(0)*golden) GOTO 110
37307 120 d3=(xm(5)**2+xm(3)**2-s12)/(2d0*xm(5))
37308 d1=(xm(5)**2+xm(1)**2-s23)/(2d0*xm(5))
37309 d2=xm(5)-d1-d3
37310 p1=sqrt(d1*d1-xm(1)**2)
37311 p2=sqrt(d2*d2-xm(2)**2)
37312 p3=sqrt(d3*d3-xm(3)**2)
37313 cthe1=2d0*pyr(0)-1d0
37314 ang1=2d0*pyr(0)*paru(1)
37315 cphi1=cos(ang1)
37316 sphi1=sin(ang1)
37317 arg=1d0-cthe1**2
37318 IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
37319 sthe1=sqrt(arg)
37320 p(n+1,1)=p1*sthe1*cphi1
37321 p(n+1,2)=p1*sthe1*sphi1
37322 p(n+1,3)=p1*cthe1
37323 p(n+1,4)=d1
37324
37325C...GET CPHI3
37326 ang3=2d0*pyr(0)*paru(1)
37327 cphi3=cos(ang3)
37328 sphi3=sin(ang3)
37329 cthe3=(p2**2-p1**2-p3**2)/2d0/p1/p3
37330 arg=1d0-cthe3**2
37331 IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
37332 sthe3=sqrt(arg)
37333 p(n+3,1)=-p3*sthe3*cphi3*cthe1*cphi1
37334 &+p3*sthe3*sphi3*sphi1
37335 &+p3*cthe3*sthe1*cphi1
37336 p(n+3,2)=-p3*sthe3*cphi3*cthe1*sphi1
37337 &-p3*sthe3*sphi3*cphi1
37338 &+p3*cthe3*sthe1*sphi1
37339 p(n+3,3)=p3*sthe3*cphi3*sthe1
37340 &+p3*cthe3*cthe1
37341 p(n+3,4)=d3
37342
37343 DO 130 i=1,3
37344 p(n+2,i)=-p(n+1,i)-p(n+3,i)
37345 130 CONTINUE
37346 p(n+2,4)=d2
37347
37348 RETURN
37349 END
37350
37351C*********************************************************************
37352
37353C...PY1ENT
37354C...Stores one parton/particle in commonblock PYJETS.
37355
37356 SUBROUTINE py1ent(IP,KF,PE,THE,PHI)
37357
37358C...Double precision and integer declarations.
37359 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37360 IMPLICIT INTEGER(I-N)
37361 INTEGER PYK,PYCHGE,PYCOMP
37362C...Commonblocks.
37363 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37364 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37365 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37366 SAVE /pyjets/,/pydat1/,/pydat2/
37367
37368C...Standard checks.
37369 mstu(28)=0
37370 IF(mstu(12).GE.1) CALL pylist(0)
37371 ipa=max(1,iabs(ip))
37372 IF(ipa.GT.mstu(4)) CALL pyerrm(21,
37373 &'(PY1ENT:) writing outside PYJETS memory')
37374 kc=pycomp(kf)
37375 IF(kc.EQ.0) CALL pyerrm(12,'(PY1ENT:) unknown flavour code')
37376
37377C...Find mass. Reset K, P and V vectors.
37378 pm=0d0
37379 IF(mstu(10).EQ.1) pm=p(ipa,5)
37380 IF(mstu(10).GE.2) pm=pymass(kf)
37381 DO 100 j=1,5
37382 k(ipa,j)=0
37383 p(ipa,j)=0d0
37384 v(ipa,j)=0d0
37385 100 CONTINUE
37386
37387C...Store parton/particle in K and P vectors.
37388 k(ipa,1)=1
37389 IF(ip.LT.0) k(ipa,1)=2
37390 k(ipa,2)=kf
37391 p(ipa,5)=pm
37392 p(ipa,4)=max(pe,pm)
37393 pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
37394 p(ipa,1)=pa*sin(the)*cos(phi)
37395 p(ipa,2)=pa*sin(the)*sin(phi)
37396 p(ipa,3)=pa*cos(the)
37397
37398C...Set N. Optionally fragment/decay.
37399 n=ipa
37400 IF(ip.EQ.0) CALL pyexec
37401
37402 RETURN
37403 END
37404
37405C*********************************************************************
37406
37407C...PY2ENT
37408C...Stores two partons/particles in their CM frame,
37409C...with the first along the +z axis.
37410
37411 SUBROUTINE py2ent(IP,KF1,KF2,PECM)
37412
37413C...Double precision and integer declarations.
37414 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37415 IMPLICIT INTEGER(I-N)
37416 INTEGER PYK,PYCHGE,PYCOMP
37417C...Commonblocks.
37418 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37419 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37420 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37421 SAVE /pyjets/,/pydat1/,/pydat2/
37422
37423C...Standard checks.
37424 mstu(28)=0
37425 IF(mstu(12).GE.1) CALL pylist(0)
37426 ipa=max(1,iabs(ip))
37427 IF(ipa.GT.mstu(4)-1) CALL pyerrm(21,
37428 &'(PY2ENT:) writing outside PYJETS memory')
37429 kc1=pycomp(kf1)
37430 kc2=pycomp(kf2)
37431 IF(kc1.EQ.0.OR.kc2.EQ.0) CALL pyerrm(12,
37432 &'(PY2ENT:) unknown flavour code')
37433
37434C...Find masses. Reset K, P and V vectors.
37435 pm1=0d0
37436 IF(mstu(10).EQ.1) pm1=p(ipa,5)
37437 IF(mstu(10).GE.2) pm1=pymass(kf1)
37438 pm2=0d0
37439 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
37440 IF(mstu(10).GE.2) pm2=pymass(kf2)
37441 DO 110 i=ipa,ipa+1
37442 DO 100 j=1,5
37443 k(i,j)=0
37444 p(i,j)=0d0
37445 v(i,j)=0d0
37446 100 CONTINUE
37447 110 CONTINUE
37448
37449C...Check flavours.
37450 kq1=kchg(kc1,2)*isign(1,kf1)
37451 kq2=kchg(kc2,2)*isign(1,kf2)
37452 IF(mstu(19).EQ.1) THEN
37453 mstu(19)=0
37454 ELSE
37455 IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL pyerrm(2,
37456 & '(PY2ENT:) unphysical flavour combination')
37457 ENDIF
37458 k(ipa,2)=kf1
37459 k(ipa+1,2)=kf2
37460
37461C...Store partons/particles in K vectors for normal case.
37462 IF(ip.GE.0) THEN
37463 k(ipa,1)=1
37464 IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
37465 k(ipa+1,1)=1
37466
37467C...Store partons in K vectors for parton shower evolution.
37468 ELSE
37469 k(ipa,1)=3
37470 k(ipa+1,1)=3
37471 k(ipa,4)=mstu(5)*(ipa+1)
37472 k(ipa,5)=k(ipa,4)
37473 k(ipa+1,4)=mstu(5)*ipa
37474 k(ipa+1,5)=k(ipa+1,4)
37475 ENDIF
37476
37477C...Check kinematics and store partons/particles in P vectors.
37478 IF(pecm.LE.pm1+pm2) CALL pyerrm(13,
37479 &'(PY2ENT:) energy smaller than sum of masses')
37480 pa=sqrt(max(0d0,(pecm**2-pm1**2-pm2**2)**2-(2d0*pm1*pm2)**2))/
37481 &(2d0*pecm)
37482 p(ipa,3)=pa
37483 p(ipa,4)=sqrt(pm1**2+pa**2)
37484 p(ipa,5)=pm1
37485 p(ipa+1,3)=-pa
37486 p(ipa+1,4)=sqrt(pm2**2+pa**2)
37487 p(ipa+1,5)=pm2
37488
37489C...Set N. Optionally fragment/decay.
37490 n=ipa+1
37491 IF(ip.EQ.0) CALL pyexec
37492
37493 RETURN
37494 END
37495
37496C*********************************************************************
37497
37498C...PY3ENT
37499C...Stores three partons or particles in their CM frame,
37500C...with the first along the +z axis and the third in the (x,z)
37501C...plane with x > 0.
37502
37503 SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
37504
37505C...Double precision and integer declarations.
37506 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37507 IMPLICIT INTEGER(I-N)
37508 INTEGER PYK,PYCHGE,PYCOMP
37509C...Commonblocks.
37510 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37511 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37512 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37513 SAVE /pyjets/,/pydat1/,/pydat2/
37514
37515C...Standard checks.
37516 mstu(28)=0
37517 IF(mstu(12).GE.1) CALL pylist(0)
37518 ipa=max(1,iabs(ip))
37519 IF(ipa.GT.mstu(4)-2) CALL pyerrm(21,
37520 &'(PY3ENT:) writing outside PYJETS memory')
37521 kc1=pycomp(kf1)
37522 kc2=pycomp(kf2)
37523 kc3=pycomp(kf3)
37524 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL pyerrm(12,
37525 &'(PY3ENT:) unknown flavour code')
37526
37527C...Find masses. Reset K, P and V vectors.
37528 pm1=0d0
37529 IF(mstu(10).EQ.1) pm1=p(ipa,5)
37530 IF(mstu(10).GE.2) pm1=pymass(kf1)
37531 pm2=0d0
37532 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
37533 IF(mstu(10).GE.2) pm2=pymass(kf2)
37534 pm3=0d0
37535 IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
37536 IF(mstu(10).GE.2) pm3=pymass(kf3)
37537 DO 110 i=ipa,ipa+2
37538 DO 100 j=1,5
37539 k(i,j)=0
37540 p(i,j)=0d0
37541 v(i,j)=0d0
37542 100 CONTINUE
37543 110 CONTINUE
37544
37545C...Check flavours.
37546 kq1=kchg(kc1,2)*isign(1,kf1)
37547 kq2=kchg(kc2,2)*isign(1,kf2)
37548 kq3=kchg(kc3,2)*isign(1,kf3)
37549 IF(mstu(19).EQ.1) THEN
37550 mstu(19)=0
37551 ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
37552 ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
37553 & kq1+kq3.EQ.4)) THEN
37554 ELSE
37555 CALL pyerrm(2,'(PY3ENT:) unphysical flavour combination')
37556 ENDIF
37557 k(ipa,2)=kf1
37558 k(ipa+1,2)=kf2
37559 k(ipa+2,2)=kf3
37560
37561C...Store partons/particles in K vectors for normal case.
37562 IF(ip.GE.0) THEN
37563 k(ipa,1)=1
37564 IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
37565 k(ipa+1,1)=1
37566 IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
37567 k(ipa+2,1)=1
37568
37569C...Store partons in K vectors for parton shower evolution.
37570 ELSE
37571 k(ipa,1)=3
37572 k(ipa+1,1)=3
37573 k(ipa+2,1)=3
37574 kcs=4
37575 IF(kq1.EQ.-1) kcs=5
37576 k(ipa,kcs)=mstu(5)*(ipa+1)
37577 k(ipa,9-kcs)=mstu(5)*(ipa+2)
37578 k(ipa+1,kcs)=mstu(5)*(ipa+2)
37579 k(ipa+1,9-kcs)=mstu(5)*ipa
37580 k(ipa+2,kcs)=mstu(5)*ipa
37581 k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
37582 ENDIF
37583
37584C...Check kinematics.
37585 mkerr=0
37586 IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*(2d0-x1-x3)*pecm.LE.pm2.OR.
37587 &0.5d0*x3*pecm.LE.pm3) mkerr=1
37588 pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
37589 pa2=sqrt(max(1d-10,(0.5d0*(2d0-x1-x3)*pecm)**2-pm2**2))
37590 pa3=sqrt(max(1d-10,(0.5d0*x3*pecm)**2-pm3**2))
37591 cthe2=(pa3**2-pa1**2-pa2**2)/(2d0*pa1*pa2)
37592 cthe3=(pa2**2-pa1**2-pa3**2)/(2d0*pa1*pa3)
37593 IF(abs(cthe2).GE.1.001d0.OR.abs(cthe3).GE.1.001d0) mkerr=1
37594 cthe3=max(-1d0,min(1d0,cthe3))
37595 IF(mkerr.NE.0) CALL pyerrm(13,
37596 &'(PY3ENT:) unphysical kinematical variable setup')
37597
37598C...Store partons/particles in P vectors.
37599 p(ipa,3)=pa1
37600 p(ipa,4)=sqrt(pa1**2+pm1**2)
37601 p(ipa,5)=pm1
37602 p(ipa+2,1)=pa3*sqrt(1d0-cthe3**2)
37603 p(ipa+2,3)=pa3*cthe3
37604 p(ipa+2,4)=sqrt(pa3**2+pm3**2)
37605 p(ipa+2,5)=pm3
37606 p(ipa+1,1)=-p(ipa+2,1)
37607 p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
37608 p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
37609 p(ipa+1,5)=pm2
37610
37611C...Set N. Optionally fragment/decay.
37612 n=ipa+2
37613 IF(ip.EQ.0) CALL pyexec
37614
37615 RETURN
37616 END
37617
37618C*********************************************************************
37619
37620C...PY4ENT
37621C...Stores four partons or particles in their CM frame, with
37622C...the first along the +z axis, the last in the xz plane with x > 0
37623C...and the second having y < 0 and y > 0 with equal probability.
37624
37625 SUBROUTINE py4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
37626
37627C...Double precision and integer declarations.
37628 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37629 IMPLICIT INTEGER(I-N)
37630 INTEGER PYK,PYCHGE,PYCOMP
37631C...Commonblocks.
37632 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37633 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37634 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37635 SAVE /pyjets/,/pydat1/,/pydat2/
37636
37637C...Standard checks.
37638 mstu(28)=0
37639 IF(mstu(12).GE.1) CALL pylist(0)
37640 ipa=max(1,iabs(ip))
37641 IF(ipa.GT.mstu(4)-3) CALL pyerrm(21,
37642 &'(PY4ENT:) writing outside PYJETS momory')
37643 kc1=pycomp(kf1)
37644 kc2=pycomp(kf2)
37645 kc3=pycomp(kf3)
37646 kc4=pycomp(kf4)
37647 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL pyerrm(12,
37648 &'(PY4ENT:) unknown flavour code')
37649
37650C...Find masses. Reset K, P and V vectors.
37651 pm1=0d0
37652 IF(mstu(10).EQ.1) pm1=p(ipa,5)
37653 IF(mstu(10).GE.2) pm1=pymass(kf1)
37654 pm2=0d0
37655 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
37656 IF(mstu(10).GE.2) pm2=pymass(kf2)
37657 pm3=0d0
37658 IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
37659 IF(mstu(10).GE.2) pm3=pymass(kf3)
37660 pm4=0d0
37661 IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
37662 IF(mstu(10).GE.2) pm4=pymass(kf4)
37663 DO 110 i=ipa,ipa+3
37664 DO 100 j=1,5
37665 k(i,j)=0
37666 p(i,j)=0d0
37667 v(i,j)=0d0
37668 100 CONTINUE
37669 110 CONTINUE
37670
37671C...Check flavours.
37672 kq1=kchg(kc1,2)*isign(1,kf1)
37673 kq2=kchg(kc2,2)*isign(1,kf2)
37674 kq3=kchg(kc3,2)*isign(1,kf3)
37675 kq4=kchg(kc4,2)*isign(1,kf4)
37676 IF(mstu(19).EQ.1) THEN
37677 mstu(19)=0
37678 ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
37679 ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
37680 & kq1+kq4.EQ.4)) THEN
37681 ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0d0)
37682 & THEN
37683 ELSE
37684 CALL pyerrm(2,'(PY4ENT:) unphysical flavour combination')
37685 ENDIF
37686 k(ipa,2)=kf1
37687 k(ipa+1,2)=kf2
37688 k(ipa+2,2)=kf3
37689 k(ipa+3,2)=kf4
37690
37691C...Store partons/particles in K vectors for normal case.
37692 IF(ip.GE.0) THEN
37693 k(ipa,1)=1
37694 IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
37695 k(ipa+1,1)=1
37696 IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
37697 & k(ipa+1,1)=2
37698 k(ipa+2,1)=1
37699 IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
37700 k(ipa+3,1)=1
37701
37702C...Store partons for parton shower evolution from q-g-g-qbar or
37703C...g-g-g-g event.
37704 ELSEIF(kq1+kq2.NE.0) THEN
37705 k(ipa,1)=3
37706 k(ipa+1,1)=3
37707 k(ipa+2,1)=3
37708 k(ipa+3,1)=3
37709 kcs=4
37710 IF(kq1.EQ.-1) kcs=5
37711 k(ipa,kcs)=mstu(5)*(ipa+1)
37712 k(ipa,9-kcs)=mstu(5)*(ipa+3)
37713 k(ipa+1,kcs)=mstu(5)*(ipa+2)
37714 k(ipa+1,9-kcs)=mstu(5)*ipa
37715 k(ipa+2,kcs)=mstu(5)*(ipa+3)
37716 k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
37717 k(ipa+3,kcs)=mstu(5)*ipa
37718 k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
37719
37720C...Store partons for parton shower evolution from q-qbar-q-qbar event.
37721 ELSE
37722 k(ipa,1)=3
37723 k(ipa+1,1)=3
37724 k(ipa+2,1)=3
37725 k(ipa+3,1)=3
37726 k(ipa,4)=mstu(5)*(ipa+1)
37727 k(ipa,5)=k(ipa,4)
37728 k(ipa+1,4)=mstu(5)*ipa
37729 k(ipa+1,5)=k(ipa+1,4)
37730 k(ipa+2,4)=mstu(5)*(ipa+3)
37731 k(ipa+2,5)=k(ipa+2,4)
37732 k(ipa+3,4)=mstu(5)*(ipa+2)
37733 k(ipa+3,5)=k(ipa+3,4)
37734 ENDIF
37735
37736C...Check kinematics.
37737 mkerr=0
37738 IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*x2*pecm.LE.pm2.OR.
37739 &0.5d0*(2d0-x1-x2-x4)*pecm.LE.pm3.OR.0.5d0*x4*pecm.LE.pm4)
37740 &mkerr=1
37741 pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
37742 pa2=sqrt(max(1d-10,(0.5d0*x2*pecm)**2-pm2**2))
37743 pa4=sqrt(max(1d-10,(0.5d0*x4*pecm)**2-pm4**2))
37744 x24=x1+x2+x4-1d0-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
37745 cthe4=(x1*x4-2d0*x14)*pecm**2/(4d0*pa1*pa4)
37746 IF(abs(cthe4).GE.1.002d0) mkerr=1
37747 cthe4=max(-1d0,min(1d0,cthe4))
37748 sthe4=sqrt(1d0-cthe4**2)
37749 cthe2=(x1*x2-2d0*x12)*pecm**2/(4d0*pa1*pa2)
37750 IF(abs(cthe2).GE.1.002d0) mkerr=1
37751 cthe2=max(-1d0,min(1d0,cthe2))
37752 sthe2=sqrt(1d0-cthe2**2)
37753 cphi2=((x2*x4-2d0*x24)*pecm**2-4d0*pa2*cthe2*pa4*cthe4)/
37754 &max(1d-8*pecm**2,4d0*pa2*sthe2*pa4*sthe4)
37755 IF(abs(cphi2).GE.1.05d0) mkerr=1
37756 cphi2=max(-1d0,min(1d0,cphi2))
37757 IF(mkerr.EQ.1) CALL pyerrm(13,
37758 &'(PY4ENT:) unphysical kinematical variable setup')
37759
37760C...Store partons/particles in P vectors.
37761 p(ipa,3)=pa1
37762 p(ipa,4)=sqrt(pa1**2+pm1**2)
37763 p(ipa,5)=pm1
37764 p(ipa+3,1)=pa4*sthe4
37765 p(ipa+3,3)=pa4*cthe4
37766 p(ipa+3,4)=sqrt(pa4**2+pm4**2)
37767 p(ipa+3,5)=pm4
37768 p(ipa+1,1)=pa2*sthe2*cphi2
37769 p(ipa+1,2)=pa2*sthe2*sqrt(1d0-cphi2**2)*(-1d0)**int(pyr(0)+0.5d0)
37770 p(ipa+1,3)=pa2*cthe2
37771 p(ipa+1,4)=sqrt(pa2**2+pm2**2)
37772 p(ipa+1,5)=pm2
37773 p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
37774 p(ipa+2,2)=-p(ipa+1,2)
37775 p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
37776 p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
37777 p(ipa+2,5)=pm3
37778
37779C...Set N. Optionally fragment/decay.
37780 n=ipa+3
37781 IF(ip.EQ.0) CALL pyexec
37782
37783 RETURN
37784 END
37785
37786C*********************************************************************
37787
37788C...PY2FRM
37789C...An interface from a two-fermion generator to include
37790C...parton showers and hadronization.
37791
37792 SUBROUTINE py2frm(IRAD,ITAU,ICOM)
37793
37794C...Double precision and integer declarations.
37795 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37796 IMPLICIT INTEGER(I-N)
37797 INTEGER PYK,PYCHGE,PYCOMP
37798C...Commonblocks.
37799 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37800 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37801 SAVE /pyjets/,/pydat1/
37802C...Local arrays.
37803 dimension ijoin(2),intau(2)
37804
37805C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
37806 IF(icom.EQ.0) THEN
37807 mstu(28)=0
37808 CALL pyhepc(2)
37809 ENDIF
37810
37811C...Loop through entries and pick up all final fermions/antifermions.
37812 i1=0
37813 i2=0
37814 DO 100 i=1,n
37815 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
37816 kfa=iabs(k(i,2))
37817 IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
37818 IF(k(i,2).GT.0) THEN
37819 IF(i1.EQ.0) THEN
37820 i1=i
37821 ELSE
37822 CALL pyerrm(16,'(PY2FRM:) more than one fermion')
37823 ENDIF
37824 ELSE
37825 IF(i2.EQ.0) THEN
37826 i2=i
37827 ELSE
37828 CALL pyerrm(16,'(PY2FRM:) more than one antifermion')
37829 ENDIF
37830 ENDIF
37831 ENDIF
37832 100 CONTINUE
37833
37834C...Check that event is arranged according to conventions.
37835 IF(i1.EQ.0.OR.i2.EQ.0) THEN
37836 CALL pyerrm(16,'(PY2FRM:) event contains too few fermions')
37837 ENDIF
37838 IF(i2.LT.i1) THEN
37839 CALL pyerrm(6,'(PY2FRM:) fermions arranged in wrong order')
37840 ENDIF
37841
37842C...Check whether fermion pair is quarks or leptons.
37843 IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
37844 iql12=1
37845 ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
37846 iql12=2
37847 ELSE
37848 CALL pyerrm(16,'(PY2FRM:) fermion pair inconsistent')
37849 ENDIF
37850
37851C...Decide whether to allow or not photon radiation in showers.
37852 mstj(41)=2
37853 IF(irad.EQ.0) mstj(41)=1
37854
37855C...Do colour joining and parton showers.
37856 ip1=i1
37857 ip2=i2
37858 IF(iql12.EQ.1) THEN
37859 ijoin(1)=ip1
37860 ijoin(2)=ip2
37861 CALL pyjoin(2,ijoin)
37862 ENDIF
37863 IF(iql12.EQ.1.OR.irad.EQ.1) THEN
37864 pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
37865 & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
37866 CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
37867 ENDIF
37868
37869C...Do fragmentation and decays. Possibly except tau decay.
37870 IF(itau.EQ.0) THEN
37871 ntau=0
37872 DO 110 i=1,n
37873 IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
37874 ntau=ntau+1
37875 intau(ntau)=i
37876 k(i,1)=11
37877 ENDIF
37878 110 CONTINUE
37879 ENDIF
37880 CALL pyexec
37881 IF(itau.EQ.0) THEN
37882 DO 120 i=1,ntau
37883 k(intau(i),1)=1
37884 120 CONTINUE
37885 ENDIF
37886
37887C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
37888 IF(icom.EQ.0) THEN
37889 mstu(28)=0
37890 CALL pyhepc(1)
37891 ENDIF
37892
37893 END
37894
37895C*********************************************************************
37896
37897C...PY4FRM
37898C...An interface from a four-fermion generator to include
37899C...parton showers and hadronization.
37900
37901 SUBROUTINE py4frm(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
37902
37903C...Double precision and integer declarations.
37904 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37905 IMPLICIT INTEGER(I-N)
37906 INTEGER PYK,PYCHGE,PYCOMP
37907C...Commonblocks.
37908 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37909 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37910 SAVE /pyjets/,/pydat1/
37911C...Local arrays.
37912 dimension ijoin(2),intau(4)
37913
37914C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
37915 IF(icom.EQ.0) THEN
37916 mstu(28)=0
37917 CALL pyhepc(2)
37918 ENDIF
37919
37920C...Loop through entries and pick up all final fermions/antifermions.
37921 i1=0
37922 i2=0
37923 i3=0
37924 i4=0
37925 DO 100 i=1,n
37926 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
37927 kfa=iabs(k(i,2))
37928 IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
37929 IF(k(i,2).GT.0) THEN
37930 IF(i1.EQ.0) THEN
37931 i1=i
37932 ELSEIF(i3.EQ.0) THEN
37933 i3=i
37934 ELSE
37935 CALL pyerrm(16,'(PY4FRM:) more than two fermions')
37936 ENDIF
37937 ELSE
37938 IF(i2.EQ.0) THEN
37939 i2=i
37940 ELSEIF(i4.EQ.0) THEN
37941 i4=i
37942 ELSE
37943 CALL pyerrm(16,'(PY4FRM:) more than two antifermions')
37944 ENDIF
37945 ENDIF
37946 ENDIF
37947 100 CONTINUE
37948
37949C...Check that event is arranged according to conventions.
37950 IF(i3.EQ.0.OR.i4.EQ.0) THEN
37951 CALL pyerrm(16,'(PY4FRM:) event contains too few fermions')
37952 ENDIF
37953 IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
37954 CALL pyerrm(6,'(PY4FRM:) fermions arranged in wrong order')
37955 ENDIF
37956
37957C...Check which fermion pairs are quarks and which leptons.
37958 IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
37959 iql12=1
37960 ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
37961 iql12=2
37962 ELSE
37963 CALL pyerrm(16,'(PY4FRM:) first fermion pair inconsistent')
37964 ENDIF
37965 IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
37966 iql34=1
37967 ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
37968 iql34=2
37969 ELSE
37970 CALL pyerrm(16,'(PY4FRM:) second fermion pair inconsistent')
37971 ENDIF
37972
37973C...Decide whether to allow or not photon radiation in showers.
37974 mstj(41)=2
37975 IF(irad.EQ.0) mstj(41)=1
37976
37977C...Decide on dipole pairing.
37978 ip1=i1
37979 ip2=i2
37980 ip3=i3
37981 ip4=i4
37982 IF(iql12.EQ.iql34) THEN
37983 r1sq=a1sq
37984 r2sq=a2sq
37985 delta=atotsq-a1sq-a2sq
37986 IF(istrat.EQ.1) THEN
37987 IF(delta.GT.0d0) r1sq=r1sq+delta
37988 IF(delta.LT.0d0) r2sq=max(0d0,r2sq+delta)
37989 ELSEIF(istrat.EQ.2) THEN
37990 IF(delta.GT.0d0) r2sq=r2sq+delta
37991 IF(delta.LT.0d0) r1sq=max(0d0,r1sq+delta)
37992 ENDIF
37993 IF(r2sq.GT.pyr(0)*(r1sq+r2sq)) THEN
37994 ip2=i4
37995 ip4=i2
37996 ENDIF
37997 ENDIF
37998
37999C...Do colour joinings and parton showers.
38000 IF(iql12.EQ.1) THEN
38001 ijoin(1)=ip1
38002 ijoin(2)=ip2
38003 CALL pyjoin(2,ijoin)
38004 ENDIF
38005 IF(iql12.EQ.1.OR.irad.EQ.1) THEN
38006 pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
38007 & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
38008 CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
38009 ENDIF
38010 IF(iql34.EQ.1) THEN
38011 ijoin(1)=ip3
38012 ijoin(2)=ip4
38013 CALL pyjoin(2,ijoin)
38014 ENDIF
38015 IF(iql34.EQ.1.OR.irad.EQ.1) THEN
38016 pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
38017 & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
38018 CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
38019 ENDIF
38020
38021C...Do fragmentation and decays. Possibly except tau decay.
38022 IF(itau.EQ.0) THEN
38023 ntau=0
38024 DO 110 i=1,n
38025 IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
38026 ntau=ntau+1
38027 intau(ntau)=i
38028 k(i,1)=11
38029 ENDIF
38030 110 CONTINUE
38031 ENDIF
38032 CALL pyexec
38033 IF(itau.EQ.0) THEN
38034 DO 120 i=1,ntau
38035 k(intau(i),1)=1
38036 120 CONTINUE
38037 ENDIF
38038
38039C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38040 IF(icom.EQ.0) THEN
38041 mstu(28)=0
38042 CALL pyhepc(1)
38043 ENDIF
38044
38045 END
38046
38047C*********************************************************************
38048
38049C...PY6FRM
38050C...An interface from a six-fermion generator to include
38051C...parton showers and hadronization.
38052
38053 SUBROUTINE py6frm(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
38054
38055C...Double precision and integer declarations.
38056 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38057 IMPLICIT INTEGER(I-N)
38058 INTEGER PYK,PYCHGE,PYCOMP
38059C...Commonblocks.
38060 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38061 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38062 SAVE /pyjets/,/pydat1/
38063C...Local arrays.
38064 dimension ijoin(2),intau(6),beta(3),betao(3),betan(3)
38065
38066C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
38067 IF(icom.EQ.0) THEN
38068 mstu(28)=0
38069 CALL pyhepc(2)
38070 ENDIF
38071
38072C...Loop through entries and pick up all final fermions/antifermions.
38073 i1=0
38074 i2=0
38075 i3=0
38076 i4=0
38077 i5=0
38078 i6=0
38079 DO 100 i=1,n
38080 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
38081 kfa=iabs(k(i,2))
38082 IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
38083 IF(k(i,2).GT.0) THEN
38084 IF(i1.EQ.0) THEN
38085 i1=i
38086 ELSEIF(i3.EQ.0) THEN
38087 i3=i
38088 ELSEIF(i5.EQ.0) THEN
38089 i5=i
38090 ELSE
38091 CALL pyerrm(16,'(PY6FRM:) more than three fermions')
38092 ENDIF
38093 ELSE
38094 IF(i2.EQ.0) THEN
38095 i2=i
38096 ELSEIF(i4.EQ.0) THEN
38097 i4=i
38098 ELSEIF(i6.EQ.0) THEN
38099 i6=i
38100 ELSE
38101 CALL pyerrm(16,'(PY6FRM:) more than three antifermions')
38102 ENDIF
38103 ENDIF
38104 ENDIF
38105 100 CONTINUE
38106
38107C...Check that event is arranged according to conventions.
38108 IF(i5.EQ.0.OR.i6.EQ.0) THEN
38109 CALL pyerrm(16,'(PY6FRM:) event contains too few fermions')
38110 ENDIF
38111 IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3.OR.i5.LT.i4.OR.i6.LT.i5) THEN
38112 CALL pyerrm(6,'(PY6FRM:) fermions arranged in wrong order')
38113 ENDIF
38114
38115C...Check which fermion pairs are quarks and which leptons.
38116 IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
38117 iql12=1
38118 ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
38119 iql12=2
38120 ELSE
38121 CALL pyerrm(16,'(PY6FRM:) first fermion pair inconsistent')
38122 ENDIF
38123 IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
38124 iql34=1
38125 ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
38126 iql34=2
38127 ELSE
38128 CALL pyerrm(16,'(PY6FRM:) second fermion pair inconsistent')
38129 ENDIF
38130 IF(iabs(k(i5,2)).LT.10.AND.iabs(k(i6,2)).LT.10) THEN
38131 iql56=1
38132 ELSEIF(iabs(k(i5,2)).GT.10.AND.iabs(k(i6,2)).GT.10) THEN
38133 iql56=2
38134 ELSE
38135 CALL pyerrm(16,'(PY6FRM:) third fermion pair inconsistent')
38136 ENDIF
38137
38138C...Decide whether to allow or not photon radiation in showers.
38139 mstj(41)=2
38140 IF(irad.EQ.0) mstj(41)=1
38141
38142C...Allow dipole pairings only among leptons and quarks separately.
38143 p12d=p12
38144 p13d=0d0
38145 IF(iql34.EQ.iql56) p13d=p13
38146 p21d=0d0
38147 IF(iql12.EQ.iql34) p21d=p21
38148 p23d=0d0
38149 IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p23d=p23
38150 p31d=0d0
38151 IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p31d=p31
38152 p32d=0d0
38153 IF(iql12.EQ.iql56) p32d=p32
38154
38155C...Decide whether t+tbar.
38156 itop=0
38157 IF(pyr(0).LT.ptop) THEN
38158 itop=1
38159
38160C...If t+tbar: reconstruct t's.
38161 it=n+1
38162 itb=n+2
38163 DO 110 j=1,5
38164 k(it,j)=0
38165 k(itb,j)=0
38166 p(it,j)=p(i1,j)+p(i3,j)+p(i4,j)
38167 p(itb,j)=p(i2,j)+p(i5,j)+p(i6,j)
38168 v(it,j)=0d0
38169 v(itb,j)=0d0
38170 110 CONTINUE
38171 k(it,1)=1
38172 k(itb,1)=1
38173 k(it,2)=6
38174 k(itb,2)=-6
38175 p(it,5)=sqrt(max(0d0,p(it,4)**2-p(it,1)**2-p(it,2)**2-
38176 & p(it,3)**2))
38177 p(itb,5)=sqrt(max(0d0,p(itb,4)**2-p(itb,1)**2-p(itb,2)**2-
38178 & p(itb,3)**2))
38179 n=n+2
38180
38181C...If t+tbar: colour join t's and let them shower.
38182 ijoin(1)=it
38183 ijoin(2)=itb
38184 CALL pyjoin(2,ijoin)
38185 pmtts=(p(it,4)+p(itb,4))**2-(p(it,1)+p(itb,1))**2-
38186 & (p(it,2)+p(itb,2))**2-(p(it,3)+p(itb,3))**2
38187 CALL pyshow(it,itb,sqrt(max(0d0,pmtts)))
38188
38189C...If t+tbar: pick up the t's after shower.
38190 itnew=it
38191 itbnew=itb
38192 DO 120 i=itb+1,n
38193 IF(k(i,2).EQ.6) itnew=i
38194 IF(k(i,2).EQ.-6) itbnew=i
38195 120 CONTINUE
38196
38197C...If t+tbar: loop over two top systems.
38198 DO 200 it1=1,2
38199 IF(it1.EQ.1) THEN
38200 ito=it
38201 itn=itnew
38202 ibo=i1
38203 iw1=i3
38204 iw2=i4
38205 ELSE
38206 ito=itb
38207 itn=itbnew
38208 ibo=i2
38209 iw1=i5
38210 iw2=i6
38211 ENDIF
38212 IF(iabs(k(ibo,2)).NE.5) CALL pyerrm(6,
38213 & '(PY6FRM:) not b in t decay')
38214
38215C...If t+tbar: find boost from original to new top frame.
38216 DO 130 j=1,3
38217 betao(j)=p(ito,j)/p(ito,4)
38218 betan(j)=p(itn,j)/p(itn,4)
38219 130 CONTINUE
38220
38221C...If t+tbar: boost copy of b by t shower and connect it in colour.
38222 n=n+1
38223 ib=n
38224 k(ib,1)=3
38225 k(ib,2)=k(ibo,2)
38226 k(ib,3)=itn
38227 DO 140 j=1,5
38228 p(ib,j)=p(ibo,j)
38229 v(ib,j)=0d0
38230 140 CONTINUE
38231 CALL pyrobo(ib,ib,0d0,0d0,-betao(1),-betao(2),-betao(3))
38232 CALL pyrobo(ib,ib,0d0,0d0,betan(1),betan(2),betan(3))
38233 k(ib,4)=mstu(5)*itn
38234 k(ib,5)=mstu(5)*itn
38235 k(itn,4)=k(itn,4)+ib
38236 k(itn,5)=k(itn,5)+ib
38237 k(itn,1)=k(itn,1)+10
38238 k(ibo,1)=k(ibo,1)+10
38239
38240C...If t+tbar: construct W recoiling against b.
38241 n=n+1
38242 iw=n
38243 DO 150 j=1,5
38244 k(iw,j)=0
38245 v(iw,j)=0d0
38246 150 CONTINUE
38247 k(iw,1)=1
38248 kchw=pychge(k(iw1,2))+pychge(k(iw2,2))
38249 IF(iabs(kchw).EQ.3) THEN
38250 k(iw,2)=isign(24,kchw)
38251 ELSE
38252 CALL pyerrm(16,'(PY6FRM:) fermion pair inconsistent with W')
38253 ENDIF
38254 k(iw,3)=iw1
38255
38256C...If t+tbar: construct W momentum, including boost by t shower.
38257 DO 160 j=1,4
38258 p(iw,j)=p(iw1,j)+p(iw2,j)
38259 160 CONTINUE
38260 p(iw,5)=sqrt(max(0d0,p(iw,4)**2-p(iw,1)**2-p(iw,2)**2-
38261 & p(iw,3)**2))
38262 CALL pyrobo(iw,iw,0d0,0d0,-betao(1),-betao(2),-betao(3))
38263 CALL pyrobo(iw,iw,0d0,0d0,betan(1),betan(2),betan(3))
38264
38265C...If t+tbar: boost b and W to top rest frame.
38266 DO 170 j=1,3
38267 beta(j)=(p(ib,j)+p(iw,j))/(p(ib,4)+p(iw,4))
38268 170 CONTINUE
38269 CALL pyrobo(ib,ib,0d0,0d0,-beta(1),-beta(2),-beta(3))
38270 CALL pyrobo(iw,iw,0d0,0d0,-beta(1),-beta(2),-beta(3))
38271
38272C...If t+tbar: let b shower and pick up modified W.
38273 pmts=(p(ib,4)+p(iw,4))**2-(p(ib,1)+p(iw,1))**2-
38274 & (p(ib,2)+p(iw,2))**2-(p(ib,3)+p(iw,3))**2
38275 CALL pyshow(ib,iw,sqrt(max(0d0,pmts)))
38276 DO 180 i=iw,n
38277 IF(iabs(k(i,2)).EQ.24) iwm=i
38278 180 CONTINUE
38279
38280C...If t+tbar: take copy of W decay products.
38281 DO 190 j=1,5
38282 k(n+1,j)=k(iw1,j)
38283 p(n+1,j)=p(iw1,j)
38284 v(n+1,j)=v(iw1,j)
38285 k(n+2,j)=k(iw2,j)
38286 p(n+2,j)=p(iw2,j)
38287 v(n+2,j)=v(iw2,j)
38288 190 CONTINUE
38289 k(iw1,1)=k(iw1,1)+10
38290 k(iw2,1)=k(iw2,1)+10
38291 k(iwm,1)=k(iwm,1)+10
38292 k(iwm,4)=n+1
38293 k(iwm,5)=n+2
38294 k(n+1,3)=iwm
38295 k(n+2,3)=iwm
38296 IF(it1.EQ.1) THEN
38297 i3=n+1
38298 i4=n+2
38299 ELSE
38300 i5=n+1
38301 i6=n+2
38302 ENDIF
38303 n=n+2
38304
38305C...If t+tbar: boost W decay products, first by effects of t shower,
38306C...then by those of b shower. b and its shower simple boost back.
38307 CALL pyrobo(n-1,n,0d0,0d0,-betao(1),-betao(2),-betao(3))
38308 CALL pyrobo(n-1,n,0d0,0d0,betan(1),betan(2),betan(3))
38309 CALL pyrobo(n-1,n,0d0,0d0,-beta(1),-beta(2),-beta(3))
38310 CALL pyrobo(n-1,n,0d0,0d0,-p(iw,1)/p(iw,4),
38311 & -p(iw,2)/p(iw,4),-p(iw,3)/p(iw,4))
38312 CALL pyrobo(n-1,n,0d0,0d0,p(iwm,1)/p(iwm,4),
38313 & p(iwm,2)/p(iwm,4),p(iwm,3)/p(iwm,4))
38314 CALL pyrobo(ib,ib,0d0,0d0,beta(1),beta(2),beta(3))
38315 CALL pyrobo(iw,n,0d0,0d0,beta(1),beta(2),beta(3))
38316 200 CONTINUE
38317 ENDIF
38318
38319C...Decide on dipole pairing.
38320 ip1=i1
38321 ip3=i3
38322 ip5=i5
38323 prn=pyr(0)*(p12d+p13d+p21d+p23d+p31d+p32d)
38324 IF(itop.EQ.1.OR.prn.LT.p12d) THEN
38325 ip2=i2
38326 ip4=i4
38327 ip6=i6
38328 ELSEIF(prn.LT.p12d+p13d) THEN
38329 ip2=i2
38330 ip4=i6
38331 ip6=i4
38332 ELSEIF(prn.LT.p12d+p13d+p21d) THEN
38333 ip2=i4
38334 ip4=i2
38335 ip6=i6
38336 ELSEIF(prn.LT.p12d+p13d+p21d+p23d) THEN
38337 ip2=i4
38338 ip4=i6
38339 ip6=i2
38340 ELSEIF(prn.LT.p12d+p13d+p21d+p23d+p31d) THEN
38341 ip2=i6
38342 ip4=i2
38343 ip6=i4
38344 ELSE
38345 ip2=i6
38346 ip4=i4
38347 ip6=i2
38348 ENDIF
38349
38350C...Do colour joinings and parton showers
38351C...(except ones already made for t+tbar).
38352 IF(itop.EQ.0) THEN
38353 IF(iql12.EQ.1) THEN
38354 ijoin(1)=ip1
38355 ijoin(2)=ip2
38356 CALL pyjoin(2,ijoin)
38357 ENDIF
38358 IF(iql12.EQ.1.OR.irad.EQ.1) THEN
38359 pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
38360 & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
38361 CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
38362 ENDIF
38363 ENDIF
38364 IF(iql34.EQ.1) THEN
38365 ijoin(1)=ip3
38366 ijoin(2)=ip4
38367 CALL pyjoin(2,ijoin)
38368 ENDIF
38369 IF(iql34.EQ.1.OR.irad.EQ.1) THEN
38370 pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
38371 & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
38372 CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
38373 ENDIF
38374 IF(iql56.EQ.1) THEN
38375 ijoin(1)=ip5
38376 ijoin(2)=ip6
38377 CALL pyjoin(2,ijoin)
38378 ENDIF
38379 IF(iql56.EQ.1.OR.irad.EQ.1) THEN
38380 pm56s=(p(ip5,4)+p(ip6,4))**2-(p(ip5,1)+p(ip6,1))**2-
38381 & (p(ip5,2)+p(ip6,2))**2-(p(ip5,3)+p(ip6,3))**2
38382 CALL pyshow(ip5,ip6,sqrt(max(0d0,pm56s)))
38383 ENDIF
38384
38385C...Do fragmentation and decays. Possibly except tau decay.
38386 IF(itau.EQ.0) THEN
38387 ntau=0
38388 DO 210 i=1,n
38389 IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
38390 ntau=ntau+1
38391 intau(ntau)=i
38392 k(i,1)=11
38393 ENDIF
38394 210 CONTINUE
38395 ENDIF
38396 CALL pyexec
38397 IF(itau.EQ.0) THEN
38398 DO 220 i=1,ntau
38399 k(intau(i),1)=1
38400 220 CONTINUE
38401 ENDIF
38402
38403C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38404 IF(icom.EQ.0) THEN
38405 mstu(28)=0
38406 CALL pyhepc(1)
38407 ENDIF
38408
38409 END
38410
38411C*********************************************************************
38412
38413C...PY4JET
38414C...An interface from a four-parton generator to include
38415C...parton showers and hadronization.
38416
38417 SUBROUTINE py4jet(PMAX,IRAD,ICOM)
38418
38419C...Double precision and integer declarations.
38420 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38421 IMPLICIT INTEGER(I-N)
38422 INTEGER PYK,PYCHGE,PYCOMP
38423C...Commonblocks.
38424 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38425 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38426 SAVE /pyjets/,/pydat1/
38427C...Local arrays.
38428 dimension ijoin(2),ptot(4),beta(3)
38429
38430C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
38431 IF(icom.EQ.0) THEN
38432 mstu(28)=0
38433 CALL pyhepc(2)
38434 ENDIF
38435
38436C...Loop through entries and pick up all final partons.
38437 i1=0
38438 i2=0
38439 i3=0
38440 i4=0
38441 DO 100 i=1,n
38442 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
38443 kfa=iabs(k(i,2))
38444 IF((kfa.GE.1.AND.kfa.LE.6).OR.kfa.EQ.21) THEN
38445 IF(k(i,2).GT.0.AND.k(i,2).LE.6) THEN
38446 IF(i1.EQ.0) THEN
38447 i1=i
38448 ELSEIF(i3.EQ.0) THEN
38449 i3=i
38450 ELSE
38451 CALL pyerrm(16,'(PY4JET:) more than two quarks')
38452 ENDIF
38453 ELSEIF(k(i,2).LT.0) THEN
38454 IF(i2.EQ.0) THEN
38455 i2=i
38456 ELSEIF(i4.EQ.0) THEN
38457 i4=i
38458 ELSE
38459 CALL pyerrm(16,'(PY4JET:) more than two antiquarks')
38460 ENDIF
38461 ELSE
38462 IF(i3.EQ.0) THEN
38463 i3=i
38464 ELSEIF(i4.EQ.0) THEN
38465 i4=i
38466 ELSE
38467 CALL pyerrm(16,'(PY4JET:) more than two gluons')
38468 ENDIF
38469 ENDIF
38470 ENDIF
38471 100 CONTINUE
38472
38473C...Check that event is arranged according to conventions.
38474 IF(i1.EQ.0.OR.i2.EQ.0.OR.i3.EQ.0.OR.i4.EQ.0) THEN
38475 CALL pyerrm(16,'(PY4JET:) event contains too few partons')
38476 ENDIF
38477 IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
38478 CALL pyerrm(6,'(PY4JET:) partons arranged in wrong order')
38479 ENDIF
38480
38481C...Check whether second pair are quarks or gluons.
38482 IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
38483 iqg34=1
38484 ELSEIF(k(i3,2).EQ.21.AND.k(i4,2).EQ.21) THEN
38485 iqg34=2
38486 ELSE
38487 CALL pyerrm(16,'(PY4JET:) second parton pair inconsistent')
38488 ENDIF
38489
38490C...Boost partons to their cm frame.
38491 DO 110 j=1,4
38492 ptot(j)=p(i1,j)+p(i2,j)+p(i3,j)+p(i4,j)
38493 110 CONTINUE
38494 ecm=sqrt(max(0d0,ptot(4)**2-ptot(1)**2-ptot(2)**2-ptot(3)**2))
38495 DO 120 j=1,3
38496 beta(j)=ptot(j)/ptot(4)
38497 120 CONTINUE
38498 CALL pyrobo(i1,i1,0d0,0d0,-beta(1),-beta(2),-beta(3))
38499 CALL pyrobo(i2,i2,0d0,0d0,-beta(1),-beta(2),-beta(3))
38500 CALL pyrobo(i3,i3,0d0,0d0,-beta(1),-beta(2),-beta(3))
38501 CALL pyrobo(i4,i4,0d0,0d0,-beta(1),-beta(2),-beta(3))
38502 nsav=n
38503
38504C...Decide and set up shower history for q qbar q' qbar' events.
38505 IF(iqg34.EQ.1) THEN
38506 w1=py4jtw(0,i1,i3,i4)
38507 w2=py4jtw(0,i2,i3,i4)
38508 IF(w1.GT.pyr(0)*(w1+w2)) THEN
38509 CALL py4jts(0,i1,i3,i4,i2,qmax)
38510 ELSE
38511 CALL py4jts(0,i2,i3,i4,i1,qmax)
38512 ENDIF
38513
38514C...Decide and set up shower history for q qbar g g events.
38515 ELSE
38516 w1=py4jtw(i1,i3,i2,i4)
38517 w2=py4jtw(i1,i4,i2,i3)
38518 w3=py4jtw(0,i3,i1,i4)
38519 w4=py4jtw(0,i4,i1,i3)
38520 w5=py4jtw(0,i3,i2,i4)
38521 w6=py4jtw(0,i4,i2,i3)
38522 w7=py4jtw(0,i1,i3,i4)
38523 w8=py4jtw(0,i2,i3,i4)
38524 wr=(w1+w2+w3+w4+w5+w6+w7+w8)*pyr(0)
38525 IF(w1.GT.wr) THEN
38526 CALL py4jts(i1,i3,i2,i4,0,qmax)
38527 ELSEIF(w1+w2.GT.wr) THEN
38528 CALL py4jts(i1,i4,i2,i3,0,qmax)
38529 ELSEIF(w1+w2+w3.GT.wr) THEN
38530 CALL py4jts(0,i3,i1,i4,i2,qmax)
38531 ELSEIF(w1+w2+w3+w4.GT.wr) THEN
38532 CALL py4jts(0,i4,i1,i3,i2,qmax)
38533 ELSEIF(w1+w2+w3+w4+w5.GT.wr) THEN
38534 CALL py4jts(0,i3,i2,i4,i1,qmax)
38535 ELSEIF(w1+w2+w3+w4+w5+w6.GT.wr) THEN
38536 CALL py4jts(0,i4,i2,i3,i1,qmax)
38537 ELSEIF(w1+w2+w3+w4+w5+w6+w7.GT.wr) THEN
38538 CALL py4jts(0,i1,i3,i4,i2,qmax)
38539 ELSE
38540 CALL py4jts(0,i2,i3,i4,i1,qmax)
38541 ENDIF
38542 ENDIF
38543
38544C...Boost back original partons and mark them as deleted.
38545 CALL pyrobo(i1,i1,0d0,0d0,beta(1),beta(2),beta(3))
38546 CALL pyrobo(i2,i2,0d0,0d0,beta(1),beta(2),beta(3))
38547 CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
38548 CALL pyrobo(i4,i4,0d0,0d0,beta(1),beta(2),beta(3))
38549 k(i1,1)=k(i1,1)+10
38550 k(i2,1)=k(i2,1)+10
38551 k(i3,1)=k(i3,1)+10
38552 k(i4,1)=k(i4,1)+10
38553
38554C...Rotate shower initiating partons to be along z axis.
38555 phi=pyangl(p(nsav+1,1),p(nsav+1,2))
38556 CALL pyrobo(nsav+1,nsav+6,0d0,-phi,0d0,0d0,0d0)
38557 the=pyangl(p(nsav+1,3),p(nsav+1,1))
38558 CALL pyrobo(nsav+1,nsav+6,-the,0d0,0d0,0d0,0d0)
38559
38560C...Set up copy of shower initiating partons as on mass shell.
38561 DO 140 i=n+1,n+2
38562 DO 130 j=1,5
38563 k(i,j)=0
38564 p(i,j)=0d0
38565 v(i,j)=v(i1,j)
38566 130 CONTINUE
38567 k(i,1)=1
38568 k(i,2)=k(i-6,2)
38569 140 CONTINUE
38570 IF(k(nsav+1,2).EQ.k(i1,2)) THEN
38571 k(n+1,3)=i1
38572 p(n+1,5)=p(i1,5)
38573 k(n+2,3)=i2
38574 p(n+2,5)=p(i2,5)
38575 ELSE
38576 k(n+1,3)=i2
38577 p(n+1,5)=p(i2,5)
38578 k(n+2,3)=i1
38579 p(n+2,5)=p(i1,5)
38580 ENDIF
38581 pabs=sqrt(max(0d0,(ecm**2-p(n+1,5)**2-p(n+2,5)**2)**2-
38582 &(2d0*p(n+1,5)*p(n+2,5))**2))/(2d0*ecm)
38583 p(n+1,3)=pabs
38584 p(n+1,4)=sqrt(pabs**2+p(n+1,5)**2)
38585 p(n+2,3)=-pabs
38586 p(n+2,4)=sqrt(pabs**2+p(n+2,5)**2)
38587 n=n+2
38588
38589C...Decide whether to allow or not photon radiation in showers.
38590C...Connect up colours.
38591 mstj(41)=2
38592 IF(irad.EQ.0) mstj(41)=1
38593 ijoin(1)=n-1
38594 ijoin(2)=n
38595 CALL pyjoin(2,ijoin)
38596
38597C...Decide on maximum virtuality and do parton shower.
38598 IF(pmax.LT.parj(82)) THEN
38599 pqmax=qmax
38600 ELSE
38601 pqmax=pmax
38602 ENDIF
38603 CALL pyshow(nsav+1,-8,pqmax)
38604
38605C...Rotate and boost back system.
38606 CALL pyrobo(nsav+1,n,the,phi,beta(1),beta(2),beta(3))
38607
38608C...Do fragmentation and decays.
38609 CALL pyexec
38610
38611C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
38612 IF(icom.EQ.0) THEN
38613 mstu(28)=0
38614 CALL pyhepc(1)
38615 ENDIF
38616
38617 RETURN
38618 END
38619
38620C*********************************************************************
38621
38622C...PY4JTW
38623C...Auxiliary to PY4JET, to evaluate weight of configuration.
38624
38625 FUNCTION py4jtw(IA1,IA2,IA3,IA4)
38626
38627C...Double precision and integer declarations.
38628 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38629 IMPLICIT INTEGER(I-N)
38630 INTEGER PYK,PYCHGE,PYCOMP
38631C...Commonblocks.
38632 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38633 SAVE /pyjets/
38634
38635C...First case: when both original partons radiate.
38636C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
38637 IF(ia1.NE.0) THEN
38638 DO 100 j=1,4
38639 p(n+1,j)=p(ia1,j)+p(ia2,j)
38640 p(n+2,j)=p(ia3,j)+p(ia4,j)
38641 100 CONTINUE
38642 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
38643 & p(n+1,3)**2))
38644 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
38645 & p(n+2,3)**2))
38646 z1=p(ia1,4)/p(n+1,4)
38647 wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-p(ia1,5)**2)
38648 z2=p(ia3,4)/p(n+2,4)
38649 wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-p(ia3,5)**2)
38650
38651C...Second case: when one original parton radiates to three.
38652C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
38653 ELSE
38654 DO 110 j=1,4
38655 p(n+2,j)=p(ia3,j)+p(ia4,j)
38656 p(n+1,j)=p(n+2,j)+p(ia2,j)
38657 110 CONTINUE
38658 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
38659 & p(n+1,3)**2))
38660 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
38661 & p(n+2,3)**2))
38662 IF(k(ia2,2).EQ.21) THEN
38663 z1=p(n+2,4)/p(n+1,4)
38664 wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
38665 & p(ia3,5)**2)
38666 ELSE
38667 z1=p(ia2,4)/p(n+1,4)
38668 wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
38669 & p(ia2,5)**2)
38670 ENDIF
38671 z2=p(ia3,4)/p(n+2,4)
38672 IF(k(ia2,2).EQ.21) THEN
38673 wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-
38674 & p(ia3,5)**2)
38675 ELSEIF(k(ia3,2).EQ.21) THEN
38676 wt2=3d0*((1d0-z2*(1d0-z2))**2/(z2*(1d0-z2)))/p(n+2,5)**2
38677 ELSE
38678 wt2=0.5d0*(z2**2+(1d0-z2)**2)
38679 ENDIF
38680 ENDIF
38681
38682C...Total weight.
38683 py4jtw=wt1*wt2
38684
38685 RETURN
38686 END
38687
38688C*********************************************************************
38689
38690C...PY4JTS
38691C...Auxiliary to PY4JET, to set up chosen configuration.
38692
38693 SUBROUTINE py4jts(IA1,IA2,IA3,IA4,IA5,QMAX)
38694
38695C...Double precision and integer declarations.
38696 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38697 IMPLICIT INTEGER(I-N)
38698 INTEGER PYK,PYCHGE,PYCOMP
38699C...Commonblocks.
38700 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38701 SAVE /pyjets/
38702
38703C...Reset info.
38704 DO 110 i=n+1,n+6
38705 DO 100 j=1,5
38706 k(i,j)=0
38707 v(i,j)=v(ia2,j)
38708 100 CONTINUE
38709 k(i,1)=16
38710 110 CONTINUE
38711
38712C...First case: when both original partons radiate.
38713C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
38714 IF(ia1.NE.0) THEN
38715
38716C...Set up flavour and history pointers for new partons.
38717 k(n+1,2)=k(ia1,2)
38718 k(n+2,2)=k(ia3,2)
38719 k(n+3,2)=k(ia1,2)
38720 k(n+4,2)=k(ia2,2)
38721 k(n+5,2)=k(ia3,2)
38722 k(n+6,2)=k(ia4,2)
38723 k(n+1,3)=ia1
38724 k(n+1,4)=n+3
38725 k(n+1,5)=n+4
38726 k(n+2,3)=ia3
38727 k(n+2,4)=n+5
38728 k(n+2,5)=n+6
38729 k(n+3,3)=n+1
38730 k(n+4,3)=n+1
38731 k(n+5,3)=n+2
38732 k(n+6,3)=n+2
38733
38734C...Set up momenta for new partons.
38735 DO 120 j=1,5
38736 p(n+1,j)=p(ia1,j)+p(ia2,j)
38737 p(n+2,j)=p(ia3,j)+p(ia4,j)
38738 p(n+3,j)=p(ia1,j)
38739 p(n+4,j)=p(ia2,j)
38740 p(n+5,j)=p(ia3,j)
38741 p(n+6,j)=p(ia4,j)
38742 120 CONTINUE
38743 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
38744 & p(n+1,3)**2))
38745 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
38746 & p(n+2,3)**2))
38747 qmax=min(p(n+1,5),p(n+2,5))
38748
38749C...Second case: q radiates twice.
38750C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
38751C...IA5=N+2 does not radiate.
38752 ELSEIF(k(ia2,2).EQ.21) THEN
38753
38754C...Set up flavour and history pointers for new partons.
38755 k(n+1,2)=k(ia3,2)
38756 k(n+2,2)=k(ia5,2)
38757 k(n+3,2)=k(ia3,2)
38758 k(n+4,2)=k(ia2,2)
38759 k(n+5,2)=k(ia3,2)
38760 k(n+6,2)=k(ia4,2)
38761 k(n+1,3)=ia3
38762 k(n+1,4)=n+3
38763 k(n+1,5)=n+4
38764 k(n+2,3)=ia5
38765 k(n+3,3)=n+1
38766 k(n+3,4)=n+5
38767 k(n+3,5)=n+6
38768 k(n+4,3)=n+1
38769 k(n+5,3)=n+3
38770 k(n+6,3)=n+3
38771
38772C...Set up momenta for new partons.
38773 DO 130 j=1,5
38774 p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
38775 p(n+2,j)=p(ia5,j)
38776 p(n+3,j)=p(ia3,j)+p(ia4,j)
38777 p(n+4,j)=p(ia2,j)
38778 p(n+5,j)=p(ia3,j)
38779 p(n+6,j)=p(ia4,j)
38780 130 CONTINUE
38781 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
38782 & p(n+1,3)**2))
38783 p(n+3,5)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,1)**2-p(n+3,2)**2-
38784 & p(n+3,3)**2))
38785 qmax=p(n+3,5)
38786
38787C...Third case: q radiates g, g branches.
38788C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
38789C...IA5=N+2 does not radiate.
38790 ELSE
38791
38792C...Set up flavour and history pointers for new partons.
38793 k(n+1,2)=k(ia2,2)
38794 k(n+2,2)=k(ia5,2)
38795 k(n+3,2)=k(ia2,2)
38796 k(n+4,2)=21
38797 k(n+5,2)=k(ia3,2)
38798 k(n+6,2)=k(ia4,2)
38799 k(n+1,3)=ia2
38800 k(n+1,4)=n+3
38801 k(n+1,5)=n+4
38802 k(n+2,3)=ia5
38803 k(n+3,3)=n+1
38804 k(n+4,3)=n+1
38805 k(n+4,4)=n+5
38806 k(n+4,5)=n+6
38807 k(n+5,3)=n+4
38808 k(n+6,3)=n+4
38809
38810C...Set up momenta for new partons.
38811 DO 140 j=1,5
38812 p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
38813 p(n+2,j)=p(ia5,j)
38814 p(n+3,j)=p(ia2,j)
38815 p(n+4,j)=p(ia3,j)+p(ia4,j)
38816 p(n+5,j)=p(ia3,j)
38817 p(n+6,j)=p(ia4,j)
38818 140 CONTINUE
38819 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
38820 & p(n+1,3)**2))
38821 p(n+4,5)=sqrt(max(0d0,p(n+4,4)**2-p(n+4,1)**2-p(n+4,2)**2-
38822 & p(n+4,3)**2))
38823 qmax=p(n+4,5)
38824
38825 ENDIF
38826 n=n+6
38827
38828 RETURN
38829 END
38830
38831C*********************************************************************
38832
38833C...PYJOIN
38834C...Connects a sequence of partons with colour flow indices,
38835C...as required for subsequent shower evolution (or other operations).
38836
38837 SUBROUTINE pyjoin(NJOIN,IJOIN)
38838
38839C...Double precision and integer declarations.
38840 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38841 IMPLICIT INTEGER(I-N)
38842 INTEGER PYK,PYCHGE,PYCOMP
38843C...Commonblocks.
38844 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38845 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38846 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38847 SAVE /pyjets/,/pydat1/,/pydat2/
38848C...Local array.
38849 dimension ijoin(*)
38850
38851C...Check that partons are of right types to be connected.
38852 IF(njoin.LT.2) GOTO 120
38853 kqsum=0
38854 DO 100 ijn=1,njoin
38855 i=ijoin(ijn)
38856 IF(i.LE.0.OR.i.GT.n) GOTO 120
38857 IF(k(i,1).LT.1.OR.k(i,1).GT.3) GOTO 120
38858 kc=pycomp(k(i,2))
38859 IF(kc.EQ.0) GOTO 120
38860 kq=kchg(kc,2)*isign(1,k(i,2))
38861 IF(kq.EQ.0) GOTO 120
38862 IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) GOTO 120
38863 IF(kq.NE.2) kqsum=kqsum+kq
38864 IF(ijn.EQ.1) kqs=kq
38865 100 CONTINUE
38866 IF(kqsum.NE.0) GOTO 120
38867
38868C...Connect the partons sequentially (closing for gluon loop).
38869 kcs=(9-kqs)/2
38870 IF(kqs.EQ.2) kcs=int(4.5d0+pyr(0))
38871 DO 110 ijn=1,njoin
38872 i=ijoin(ijn)
38873 k(i,1)=3
38874 IF(ijn.NE.1) ip=ijoin(ijn-1)
38875 IF(ijn.EQ.1) ip=ijoin(njoin)
38876 IF(ijn.NE.njoin) in=ijoin(ijn+1)
38877 IF(ijn.EQ.njoin) in=ijoin(1)
38878 k(i,kcs)=mstu(5)*in
38879 k(i,9-kcs)=mstu(5)*ip
38880 IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
38881 IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
38882 110 CONTINUE
38883
38884C...Error exit: no action taken.
38885 RETURN
38886 120 CALL pyerrm(12,
38887 &'(PYJOIN:) given entries can not be joined by one string')
38888
38889 RETURN
38890 END
38891
38892C*********************************************************************
38893
38894C...PYGIVE
38895C...Sets values of commonblock variables.
38896
38897 SUBROUTINE pygive(CHIN)
38898
38899C...Double precision and integer declarations.
38900 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38901 IMPLICIT INTEGER(I-N)
38902 INTEGER PYK,PYCHGE,PYCOMP
38903C...Commonblocks.
38904 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38905 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38906 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38907 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
38908 common/pydat4/chaf(500,2)
38909 CHARACTER CHAF*16
38910 common/pydatr/mrpy(6),rrpy(100)
38911 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
38912 common/pypars/mstp(200),parp(200),msti(200),pari(200)
38913 common/pyint1/mint(400),vint(400)
38914 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
38915 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
38916 common/pyint4/mwid(500),wids(500,5)
38917 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
38918 common/pyint6/proc(0:500)
38919 CHARACTER PROC*28
38920 common/pyint7/sigt(0:6,0:6,0:5)
38921 common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
38922 &xpdir(-6:6)
38923 common/pymssm/imss(0:99),rmss(0:99)
38924 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,
38925 &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,
38926 &/pyint5/,/pyint6/,/pyint7/,/pyint8/,/pymssm/
38927C...Local arrays and character variables.
38928 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
38929 &chnew2*28,chnam*6,chvar(49)*6,chalp(2)*26,chind*8,chini*10,
38930 &chinr*16
38931 dimension msvar(49,8)
38932
38933C...For each variable to be translated give: name,
38934C...integer/real/character, no. of indices, lower&upper index bounds.
38935 DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
38936 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
38937 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
38938 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
38939 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
38940 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
38941 DATA ((msvar(i,j),j=1,8),i=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
38942 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
38943 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
38944 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
38945 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
38946 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
38947 &1,1,1,6,4*0, 2,1,1,100,4*0,
38948 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
38949 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
38950 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
38951 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
38952 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
38953 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
38954 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
38955 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
38956 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
38957 DATA chalp/'abcdefghijklmnopqrstuvwxyz',
38958 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
38959
38960C...Length of character variable. Subdivide it into instructions.
38961 IF(mstu(12).GE.1) CALL pylist(0)
38962 chbit=chin//' '
38963 lbit=101
38964 100 lbit=lbit-1
38965 IF(chbit(lbit:lbit).EQ.' ') GOTO 100
38966 ltot=0
38967 DO 110 lcom=1,lbit
38968 IF(chbit(lcom:lcom).EQ.' ') GOTO 110
38969 ltot=ltot+1
38970 chfix(ltot:ltot)=chbit(lcom:lcom)
38971 110 CONTINUE
38972 llow=0
38973 120 lhig=llow+1
38974 130 lhig=lhig+1
38975 IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') GOTO 130
38976 lbit=lhig-llow-1
38977 chbit(1:lbit)=chfix(llow+1:lhig-1)
38978
38979C...Identify commonblock variable.
38980 lnam=1
38981 140 lnam=lnam+1
38982 IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
38983 &lnam.LE.6) GOTO 140
38984 chnam=chbit(1:lnam-1)//' '
38985 DO 160 lcom=1,lnam-1
38986 DO 150 lalp=1,26
38987 IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
38988 & chalp(2)(lalp:lalp)
38989 150 CONTINUE
38990 160 CONTINUE
38991 ivar=0
38992 DO 170 iv=1,49
38993 IF(chnam.EQ.chvar(iv)) ivar=iv
38994 170 CONTINUE
38995 IF(ivar.EQ.0) THEN
38996 CALL pyerrm(18,'(PYGIVE:) do not recognize variable '//chnam)
38997 llow=lhig
38998 IF(llow.LT.ltot) GOTO 120
38999 RETURN
39000 ENDIF
39001
39002C...Identify any indices.
39003 i1=0
39004 i2=0
39005 i3=0
39006 nindx=0
39007 IF(chbit(lnam:lnam).EQ.'(') THEN
39008 lind=lnam
39009 180 lind=lind+1
39010 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 180
39011 chind=' '
39012 IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c')
39013 & .AND.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17))
39014 & THEN
39015 chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
39016 READ(chind,'(I8)') kf
39017 i1=pycomp(kf)
39018 ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
39019 & 'c') THEN
39020 CALL pyerrm(18,'(PYGIVE:) not allowed to use C index for '//
39021 & chnam)
39022 llow=lhig
39023 IF(llow.LT.ltot) GOTO 120
39024 RETURN
39025 ELSE
39026 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
39027 READ(chind,'(I8)') i1
39028 ENDIF
39029 lnam=lind
39030 IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
39031 nindx=1
39032 ENDIF
39033 IF(chbit(lnam:lnam).EQ.',') THEN
39034 lind=lnam
39035 190 lind=lind+1
39036 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 190
39037 chind=' '
39038 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
39039 READ(chind,'(I8)') i2
39040 lnam=lind
39041 IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
39042 nindx=2
39043 ENDIF
39044 IF(chbit(lnam:lnam).EQ.',') THEN
39045 lind=lnam
39046 200 lind=lind+1
39047 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 200
39048 chind=' '
39049 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
39050 READ(chind,'(I8)') i3
39051 lnam=lind+1
39052 nindx=3
39053 ENDIF
39054
39055C...Check that indices allowed.
39056 ierr=0
39057 IF(nindx.NE.msvar(ivar,2)) ierr=1
39058 IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
39059 &ierr=2
39060 IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
39061 &ierr=3
39062 IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
39063 &ierr=4
39064 IF(chbit(lnam:lnam).NE.'=') ierr=5
39065 IF(ierr.GE.1) THEN
39066 CALL pyerrm(18,'(PYGIVE:) unallowed indices for '//
39067 & chbit(1:lnam-1))
39068 llow=lhig
39069 IF(llow.LT.ltot) GOTO 120
39070 RETURN
39071 ENDIF
39072
39073C...Save old value of variable.
39074 IF(ivar.EQ.1) THEN
39075 iold=n
39076 ELSEIF(ivar.EQ.2) THEN
39077 iold=k(i1,i2)
39078 ELSEIF(ivar.EQ.3) THEN
39079 rold=p(i1,i2)
39080 ELSEIF(ivar.EQ.4) THEN
39081 rold=v(i1,i2)
39082 ELSEIF(ivar.EQ.5) THEN
39083 iold=mstu(i1)
39084 ELSEIF(ivar.EQ.6) THEN
39085 rold=paru(i1)
39086 ELSEIF(ivar.EQ.7) THEN
39087 iold=mstj(i1)
39088 ELSEIF(ivar.EQ.8) THEN
39089 rold=parj(i1)
39090 ELSEIF(ivar.EQ.9) THEN
39091 iold=kchg(i1,i2)
39092 ELSEIF(ivar.EQ.10) THEN
39093 rold=pmas(i1,i2)
39094 ELSEIF(ivar.EQ.11) THEN
39095 rold=parf(i1)
39096 ELSEIF(ivar.EQ.12) THEN
39097 rold=vckm(i1,i2)
39098 ELSEIF(ivar.EQ.13) THEN
39099 iold=mdcy(i1,i2)
39100 ELSEIF(ivar.EQ.14) THEN
39101 iold=mdme(i1,i2)
39102 ELSEIF(ivar.EQ.15) THEN
39103 rold=brat(i1)
39104 ELSEIF(ivar.EQ.16) THEN
39105 iold=kfdp(i1,i2)
39106 ELSEIF(ivar.EQ.17) THEN
39107 chold=chaf(i1,i2)
39108 ELSEIF(ivar.EQ.18) THEN
39109 iold=mrpy(i1)
39110 ELSEIF(ivar.EQ.19) THEN
39111 rold=rrpy(i1)
39112 ELSEIF(ivar.EQ.20) THEN
39113 iold=msel
39114 ELSEIF(ivar.EQ.21) THEN
39115 iold=msub(i1)
39116 ELSEIF(ivar.EQ.22) THEN
39117 iold=kfin(i1,i2)
39118 ELSEIF(ivar.EQ.23) THEN
39119 rold=ckin(i1)
39120 ELSEIF(ivar.EQ.24) THEN
39121 iold=mstp(i1)
39122 ELSEIF(ivar.EQ.25) THEN
39123 rold=parp(i1)
39124 ELSEIF(ivar.EQ.26) THEN
39125 iold=msti(i1)
39126 ELSEIF(ivar.EQ.27) THEN
39127 rold=pari(i1)
39128 ELSEIF(ivar.EQ.28) THEN
39129 iold=mint(i1)
39130 ELSEIF(ivar.EQ.29) THEN
39131 rold=vint(i1)
39132 ELSEIF(ivar.EQ.30) THEN
39133 iold=iset(i1)
39134 ELSEIF(ivar.EQ.31) THEN
39135 iold=kfpr(i1,i2)
39136 ELSEIF(ivar.EQ.32) THEN
39137 rold=coef(i1,i2)
39138 ELSEIF(ivar.EQ.33) THEN
39139 iold=icol(i1,i2,i3)
39140 ELSEIF(ivar.EQ.34) THEN
39141 rold=xsfx(i1,i2)
39142 ELSEIF(ivar.EQ.35) THEN
39143 iold=isig(i1,i2)
39144 ELSEIF(ivar.EQ.36) THEN
39145 rold=sigh(i1)
39146 ELSEIF(ivar.EQ.37) THEN
39147 iold=mwid(i1)
39148 ELSEIF(ivar.EQ.38) THEN
39149 rold=wids(i1,i2)
39150 ELSEIF(ivar.EQ.39) THEN
39151 iold=ngen(i1,i2)
39152 ELSEIF(ivar.EQ.40) THEN
39153 rold=xsec(i1,i2)
39154 ELSEIF(ivar.EQ.41) THEN
39155 chold2=proc(i1)
39156 ELSEIF(ivar.EQ.42) THEN
39157 rold=sigt(i1,i2,i3)
39158 ELSEIF(ivar.EQ.43) THEN
39159 rold=xpvmd(i1)
39160 ELSEIF(ivar.EQ.44) THEN
39161 rold=xpanl(i1)
39162 ELSEIF(ivar.EQ.45) THEN
39163 rold=xpanh(i1)
39164 ELSEIF(ivar.EQ.46) THEN
39165 rold=xpbeh(i1)
39166 ELSEIF(ivar.EQ.47) THEN
39167 rold=xpdir(i1)
39168 ELSEIF(ivar.EQ.48) THEN
39169 iold=imss(i1)
39170 ELSEIF(ivar.EQ.49) THEN
39171 rold=rmss(i1)
39172 ENDIF
39173
39174C...Print current value of variable. Loop back.
39175 IF(lnam.GE.lbit) THEN
39176 chbit(lnam:14)=' '
39177 chbit(15:60)=' has the value '
39178 IF(msvar(ivar,1).EQ.1) THEN
39179 WRITE(chbit(51:60),'(I10)') iold
39180 ELSEIF(msvar(ivar,1).EQ.2) THEN
39181 WRITE(chbit(47:60),'(F14.5)') rold
39182 ELSEIF(msvar(ivar,1).EQ.3) THEN
39183 chbit(53:60)=chold
39184 ELSE
39185 chbit(33:60)=chold
39186 ENDIF
39187 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
39188 llow=lhig
39189 IF(llow.LT.ltot) GOTO 120
39190 RETURN
39191 ENDIF
39192
39193C...Read in new variable value.
39194 IF(msvar(ivar,1).EQ.1) THEN
39195 chini=' '
39196 chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
39197 READ(chini,'(I10)') inew
39198 ELSEIF(msvar(ivar,1).EQ.2) THEN
39199 chinr=' '
39200 chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
39201 READ(chinr,*) rnew
39202 ELSEIF(msvar(ivar,1).EQ.3) THEN
39203 chnew=chbit(lnam+1:lbit)//' '
39204 ELSE
39205 chnew2=chbit(lnam+1:lbit)//' '
39206 ENDIF
39207
39208C...Store new variable value.
39209 IF(ivar.EQ.1) THEN
39210 n=inew
39211 ELSEIF(ivar.EQ.2) THEN
39212 k(i1,i2)=inew
39213 ELSEIF(ivar.EQ.3) THEN
39214 p(i1,i2)=rnew
39215 ELSEIF(ivar.EQ.4) THEN
39216 v(i1,i2)=rnew
39217 ELSEIF(ivar.EQ.5) THEN
39218 mstu(i1)=inew
39219 ELSEIF(ivar.EQ.6) THEN
39220 paru(i1)=rnew
39221 ELSEIF(ivar.EQ.7) THEN
39222 mstj(i1)=inew
39223 ELSEIF(ivar.EQ.8) THEN
39224 parj(i1)=rnew
39225 ELSEIF(ivar.EQ.9) THEN
39226 kchg(i1,i2)=inew
39227 ELSEIF(ivar.EQ.10) THEN
39228 pmas(i1,i2)=rnew
39229 ELSEIF(ivar.EQ.11) THEN
39230 parf(i1)=rnew
39231 ELSEIF(ivar.EQ.12) THEN
39232 vckm(i1,i2)=rnew
39233 ELSEIF(ivar.EQ.13) THEN
39234 mdcy(i1,i2)=inew
39235 ELSEIF(ivar.EQ.14) THEN
39236 mdme(i1,i2)=inew
39237 ELSEIF(ivar.EQ.15) THEN
39238 brat(i1)=rnew
39239 ELSEIF(ivar.EQ.16) THEN
39240 kfdp(i1,i2)=inew
39241 ELSEIF(ivar.EQ.17) THEN
39242 chaf(i1,i2)=chnew
39243 ELSEIF(ivar.EQ.18) THEN
39244 mrpy(i1)=inew
39245 ELSEIF(ivar.EQ.19) THEN
39246 rrpy(i1)=rnew
39247 ELSEIF(ivar.EQ.20) THEN
39248 msel=inew
39249 ELSEIF(ivar.EQ.21) THEN
39250 msub(i1)=inew
39251 ELSEIF(ivar.EQ.22) THEN
39252 kfin(i1,i2)=inew
39253 ELSEIF(ivar.EQ.23) THEN
39254 ckin(i1)=rnew
39255 ELSEIF(ivar.EQ.24) THEN
39256 mstp(i1)=inew
39257 ELSEIF(ivar.EQ.25) THEN
39258 parp(i1)=rnew
39259 ELSEIF(ivar.EQ.26) THEN
39260 msti(i1)=inew
39261 ELSEIF(ivar.EQ.27) THEN
39262 pari(i1)=rnew
39263 ELSEIF(ivar.EQ.28) THEN
39264 mint(i1)=inew
39265 ELSEIF(ivar.EQ.29) THEN
39266 vint(i1)=rnew
39267 ELSEIF(ivar.EQ.30) THEN
39268 iset(i1)=inew
39269 ELSEIF(ivar.EQ.31) THEN
39270 kfpr(i1,i2)=inew
39271 ELSEIF(ivar.EQ.32) THEN
39272 coef(i1,i2)=rnew
39273 ELSEIF(ivar.EQ.33) THEN
39274 icol(i1,i2,i3)=inew
39275 ELSEIF(ivar.EQ.34) THEN
39276 xsfx(i1,i2)=rnew
39277 ELSEIF(ivar.EQ.35) THEN
39278 isig(i1,i2)=inew
39279 ELSEIF(ivar.EQ.36) THEN
39280 sigh(i1)=rnew
39281 ELSEIF(ivar.EQ.37) THEN
39282 mwid(i1)=inew
39283 ELSEIF(ivar.EQ.38) THEN
39284 wids(i1,i2)=rnew
39285 ELSEIF(ivar.EQ.39) THEN
39286 ngen(i1,i2)=inew
39287 ELSEIF(ivar.EQ.40) THEN
39288 xsec(i1,i2)=rnew
39289 ELSEIF(ivar.EQ.41) THEN
39290 proc(i1)=chnew2
39291 ELSEIF(ivar.EQ.42) THEN
39292 sigt(i1,i2,i3)=rnew
39293 ELSEIF(ivar.EQ.43) THEN
39294 xpvmd(i1)=rnew
39295 ELSEIF(ivar.EQ.44) THEN
39296 xpanl(i1)=rnew
39297 ELSEIF(ivar.EQ.45) THEN
39298 xpanh(i1)=rnew
39299 ELSEIF(ivar.EQ.46) THEN
39300 xpbeh(i1)=rnew
39301 ELSEIF(ivar.EQ.47) THEN
39302 xpdir(i1)=rnew
39303 ELSEIF(ivar.EQ.48) THEN
39304 imss(i1)=inew
39305 ELSEIF(ivar.EQ.49) THEN
39306 rmss(i1)=rnew
39307 ENDIF
39308
39309C...Write old and new value. Loop back.
39310 chbit(lnam:14)=' '
39311 chbit(15:60)=' changed from to '
39312 IF(msvar(ivar,1).EQ.1) THEN
39313 WRITE(chbit(33:42),'(I10)') iold
39314 WRITE(chbit(51:60),'(I10)') inew
39315 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
39316 ELSEIF(msvar(ivar,1).EQ.2) THEN
39317 WRITE(chbit(29:42),'(F14.5)') rold
39318 WRITE(chbit(47:60),'(F14.5)') rnew
39319 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
39320 ELSEIF(msvar(ivar,1).EQ.3) THEN
39321 chbit(35:42)=chold
39322 chbit(53:60)=chnew
39323 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
39324 ELSE
39325 chbit(15:88)=' changed from '//chold2//' to '//chnew2
39326 IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
39327 ENDIF
39328 llow=lhig
39329 IF(llow.LT.ltot) GOTO 120
39330
39331C...Format statement for output on unit MSTU(11) (by default 6).
39332 5000 FORMAT(5x,a60)
39333 5100 FORMAT(5x,a88)
39334
39335 RETURN
39336 END
39337
39338C*********************************************************************
39339
39340C...PYEXEC
39341C...Administrates the fragmentation and decay chain.
39342
39343 SUBROUTINE pyexec
39344
39345C...Double precision and integer declarations.
39346 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39347 IMPLICIT INTEGER(I-N)
39348 INTEGER PYK,PYCHGE,PYCOMP
39349C...Commonblocks.
39350 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
39351 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39352 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39353 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
39354 common/pyint4/mwid(500),wids(500,5)
39355 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint4/
39356C...Local array.
39357 dimension ps(2,6),ijoin(100)
39358
39359C...Initialize and reset.
39360 mstu(24)=0
39361 IF(mstu(12).GE.1) CALL pylist(0)
39362 mstu(31)=mstu(31)+1
39363 mstu(1)=0
39364 mstu(2)=0
39365 mstu(3)=0
39366 IF(mstu(17).LE.0) mstu(90)=0
39367 mcons=1
39368
39369C...Sum up momentum, energy and charge for starting entries.
39370 nsav=n
39371 DO 110 i=1,2
39372 DO 100 j=1,6
39373 ps(i,j)=0d0
39374 100 CONTINUE
39375 110 CONTINUE
39376 DO 130 i=1,n
39377 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 130
39378 DO 120 j=1,4
39379 ps(1,j)=ps(1,j)+p(i,j)
39380 120 CONTINUE
39381 ps(1,6)=ps(1,6)+pychge(k(i,2))
39382 130 CONTINUE
39383 paru(21)=ps(1,4)
39384
39385C...Prepare system for subsequent fragmentation/decay.
39386 CALL pyprep(0)
39387
39388C...Loop through jet fragmentation and particle decays.
39389 mbe=0
39390 140 mbe=mbe+1
39391 ip=0
39392 150 ip=ip+1
39393 kc=0
39394 IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=pycomp(k(ip,2))
39395 IF(kc.EQ.0) THEN
39396
39397C...Deal with any remaining undecayed resonance
39398C...(normally the task of PYEVNT, so seldom used).
39399 ELSEIF(mwid(kc).NE.0) THEN
39400 ibeg=ip
39401 IF(kchg(kc,2).NE.0.AND.k(i,1).NE.3) THEN
39402 ibeg=ip+1
39403 160 ibeg=ibeg-1
39404 IF(ibeg.GE.2.AND.k(ibeg,1).EQ.2) GOTO 160
39405 IF(k(ibeg,1).NE.2) ibeg=ibeg+1
39406 iend=ip-1
39407 170 iend=iend+1
39408 IF(iend.LT.n.AND.k(iend,1).EQ.2) GOTO 170
39409 IF(iend.LT.n.AND.kchg(pycomp(k(iend,2)),2).EQ.0) GOTO 170
39410 njoin=0
39411 DO 180 i=ibeg,iend
39412 IF(kchg(pycomp(k(iend,2)),2).NE.0) THEN
39413 njoin=njoin+1
39414 ijoin(njoin)=i
39415 ENDIF
39416 180 CONTINUE
39417 ENDIF
39418 CALL pyresd(ip)
39419 CALL pyprep(ibeg)
39420
39421C...Particle decay if unstable and allowed. Save long-lived particle
39422C...decays until second pass after Bose-Einstein effects.
39423 ELSEIF(kchg(kc,2).EQ.0) THEN
39424 IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe
39425 & .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
39426 & CALL pydecy(ip)
39427
39428C...Decay products may develop a shower.
39429 IF(mstj(92).GT.0) THEN
39430 ip1=mstj(92)
39431 qmax=sqrt(max(0d0,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
39432 & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
39433 CALL pyshow(ip1,ip1+1,qmax)
39434 CALL pyprep(ip1)
39435 mstj(92)=0
39436 ELSEIF(mstj(92).LT.0) THEN
39437 ip1=-mstj(92)
39438 CALL pyshow(ip1,-3,p(ip,5))
39439 CALL pyprep(ip1)
39440 mstj(92)=0
39441 ENDIF
39442
39443C...Jet fragmentation: string or independent fragmentation.
39444 ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
39445 mfrag=mstj(1)
39446 IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
39447 IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
39448 IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
39449 & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
39450 IF(kchg(pycomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
39451 ENDIF
39452 ENDIF
39453 IF(mfrag.EQ.1) CALL pystrf(ip)
39454 IF(mfrag.EQ.2) CALL pyindf(ip)
39455 IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
39456 IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
39457 ENDIF
39458
39459C...Loop back if enough space left in PYJETS and no error abort.
39460 IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
39461 ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
39462 GOTO 150
39463 ELSEIF(ip.LT.n) THEN
39464 CALL pyerrm(11,'(PYEXEC:) no more memory left in PYJETS')
39465 ENDIF
39466
39467C...Include simple Bose-Einstein effect parametrization if desired.
39468 IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
39469 CALL pyboei(nsav)
39470 GOTO 140
39471 ENDIF
39472
39473C...Check that momentum, energy and charge were conserved.
39474 DO 200 i=1,n
39475 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 200
39476 DO 190 j=1,4
39477 ps(2,j)=ps(2,j)+p(i,j)
39478 190 CONTINUE
39479 ps(2,6)=ps(2,6)+pychge(k(i,2))
39480 200 CONTINUE
39481 pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
39482 &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1d0+abs(ps(2,4))+abs(ps(1,4)))
39483 IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL pyerrm(15,
39484 &'(PYEXEC:) four-momentum was not conserved')
39485 IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1d0) CALL pyerrm(15,
39486 &'(PYEXEC:) charge was not conserved')
39487
39488 RETURN
39489 END
39490
39491C*********************************************************************
39492
39493C...PYPREP
39494C...Rearranges partons along strings.
39495C...Allows small systems to collapse into one or two particles.
39496C...Checks flavours and colour singlet invarient masses.
39497
39498 SUBROUTINE pyprep(IP)
39499
39500C...Double precision and integer declarations.
39501 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39502 INTEGER PYK,PYCHGE,PYCOMP
39503C...Commonblocks.
39504 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
39505 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39506 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39507 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
39508 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
39509C...Local arrays.
39510 dimension dps(5),dpc(5),ue(3),pg(5),
39511 &e1(3),e2(3),e3(3),e4(3),ecl(3)
39512
39513C...Function to give four-product.
39514 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)
39515
39516C...Rearrange parton shower product listing along strings: begin loop.
39517 i1=n
39518 DO 130 mqgst=1,2
39519 DO 120 i=max(1,ip),n
39520 IF(k(i,1).NE.3) GOTO 120
39521 kc=pycomp(k(i,2))
39522 IF(kc.EQ.0) GOTO 120
39523 kq=kchg(kc,2)
39524 IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 120
39525
39526C...Pick up loose string end.
39527 kcs=4
39528 IF(kq*isign(1,k(i,2)).LT.0) kcs=5
39529 ia=i
39530 nstp=0
39531 100 nstp=nstp+1
39532 IF(nstp.GT.4*n) THEN
39533 CALL pyerrm(14,'(PYPREP:) caught in infinite loop')
39534 RETURN
39535 ENDIF
39536
39537C...Copy undecayed parton.
39538 IF(k(ia,1).EQ.3) THEN
39539 IF(i1.GE.mstu(4)-mstu(32)-5) THEN
39540 CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
39541 RETURN
39542 ENDIF
39543 i1=i1+1
39544 k(i1,1)=2
39545 IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) k(i1,1)=1
39546 k(i1,2)=k(ia,2)
39547 k(i1,3)=ia
39548 k(i1,4)=0
39549 k(i1,5)=0
39550 DO 110 j=1,5
39551 p(i1,j)=p(ia,j)
39552 v(i1,j)=v(ia,j)
39553 110 CONTINUE
39554 k(ia,1)=k(ia,1)+10
39555 IF(k(i1,1).EQ.1) GOTO 120
39556 ENDIF
39557
39558C...Go to next parton in colour space.
39559 ib=ia
39560 IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
39561 & .NE.0) THEN
39562 ia=mod(k(ib,kcs),mstu(5))
39563 k(ib,kcs)=k(ib,kcs)+mstu(5)**2
39564 mrev=0
39565 ELSE
39566 IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
39567 & mstu(5)).EQ.0) kcs=9-kcs
39568 ia=mod(k(ib,kcs)/mstu(5),mstu(5))
39569 k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
39570 mrev=1
39571 ENDIF
39572 IF(ia.LE.0.OR.ia.GT.n) THEN
39573 CALL pyerrm(12,'(PYPREP:) colour rearrangement failed')
39574 RETURN
39575 ENDIF
39576 IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
39577 & mstu(5)).EQ.ib) THEN
39578 IF(mrev.EQ.1) kcs=9-kcs
39579 IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
39580 k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
39581 ELSE
39582 IF(mrev.EQ.0) kcs=9-kcs
39583 IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
39584 k(ia,kcs)=k(ia,kcs)+mstu(5)**2
39585 ENDIF
39586 IF(ia.NE.i) GOTO 100
39587 k(i1,1)=1
39588 120 CONTINUE
39589 130 CONTINUE
39590 n=i1
39591
39592C...Done if no checks on small-mass systems.
39593 IF(mstj(14).LT.0) RETURN
39594 IF(mstj(14).EQ.0) GOTO 540
39595
39596C...Find lowest-mass colour singlet jet system.
39597 ns=n
39598 140 nsin=n-ns
39599 pdmin=1d0+parj(32)
39600 ic=0
39601 DO 190 i=max(1,ip),n
39602 IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
39603 ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
39604 nsin=nsin+1
39605 ic=i
39606 DO 150 j=1,4
39607 dps(j)=p(i,j)
39608 150 CONTINUE
39609 mstj(93)=1
39610 dps(5)=pymass(k(i,2))
39611 ELSEIF(k(i,1).EQ.2) THEN
39612 DO 160 j=1,4
39613 dps(j)=dps(j)+p(i,j)
39614 160 CONTINUE
39615 ELSEIF(ic.NE.0.AND.kchg(pycomp(k(i,2)),2).NE.0) THEN
39616 DO 170 j=1,4
39617 dps(j)=dps(j)+p(i,j)
39618 170 CONTINUE
39619 mstj(93)=1
39620 dps(5)=dps(5)+pymass(k(i,2))
39621 pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-
39622 & dps(5)
39623 IF(pd.LT.pdmin) THEN
39624 pdmin=pd
39625 DO 180 j=1,5
39626 dpc(j)=dps(j)
39627 180 CONTINUE
39628 ic1=ic
39629 ic2=i
39630 ENDIF
39631 ic=0
39632 ELSE
39633 nsin=nsin+1
39634 ENDIF
39635 190 CONTINUE
39636
39637C...Done if lowest-mass system above threshold for string frag.
39638 IF(pdmin.GE.parj(32)) GOTO 540
39639
39640C...Fill small-mass system as cluster.
39641 nsav=n
39642 pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
39643 k(n+1,1)=11
39644 k(n+1,2)=91
39645 k(n+1,3)=ic1
39646 p(n+1,1)=dpc(1)
39647 p(n+1,2)=dpc(2)
39648 p(n+1,3)=dpc(3)
39649 p(n+1,4)=dpc(4)
39650 p(n+1,5)=pecm
39651
39652C...Set up history, assuming cluster -> 2 hadrons.
39653 nbody=2
39654 k(n+1,4)=n+2
39655 k(n+1,5)=n+3
39656 k(n+2,1)=1
39657 k(n+3,1)=1
39658 IF(mstu(16).NE.2) THEN
39659 k(n+2,3)=n+1
39660 k(n+3,3)=n+1
39661 ELSE
39662 k(n+2,3)=ic1
39663 k(n+3,3)=ic2
39664 ENDIF
39665 k(n+2,4)=0
39666 k(n+3,4)=0
39667 k(n+2,5)=0
39668 k(n+3,5)=0
39669 v(n+1,5)=0d0
39670 v(n+2,5)=0d0
39671 v(n+3,5)=0d0
39672
39673C...Form two particles from flavours of lowest-mass system, if feasible.
39674 ntry = 0
39675 200 ntry = ntry + 1
39676C...Open string.
39677 IF(iabs(k(ic1,2)).NE.21) THEN
39678 kc1=pycomp(k(ic1,2))
39679 kc2=pycomp(k(ic2,2))
39680 IF(kc1.EQ.0.OR.kc2.EQ.0) GOTO 540
39681 kq1=kchg(kc1,2)*isign(1,k(ic1,2))
39682 kq2=kchg(kc2,2)*isign(1,k(ic2,2))
39683 IF(kq1+kq2.NE.0) GOTO 540
39684C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
39685 210 k1=k(ic1,2)
39686 IF(iabs(k(ic2,2)).GT.10) k1=k(ic2,2)
39687 mstu(125)=0
39688 CALL pydcyk(k1,0,kfln,k(n+2,2))
39689 CALL pydcyk(k(ic1,2)+k(ic2,2)-k1,-kfln,kfldmp,k(n+3,2))
39690 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 210
39691C...Closed string.
39692 ELSE
39693 IF(iabs(k(ic2,2)).NE.21) GOTO 540
39694C...No room for popcorn mesons in closed string -> 2 hadrons.
39695 mstu(125)=0
39696 220 CALL pydcyk(1+int((2d0+parj(2))*pyr(0)),0,kfln,kfdmp)
39697 CALL pydcyk(kfln,0,kflm,k(n+2,2))
39698 CALL pydcyk(-kfln,-kflm,kfldmp,k(n+3,2))
39699 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 220
39700 ENDIF
39701 p(n+2,5)=pymass(k(n+2,2))
39702 p(n+3,5)=pymass(k(n+3,2))
39703
39704C...If it does not work: try again (a number of times), give up
39705C...(if no place to shuffle momentum), or form one hadron.
39706 IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) THEN
39707 IF(ntry.LT.mstj(17)) THEN
39708 GOTO 200
39709 ELSEIF(nsin.EQ.1) THEN
39710 GOTO 540
39711 ELSE
39712 GOTO 290
39713 END IF
39714 END IF
39715
39716C...Perform two-particle decay of jet system.
39717C...First step: find reference axis in decaying system rest frame.
39718C...(Borrow slot N+2 for temporary direction.)
39719 DO 230 j=1,4
39720 p(n+2,j)=p(ic1,j)
39721 230 CONTINUE
39722 DO 250 i=ic1+1,ic2-1
39723 IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
39724 & kchg(pycomp(k(i,2)),2).NE.0) THEN
39725 frac1=four(ic2,i)/(four(ic1,i)+four(ic2,i))
39726 DO 240 j=1,4
39727 p(n+2,j)=p(n+2,j)+frac1*p(i,j)
39728 240 CONTINUE
39729 ENDIF
39730 250 CONTINUE
39731 CALL pyrobo(n+2,n+2,0d0,0d0,-dpc(1)/dpc(4),-dpc(2)/dpc(4),
39732 &-dpc(3)/dpc(4))
39733 the1=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
39734 phi1=pyangl(p(n+2,1),p(n+2,2))
39735
39736C...Second step: generate isotropic/anisotropic decay.
39737 pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
39738 &(p(n+2,5)-p(n+3,5))**2))/(2d0*pecm)
39739 260 ue(3)=pyr(0)
39740 pt2=(1d0-ue(3)**2)*pa**2
39741 IF(mstj(16).LE.0) THEN
39742 prev=0.5d0
39743 ELSE
39744 IF(exp(-pt2/(2d0*parj(21)**2)).LT.pyr(0)) GOTO 260
39745 pr1=p(n+2,5)**2+pt2
39746 pr2=p(n+3,5)**2+pt2
39747 alambd=sqrt(max(0d0,(pecm**2-pr1-pr2)**2-4d0*pr1*pr2))
39748 prevcf=parj(42)
39749 IF(mstj(11).EQ.2) prevcf=parj(39)
39750 prev=1d0/(1d0+exp(min(50d0,prevcf*alambd)))
39751 ENDIF
39752 IF(pyr(0).LT.prev) ue(3)=-ue(3)
39753 phi=paru(2)*pyr(0)
39754 ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
39755 ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
39756 DO 270 j=1,3
39757 p(n+2,j)=pa*ue(j)
39758 p(n+3,j)=-pa*ue(j)
39759 270 CONTINUE
39760 p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
39761 p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
39762
39763C...Third step: move back to event frame and set production vertex.
39764 CALL pyrobo(n+2,n+3,the1,phi1,dpc(1)/dpc(4),dpc(2)/dpc(4),
39765 &dpc(3)/dpc(4))
39766 DO 280 j=1,4
39767 v(n+1,j)=v(ic1,j)
39768 v(n+2,j)=v(ic1,j)
39769 v(n+3,j)=v(ic2,j)
39770 280 CONTINUE
39771 n=n+3
39772 GOTO 520
39773
39774C...Else form one particle, if possible.
39775 290 nbody=1
39776 k(n+1,5)=n+2
39777 DO 300 j=1,4
39778 v(n+1,j)=v(ic1,j)
39779 v(n+2,j)=v(ic1,j)
39780 300 CONTINUE
39781
39782C...Select hadron flavour from available quark flavours.
39783 310 IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
39784 GOTO 540
39785 ELSEIF(iabs(k(ic1,2)).NE.21) THEN
39786 CALL pykfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
39787 ELSE
39788 kfln=1+int((2d0+parj(2))*pyr(0))
39789 CALL pykfdi(kfln,-kfln,kfldmp,k(n+2,2))
39790 ENDIF
39791 IF(k(n+2,2).EQ.0) GOTO 310
39792 p(n+2,5)=pymass(k(n+2,2))
39793
39794C...Use old algorithm for E/p conservation? (EN)
39795 IF (mstj(16).LE.0) GOTO 480
39796
39797C...Find the string piece closest to the cluster by a loop
39798C...over the undecayed partons not in present cluster. (EN)
39799 dglomi=1d30
39800 ibeg=0
39801 i0=0
39802 DO 340 i1=max(1,ip),n-1
39803 IF(i1.GE.ic1-1.AND.i1.LE.ic2) THEN
39804 i0=0
39805 ELSEIF(k(i1,1).EQ.2) THEN
39806 IF(i0.EQ.0) i0=i1
39807 i2=i1
39808 320 i2=i2+1
39809 IF(kchg(pycomp(k(i2,2)),2).EQ.0) GOTO 320
39810
39811C...Define velocity vectors e1, e2, ecl and differences e3, e4.
39812 DO 330 j=1,3
39813 e1(j)=p(i1,j)/p(i1,4)
39814 e2(j)=p(i2,j)/p(i2,4)
39815 ecl(j)=p(n+1,j)/p(n+1,4)
39816 e3(j)=e2(j)-e1(j)
39817 e4(j)=ecl(j)-e1(j)
39818 330 CONTINUE
39819
39820C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
39821 e3s=e3(1)**2+e3(2)**2+e3(3)**2
39822 e4s=e4(1)**2+e4(2)**2+e4(3)**2
39823 e34=e3(1)*e4(1)+e3(2)*e4(2)+e3(3)*e4(3)
39824 IF(e34.LE.0d0) THEN
39825 ddmin=e4s
39826 ELSEIF(e34.LT.e3s) THEN
39827 ddmin=e4s-e34**2/e3s
39828 ELSE
39829 ddmin=e4s-2d0*e34+e3s
39830 ENDIF
39831
39832C...Is this the smallest so far?
39833 IF(ddmin.LT.dglomi) THEN
39834 dglomi=ddmin
39835 ibeg=i0
39836 ipcs=i1
39837 ENDIF
39838 ELSEIF(k(i1,1).EQ.1.AND.kchg(pycomp(k(i1,2)),2).NE.0) THEN
39839 i0=0
39840 ENDIF
39841 340 CONTINUE
39842
39843C... Check if there are any strings to connect to the new gluon. (EN)
39844 IF (ibeg.EQ.0) GOTO 480
39845
39846C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
39847 IF (p(n+1,5).GE.p(n+2,5)) THEN
39848
39849C...Construct 'gluon' that is needed to put hadron on the mass shell.
39850 frac=p(n+2,5)/p(n+1,5)
39851 DO 350 j=1,5
39852 p(n+2,j)=frac*p(n+1,j)
39853 pg(j)=(1d0-frac)*p(n+1,j)
39854 350 CONTINUE
39855
39856C... Copy string with new gluon put in.
39857 n=n+2
39858 i=ibeg-1
39859 360 i=i+1
39860 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 360
39861 IF(kchg(pycomp(k(i,2)),2).EQ.0) GOTO 360
39862 n=n+1
39863 DO 370 j=1,5
39864 k(n,j)=k(i,j)
39865 p(n,j)=p(i,j)
39866 v(n,j)=v(i,j)
39867 370 CONTINUE
39868 k(i,1)=k(i,1)+10
39869 k(i,4)=n
39870 k(i,5)=n
39871 k(n,3)=i
39872 IF(i.EQ.ipcs) THEN
39873 n=n+1
39874 DO 380 j=1,5
39875 k(n,j)=k(n-1,j)
39876 p(n,j)=pg(j)
39877 v(n,j)=v(n-1,j)
39878 380 CONTINUE
39879 k(n,2)=21
39880 k(n,3)=nsav+1
39881 ENDIF
39882 IF(k(i,1).EQ.12) GOTO 360
39883 GOTO 520
39884
39885C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
39886C...from string piece endpoints.
39887 ELSE
39888
39889C...Begin by copying string that should give energy to cluster.
39890 n=n+2
39891 i=ibeg-1
39892 390 i=i+1
39893 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 390
39894 IF(kchg(pycomp(k(i,2)),2).EQ.0) GOTO 390
39895 n=n+1
39896 DO 400 j=1,5
39897 k(n,j)=k(i,j)
39898 p(n,j)=p(i,j)
39899 v(n,j)=v(i,j)
39900 400 CONTINUE
39901 k(i,1)=k(i,1)+10
39902 k(i,4)=n
39903 k(i,5)=n
39904 k(n,3)=i
39905 IF(i.EQ.ipcs) i1=n
39906 IF(k(i,1).EQ.12) GOTO 390
39907 i2=i1+1
39908
39909C...Set initial Phad.
39910 DO 410 j=1,4
39911 p(nsav+2,j)=p(nsav+1,j)
39912 410 CONTINUE
39913
39914C...Calculate Pg, a part of which will be added to Phad later. (EN)
39915 420 IF(mstj(16).EQ.1) THEN
39916 alpha=1d0
39917 beta=1d0
39918 ELSE
39919 alpha=four(nsav+1,i2)/four(i1,i2)
39920 beta=four(nsav+1,i1)/four(i1,i2)
39921 ENDIF
39922 DO 430 j=1,4
39923 pg(j)=alpha*p(i1,j)+beta*p(i2,j)
39924 430 CONTINUE
39925 pg(5)=sqrt(max(1d-20,pg(4)**2-pg(1)**2-pg(2)**2-pg(3)**2))
39926
39927C..Solve 2nd order equation, use the best (smallest) solution. (EN)
39928 pmscol=p(nsav+2,4)**2-p(nsav+2,1)**2-p(nsav+2,2)**2-
39929 & p(nsav+2,3)**2
39930 pclpg=(p(nsav+2,4)*pg(4)-p(nsav+2,1)*pg(1)-
39931 & p(nsav+2,2)*pg(2)-p(nsav+2,3)*pg(3))/pg(5)**2
39932 delta=sqrt(pclpg**2+(p(nsav+2,5)**2-pmscol)/pg(5)**2)-pclpg
39933
39934C...If all gluon energy eaten, zero it and take a step back.
39935 iter=0
39936 IF(delta*alpha.GT.1d0.AND.i1.GT.nsav+3) THEN
39937 iter=1
39938 DO 440 j=1,4
39939 p(nsav+2,j)=p(nsav+2,j)+p(i1,j)
39940 p(i1,j)=0d0
39941 440 CONTINUE
39942 p(i1,5)=0d0
39943 i1=i1-1
39944 ENDIF
39945 IF(delta*beta.GT.1d0.AND.i2.LT.n) THEN
39946 iter=1
39947 DO 450 j=1,4
39948 p(nsav+2,j)=p(nsav+2,j)+p(i2,j)
39949 p(i2,j)=0d0
39950 450 CONTINUE
39951 p(i2,5)=0d0
39952 i2=i2+1
39953 ENDIF
39954 IF(iter.EQ.1) GOTO 420
39955
39956C...If also all endpoint energy eaten, revert to old procedure.
39957 IF((1d0-delta*alpha)*p(i1,4).LT.p(i1,5).OR.
39958 & (1d0-delta*beta)*p(i2,4).LT.p(i2,5)) THEN
39959 DO 460 i=nsav+3,n
39960 im=k(i,3)
39961 k(im,1)=k(im,1)-10
39962 k(im,4)=0
39963 k(im,5)=0
39964 460 CONTINUE
39965 n=nsav
39966 GOTO 480
39967 ENDIF
39968
39969C... Construct the collapsed hadron and modified string partons.
39970 DO 470 j=1,4
39971 p(nsav+2,j)=p(nsav+2,j)+delta*pg(j)
39972 p(i1,j)=(1d0-delta*alpha)*p(i1,j)
39973 p(i2,j)=(1d0-delta*beta)*p(i2,j)
39974 470 CONTINUE
39975 p(i1,5)=(1d0-delta*alpha)*p(i1,5)
39976 p(i2,5)=(1d0-delta*beta)*p(i2,5)
39977
39978C...Finished with string collapse in new scheme.
39979 GOTO 520
39980 ENDIF
39981
39982C... Use old algorithm; by choice or when in trouble.
39983 480 CONTINUE
39984C...Find parton/particle which combines to largest extra mass.
39985 ir=0
39986 ha=0d0
39987 hsm=0d0
39988 DO 500 mcomb=1,3
39989 IF(ir.NE.0) GOTO 500
39990 DO 490 i=max(1,ip),n
39991 IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
39992 & .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) GOTO 490
39993 IF(mcomb.EQ.1) kci=pycomp(k(i,2))
39994 IF(mcomb.EQ.1.AND.kci.EQ.0) GOTO 490
39995 IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) GOTO 490
39996 IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
39997 & GOTO 490
39998 hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
39999 hsr=2d0*hcr+pecm**2-p(n+2,5)**2-2d0*p(n+2,5)*p(i,5)
40000 IF(hsr.GT.hsm) THEN
40001 ir=i
40002 ha=hcr
40003 hsm=hsr
40004 ENDIF
40005 490 CONTINUE
40006 500 CONTINUE
40007
40008C...Shuffle energy and momentum to put new particle on mass shell.
40009 IF(ir.NE.0) THEN
40010 hb=pecm**2+ha
40011 hc=p(n+2,5)**2+ha
40012 hd=p(ir,5)**2+ha
40013 hk2=0.5d0*(hb*sqrt(max(0d0,((hb+hc)**2-4d0*(hb+hd)*p(n+2,5)**2)/
40014 & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
40015 hk1=(0.5d0*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
40016 DO 510 j=1,4
40017 p(n+2,j)=(1d0+hk1)*dpc(j)-hk2*p(ir,j)
40018 p(ir,j)=(1d0+hk2)*p(ir,j)-hk1*dpc(j)
40019 510 CONTINUE
40020 n=n+2
40021 ELSE
40022 CALL pyerrm(3,'(PYPREP:) no match for collapsing cluster')
40023 RETURN
40024 ENDIF
40025
40026C...Mark collapsed system and store daughter pointers. Iterate.
40027 520 DO 530 i=ic1,ic2
40028 IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
40029 & kchg(pycomp(k(i,2)),2).NE.0) THEN
40030 k(i,1)=k(i,1)+10
40031 IF(mstu(16).NE.2) THEN
40032 k(i,4)=nsav+1
40033 k(i,5)=nsav+1
40034 ELSE
40035 k(i,4)=nsav+2
40036 k(i,5)=nsav+1+nbody
40037 ENDIF
40038 ENDIF
40039 530 CONTINUE
40040 IF(n.LT.mstu(4)-mstu(32)-5) GOTO 140
40041
40042C...Check flavours and invariant masses in parton systems.
40043 540 np=0
40044 kfn=0
40045 kqs=0
40046 DO 550 j=1,5
40047 dps(j)=0d0
40048 550 CONTINUE
40049 DO 580 i=max(1,ip),n
40050 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 580
40051 kc=pycomp(k(i,2))
40052 IF(kc.EQ.0) GOTO 580
40053 kq=kchg(kc,2)*isign(1,k(i,2))
40054 IF(kq.EQ.0) GOTO 580
40055 np=np+1
40056 IF(kq.NE.2) THEN
40057 kfn=kfn+1
40058 kqs=kqs+kq
40059 mstj(93)=1
40060 dps(5)=dps(5)+pymass(k(i,2))
40061 ENDIF
40062 DO 560 j=1,4
40063 dps(j)=dps(j)+p(i,j)
40064 560 CONTINUE
40065 IF(k(i,1).EQ.1) THEN
40066 IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) call
40067 & pyerrm(2,'(PYPREP:) unphysical flavour combination')
40068 IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
40069 & (0.9d0*parj(32)+dps(5))**2) THEN
40070 CALL pyerrm(3,'(PYPREP:) too small mass in jet system')
40071 END IF
40072 np=0
40073 kfn=0
40074 kqs=0
40075 DO 570 j=1,5
40076 dps(j)=0d0
40077 570 CONTINUE
40078 ENDIF
40079 580 CONTINUE
40080
40081 RETURN
40082 END
40083
40084C*********************************************************************
40085
40086C...PYSTRF
40087C...Handles the fragmentation of an arbitrary colour singlet
40088C...jet system according to the Lund string fragmentation model.
40089
40090 SUBROUTINE pystrf(IP)
40091
40092C...Double precision and integer declarations.
40093 IMPLICIT DOUBLE PRECISION(a-h, o-z)
40094 IMPLICIT INTEGER(I-N)
40095 INTEGER PYK,PYCHGE,PYCOMP
40096C...Commonblocks.
40097 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
40098 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40099 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
40100 SAVE /pyjets/,/pydat1/,/pydat2/
40101C...Local arrays. All MOPS variables ends with MO
40102 dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
40103 &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
40104 &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8),
40105 &inmo(9),pm2qmo(2),xtmo(2)
40106
40107C...Function: four-product of two vectors.
40108 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)
40109 dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
40110 &dp(i,3)*dp(j,3)
40111
40112C...Reset counters. Identify parton system.
40113 mstj(91)=0
40114 nsav=n
40115 mstu90=mstu(90)
40116 np=0
40117 kqsum=0
40118 DO 100 j=1,5
40119 dps(j)=0d0
40120 100 CONTINUE
40121 mju(1)=0
40122 mju(2)=0
40123 i=ip-1
40124 110 i=i+1
40125 IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
40126 CALL pyerrm(12,'(PYSTRF:) failed to reconstruct jet system')
40127 IF(mstu(21).GE.1) RETURN
40128 ENDIF
40129 IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 110
40130 kc=pycomp(k(i,2))
40131 IF(kc.EQ.0) GOTO 110
40132 kq=kchg(kc,2)*isign(1,k(i,2))
40133 IF(kq.EQ.0) GOTO 110
40134 IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
40135 CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
40136 IF(mstu(21).GE.1) RETURN
40137 ENDIF
40138
40139C...Take copy of partons to be considered. Check flavour sum.
40140 np=np+1
40141 DO 120 j=1,5
40142 k(n+np,j)=k(i,j)
40143 p(n+np,j)=p(i,j)
40144 IF(j.NE.4) dps(j)=dps(j)+p(i,j)
40145 120 CONTINUE
40146 dps(4)=dps(4)+sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
40147 k(n+np,3)=i
40148 IF(kq.NE.2) kqsum=kqsum+kq
40149 IF(k(i,1).EQ.41) THEN
40150 kqsum=kqsum+2*kq
40151 IF(kqsum.EQ.kq) mju(1)=n+np
40152 IF(kqsum.NE.kq) mju(2)=n+np
40153 ENDIF
40154 IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) GOTO 110
40155 IF(kqsum.NE.0) THEN
40156 CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
40157 IF(mstu(21).GE.1) RETURN
40158 ENDIF
40159
40160C...Boost copied system to CM frame (for better numerical precision).
40161 IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
40162 mbst=0
40163 mstu(33)=1
40164 CALL pyrobo(n+1,n+np,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
40165 & -dps(3)/dps(4))
40166 ELSE
40167 mbst=1
40168 hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
40169 DO 130 i=n+1,n+np
40170 hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
40171 IF(p(i,3).GT.0d0) THEN
40172 hhpez=max(1d-10,(p(i,4)+p(i,3))/hhbz)
40173 p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
40174 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
40175 ELSE
40176 hhpez=max(1d-10,(p(i,4)-p(i,3))*hhbz)
40177 p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
40178 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
40179 ENDIF
40180 130 CONTINUE
40181 ENDIF
40182
40183C...Search for very nearby partons that may be recombined.
40184 ntryr=0
40185 paru12=paru(12)
40186 paru13=paru(13)
40187 mju(3)=mju(1)
40188 mju(4)=mju(2)
40189 nr=np
40190 140 IF(nr.GE.3) THEN
40191 pdrmin=2d0*paru12
40192 DO 150 i=n+1,n+nr
40193 IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) GOTO 150
40194 i1=i+1
40195 IF(i.EQ.n+nr) i1=n+1
40196 IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) GOTO 150
40197 IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
40198 & GOTO 150
40199 IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21)
40200 & GOTO 150
40201 pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
40202 & p(i1,2)**2+p(i1,3)**2))
40203 pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
40204 pdr=4d0*(pap-pvp)**2/max(1d-6,paru13**2*pap+2d0*(pap-pvp))
40205 IF(pdr.LT.pdrmin) THEN
40206 ir=i
40207 pdrmin=pdr
40208 ENDIF
40209 150 CONTINUE
40210
40211C...Recombine very nearby partons to avoid machine precision problems.
40212 IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
40213 DO 160 j=1,4
40214 p(n+1,j)=p(n+1,j)+p(n+nr,j)
40215 160 CONTINUE
40216 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
40217 & p(n+1,3)**2))
40218 nr=nr-1
40219 GOTO 140
40220 ELSEIF(pdrmin.LT.paru12) THEN
40221 DO 170 j=1,4
40222 p(ir,j)=p(ir,j)+p(ir+1,j)
40223 170 CONTINUE
40224 p(ir,5)=sqrt(max(0d0,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
40225 & p(ir,3)**2))
40226 DO 190 i=ir+1,n+nr-1
40227 k(i,2)=k(i+1,2)
40228 DO 180 j=1,5
40229 p(i,j)=p(i+1,j)
40230 180 CONTINUE
40231 190 CONTINUE
40232 IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
40233 nr=nr-1
40234 IF(mju(1).GT.ir) mju(1)=mju(1)-1
40235 IF(mju(2).GT.ir) mju(2)=mju(2)-1
40236 GOTO 140
40237 ENDIF
40238 ENDIF
40239 ntryr=ntryr+1
40240
40241C...Reset particle counter. Skip ahead if no junctions are present;
40242C...this is usually the case!
40243 nrs=max(5*nr+11,np)
40244 ntry=0
40245 200 ntry=ntry+1
40246 IF(ntry.GT.100.AND.ntryr.LE.4) THEN
40247 paru12=4d0*paru12
40248 paru13=2d0*paru13
40249 GOTO 140
40250 ELSEIF(ntry.GT.100) THEN
40251 CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
40252 IF(mstu(21).GE.1) RETURN
40253 ENDIF
40254 i=n+nrs
40255 mstu(90)=mstu90
40256 IF(mju(1).EQ.0.AND.mju(2).EQ.0) GOTO 580
40257 IF(mstj(12).GE.4) CALL pyerrm(29,'(PYSTRF:) sorry,'//
40258 & ' junction strings not handled by MSTJ(12)>3 options')
40259 DO 570 jt=1,2
40260 njs(jt)=0
40261 IF(mju(jt).EQ.0) GOTO 570
40262 js=3-2*jt
40263
40264C...Find and sum up momentum on three sides of junction. Check flavours.
40265 DO 220 iu=1,3
40266 iju(iu)=0
40267 DO 210 j=1,5
40268 pju(iu,j)=0d0
40269 210 CONTINUE
40270 220 CONTINUE
40271 iu=0
40272 DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
40273 IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
40274 iu=iu+1
40275 iju(iu)=i1
40276 ENDIF
40277 DO 230 j=1,4
40278 pju(iu,j)=pju(iu,j)+p(i1,j)
40279 230 CONTINUE
40280 240 CONTINUE
40281 DO 250 iu=1,3
40282 pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
40283 250 CONTINUE
40284 IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.
40285 & k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
40286 CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
40287 IF(mstu(21).GE.1) RETURN
40288 ENDIF
40289
40290C...Calculate (approximate) boost to rest frame of junction.
40291 t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
40292 & (pju(1,5)*pju(2,5))
40293 t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
40294 & (pju(1,5)*pju(3,5))
40295 t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
40296 & (pju(2,5)*pju(3,5))
40297 t11=sqrt((2d0/3d0)*(1d0-t12)*(1d0-t13)/(1d0-t23))
40298 t22=sqrt((2d0/3d0)*(1d0-t12)*(1d0-t23)/(1d0-t13))
40299 tsq=sqrt((2d0*t11*t22+t12-1d0)*(1d0+t12))
40300 t1f=(tsq-t22*(1d0+t12))/(1d0-t12**2)
40301 t2f=(tsq-t11*(1d0+t12))/(1d0-t12**2)
40302 DO 260 j=1,3
40303 tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
40304 260 CONTINUE
40305 tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
40306 DO 270 iu=1,3
40307 pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
40308 & tju(3)*pju(iu,3)
40309 270 CONTINUE
40310
40311C...Put junction at rest if motion could give inconsistencies.
40312 IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
40313 DO 280 j=1,3
40314 tju(j)=0d0
40315 280 CONTINUE
40316 tju(4)=1d0
40317 pju(1,5)=pju(1,4)
40318 pju(2,5)=pju(2,4)
40319 pju(3,5)=pju(3,4)
40320 ENDIF
40321
40322C...Start preparing for fragmentation of two strings from junction.
40323 ista=i
40324 DO 550 iu=1,2
40325 ns=iju(iu+1)-iju(iu)
40326
40327C...Junction strings: find longitudinal string directions.
40328 DO 310 is=1,ns
40329 is1=iju(iu)+is-1
40330 is2=iju(iu)+is
40331 DO 290 j=1,5
40332 dp(1,j)=0.5d0*p(is1,j)
40333 IF(is.EQ.1) dp(1,j)=p(is1,j)
40334 dp(2,j)=0.5d0*p(is2,j)
40335 IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
40336 290 CONTINUE
40337 IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+
40338 & pju(iu,3)**2)
40339 IF(is.EQ.ns) dp(2,5)=0d0
40340 dp(3,5)=dfour(1,1)
40341 dp(4,5)=dfour(2,2)
40342 dhkc=dfour(1,2)
40343 IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
40344 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
40345 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
40346 dp(3,5)=0d0
40347 dp(4,5)=0d0
40348 dhkc=dfour(1,2)
40349 ENDIF
40350 dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
40351 dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
40352 dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
40353 in1=n+nr+4*is-3
40354 p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
40355 DO 300 j=1,4
40356 p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
40357 p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
40358 300 CONTINUE
40359 310 CONTINUE
40360
40361C...Junction strings: initialize flavour, momentum and starting pos.
40362 isav=i
40363 mstu91=mstu(90)
40364 320 ntry=ntry+1
40365 IF(ntry.GT.100.AND.ntryr.LE.4) THEN
40366 paru12=4d0*paru12
40367 paru13=2d0*paru13
40368 GOTO 140
40369 ELSEIF(ntry.GT.100) THEN
40370 CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
40371 IF(mstu(21).GE.1) RETURN
40372 ENDIF
40373 i=isav
40374 mstu(90)=mstu91
40375 irankj=0
40376 ie(1)=k(n+1+(jt/2)*(np-1),3)
40377 in(4)=n+nr+1
40378 in(5)=in(4)+1
40379 in(6)=n+nr+4*ns+1
40380 DO 340 jq=1,2
40381 DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
40382 p(in1,1)=2-jq
40383 p(in1,2)=jq-1
40384 p(in1,3)=1d0
40385 330 CONTINUE
40386 340 CONTINUE
40387 kfl(1)=k(iju(iu),2)
40388 px(1)=0d0
40389 py(1)=0d0
40390 gam(1)=0d0
40391 DO 350 j=1,5
40392 pju(iu+3,j)=0d0
40393 350 CONTINUE
40394
40395C...Junction strings: find initial transverse directions.
40396 DO 360 j=1,4
40397 dp(1,j)=p(in(4),j)
40398 dp(2,j)=p(in(4)+1,j)
40399 dp(3,j)=0d0
40400 dp(4,j)=0d0
40401 360 CONTINUE
40402 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
40403 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
40404 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
40405 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
40406 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
40407 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
40408 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
40409 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
40410 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
40411 dhc12=dfour(1,2)
40412 dhcx1=dfour(3,1)/dhc12
40413 dhcx2=dfour(3,2)/dhc12
40414 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
40415 dhcy1=dfour(4,1)/dhc12
40416 dhcy2=dfour(4,2)/dhc12
40417 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
40418 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
40419 DO 370 j=1,4
40420 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
40421 p(in(6),j)=dp(3,j)
40422 p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
40423 & dhcyx*dp(3,j))
40424 370 CONTINUE
40425
40426C...Junction strings: produce new particle, origin.
40427 380 i=i+1
40428 IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
40429 CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
40430 IF(mstu(21).GE.1) RETURN
40431 ENDIF
40432 irankj=irankj+1
40433 k(i,1)=1
40434 k(i,3)=ie(1)
40435 k(i,4)=0
40436 k(i,5)=0
40437
40438C...Junction strings: generate flavour, hadron, pT, z and Gamma.
40439 390 CALL pykfdi(kfl(1),0,kfl(3),k(i,2))
40440 IF(k(i,2).EQ.0) GOTO 320
40441 IF(irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
40442 & iabs(kfl(3)).GT.10) THEN
40443 IF(pyr(0).GT.parj(19)) GOTO 390
40444 ENDIF
40445 p(i,5)=pymass(k(i,2))
40446 CALL pyptdi(kfl(1),px(3),py(3))
40447 pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
40448 CALL pyzdis(kfl(1),kfl(3),pr(1),z)
40449 IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
40450 & mstu(90).LT.8) THEN
40451 mstu(90)=mstu(90)+1
40452 mstu(90+mstu(90))=i
40453 paru(90+mstu(90))=z
40454 ENDIF
40455 gam(3)=(1d0-z)*(gam(1)+pr(1)/z)
40456 DO 400 j=1,3
40457 in(j)=in(3+j)
40458 400 CONTINUE
40459
40460C...Junction strings: stepping within or from 'low' string region easy.
40461 IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
40462 & p(in(1),5)**2.GE.pr(1)) THEN
40463 p(in(1)+2,4)=z*p(in(1)+2,3)
40464 p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
40465 DO 410 j=1,4
40466 p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
40467 410 CONTINUE
40468 GOTO 500
40469 ELSEIF(in(1)+1.EQ.in(2)) THEN
40470 p(in(2)+2,4)=p(in(2)+2,3)
40471 p(in(2)+2,1)=1d0
40472 in(2)=in(2)+4
40473 IF(in(2).GT.n+nr+4*ns) GOTO 320
40474 IF(four(in(1),in(2)).LE.1d-2) THEN
40475 p(in(1)+2,4)=p(in(1)+2,3)
40476 p(in(1)+2,1)=0d0
40477 in(1)=in(1)+4
40478 ENDIF
40479 ENDIF
40480
40481C...Junction strings: find new transverse directions.
40482 420 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
40483 & in(1).GT.in(2)) GOTO 320
40484 IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
40485 DO 430 j=1,4
40486 dp(1,j)=p(in(1),j)
40487 dp(2,j)=p(in(2),j)
40488 dp(3,j)=0d0
40489 dp(4,j)=0d0
40490 430 CONTINUE
40491 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
40492 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
40493 dhc12=dfour(1,2)
40494 IF(dhc12.LE.1d-2) THEN
40495 p(in(1)+2,4)=p(in(1)+2,3)
40496 p(in(1)+2,1)=0d0
40497 in(1)=in(1)+4
40498 GOTO 420
40499 ENDIF
40500 in(3)=n+nr+4*ns+5
40501 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
40502 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
40503 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
40504 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
40505 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
40506 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
40507 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
40508 dhcx1=dfour(3,1)/dhc12
40509 dhcx2=dfour(3,2)/dhc12
40510 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
40511 dhcy1=dfour(4,1)/dhc12
40512 dhcy2=dfour(4,2)/dhc12
40513 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
40514 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
40515 DO 440 j=1,4
40516 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
40517 p(in(3),j)=dp(3,j)
40518 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
40519 & dhcyx*dp(3,j))
40520 440 CONTINUE
40521C...Express pT with respect to new axes, if sensible.
40522 pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
40523 pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
40524 IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
40525 px(3)=pxp
40526 py(3)=pyp
40527 ENDIF
40528 ENDIF
40529
40530C...Junction strings: sum up known four-momentum, coefficients for m2.
40531 DO 470 j=1,4
40532 dhg(j)=0d0
40533 p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
40534 & py(3)*p(in(3)+1,j)
40535 DO 450 in1=in(4),in(1)-4,4
40536 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
40537 450 CONTINUE
40538 DO 460 in2=in(5),in(2)-4,4
40539 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
40540 460 CONTINUE
40541 470 CONTINUE
40542 dhm(1)=four(i,i)
40543 dhm(2)=2d0*four(i,in(1))
40544 dhm(3)=2d0*four(i,in(2))
40545 dhm(4)=2d0*four(in(1),in(2))
40546
40547C...Junction strings: find coefficients for Gamma expression.
40548 DO 490 in2=in(1)+1,in(2),4
40549 DO 480 in1=in(1),in2-1,4
40550 dhc=2d0*four(in1,in2)
40551 dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
40552 IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
40553 IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
40554 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
40555 480 CONTINUE
40556 490 CONTINUE
40557
40558C...Junction strings: solve (m2, Gamma) equation system for energies.
40559 dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
40560 IF(abs(dhs1).LT.1d-4) GOTO 320
40561 dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
40562 & (p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
40563 dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
40564 p(in(2)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
40565 & abs(dhs1)-dhs2/dhs1)
40566 IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0d0) GOTO 320
40567 p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
40568 & (dhm(2)+dhm(4)*p(in(2)+2,4))
40569
40570C...Junction strings: step to new region if necessary.
40571 IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
40572 p(in(2)+2,4)=p(in(2)+2,3)
40573 p(in(2)+2,1)=1d0
40574 in(2)=in(2)+4
40575 IF(in(2).GT.n+nr+4*ns) GOTO 320
40576 IF(four(in(1),in(2)).LE.1d-2) THEN
40577 p(in(1)+2,4)=p(in(1)+2,3)
40578 p(in(1)+2,1)=0d0
40579 in(1)=in(1)+4
40580 ENDIF
40581 GOTO 420
40582 ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
40583 p(in(1)+2,4)=p(in(1)+2,3)
40584 p(in(1)+2,1)=0d0
40585 in(1)=in(1)+js
40586 GOTO 890
40587 ENDIF
40588
40589C...Junction strings: particle four-momentum, remainder, loop back.
40590 500 DO 510 j=1,4
40591 p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+
40592 & p(in(2)+2,4)*p(in(2),j)
40593 pju(iu+3,j)=pju(iu+3,j)+p(i,j)
40594 510 CONTINUE
40595 IF(p(i,4).LT.p(i,5)) GOTO 320
40596 pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
40597 & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
40598 IF(pju(iu+3,5).LT.pju(iu,5)) THEN
40599 kfl(1)=-kfl(3)
40600 px(1)=-px(3)
40601 py(1)=-py(3)
40602 gam(1)=gam(3)
40603 IF(in(3).NE.in(6)) THEN
40604 DO 520 j=1,4
40605 p(in(6),j)=p(in(3),j)
40606 p(in(6)+1,j)=p(in(3)+1,j)
40607 520 CONTINUE
40608 ENDIF
40609 DO 530 jq=1,2
40610 in(3+jq)=in(jq)
40611 p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
40612 p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
40613 530 CONTINUE
40614 GOTO 380
40615 ENDIF
40616
40617C...Junction strings: save quantities left after each string.
40618 IF(iabs(kfl(1)).GT.10) GOTO 320
40619 i=i-1
40620 kfjh(iu)=kfl(1)
40621 DO 540 j=1,4
40622 pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
40623 540 CONTINUE
40624 550 CONTINUE
40625
40626C...Junction strings: put together to new effective string endpoint.
40627 njs(jt)=i-ista
40628 kfjs(jt)=k(k(mju(jt+2),3),2)
40629 kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
40630 IF(kfjh(1).EQ.kfjh(2)) kfls=3
40631 IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),
40632 & iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+
40633 & kfls,kfjh(1))
40634 DO 560 j=1,4
40635 pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
40636 pjs(jt+2,j)=pju(4,j)+pju(5,j)
40637 560 CONTINUE
40638 pjs(jt,5)=sqrt(max(0d0,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
40639 & pjs(jt,3)**2))
40640 570 CONTINUE
40641
40642C...Open versus closed strings. Choose breakup region for latter.
40643 580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
40644 ns=mju(2)-mju(1)
40645 nb=mju(1)-n
40646 ELSEIF(mju(1).NE.0) THEN
40647 ns=n+nr-mju(1)
40648 nb=mju(1)-n
40649 ELSEIF(mju(2).NE.0) THEN
40650 ns=mju(2)-n
40651 nb=1
40652 ELSEIF(iabs(k(n+1,2)).NE.21) THEN
40653 ns=nr-1
40654 nb=1
40655 ELSE
40656 ns=nr+1
40657 w2sum=0d0
40658 DO 590 is=1,nr
40659 p(n+nr+is,1)=0.5d0*four(n+is,n+is+1-nr*(is/nr))
40660 w2sum=w2sum+p(n+nr+is,1)
40661 590 CONTINUE
40662 w2ran=pyr(0)*w2sum
40663 nb=0
40664 600 nb=nb+1
40665 w2sum=w2sum-p(n+nr+nb,1)
40666 IF(w2sum.GT.w2ran.AND.nb.LT.nr) GOTO 600
40667 ENDIF
40668
40669C...Find longitudinal string directions (i.e. lightlike four-vectors).
40670 DO 630 is=1,ns
40671 is1=n+is+nb-1-nr*((is+nb-2)/nr)
40672 is2=n+is+nb-nr*((is+nb-1)/nr)
40673 DO 610 j=1,5
40674 dp(1,j)=p(is1,j)
40675 IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5d0*dp(1,j)
40676 IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
40677 dp(2,j)=p(is2,j)
40678 IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5d0*dp(2,j)
40679 IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
40680 610 CONTINUE
40681 dp(3,5)=dfour(1,1)
40682 dp(4,5)=dfour(2,2)
40683 dhkc=dfour(1,2)
40684 IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
40685 dp(3,5)=dp(1,5)**2
40686 dp(4,5)=dp(2,5)**2
40687 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
40688 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
40689 dhkc=dfour(1,2)
40690 ENDIF
40691 dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
40692 dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
40693 dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
40694 in1=n+nr+4*is-3
40695 p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
40696 DO 620 j=1,4
40697 p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
40698 p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
40699 620 CONTINUE
40700 630 CONTINUE
40701
40702C...Begin initialization: sum up energy, set starting position.
40703 isav=i
40704 mstu91=mstu(90)
40705 640 ntry=ntry+1
40706 IF(ntry.GT.100.AND.ntryr.LE.4) THEN
40707 paru12=4d0*paru12
40708 paru13=2d0*paru13
40709 GOTO 140
40710 ELSEIF(ntry.GT.100) THEN
40711 CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
40712 IF(mstu(21).GE.1) RETURN
40713 ENDIF
40714 i=isav
40715 mstu(90)=mstu91
40716 DO 660 j=1,4
40717 p(n+nrs,j)=0d0
40718 DO 650 is=1,nr
40719 p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
40720 650 CONTINUE
40721 660 CONTINUE
40722 DO 680 jt=1,2
40723 irank(jt)=0
40724 IF(mju(jt).NE.0) irank(jt)=njs(jt)
40725 IF(ns.GT.nr) irank(jt)=1
40726 ie(jt)=k(n+1+(jt/2)*(np-1),3)
40727 in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
40728 in(3*jt+2)=in(3*jt+1)+1
40729 in(3*jt+3)=n+nr+4*ns+2*jt-1
40730 DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
40731 p(in1,1)=2-jt
40732 p(in1,2)=jt-1
40733 p(in1,3)=1d0
40734 670 CONTINUE
40735 680 CONTINUE
40736C.. MOPS variables and switches
40737 nrvmo=0
40738 xbmo=1d0
40739 mstu(121)=0
40740 mstu(122)=0
40741
40742C...Initialize flavour and pT variables for open string.
40743 IF(ns.LT.nr) THEN
40744 px(1)=0d0
40745 py(1)=0d0
40746 IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL pyptdi(0,px(1),py(1))
40747 px(2)=-px(1)
40748 py(2)=-py(1)
40749 DO 690 jt=1,2
40750 kfl(jt)=k(ie(jt),2)
40751 IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
40752 mstj(93)=1
40753 pmq(jt)=pymass(kfl(jt))
40754 gam(jt)=0d0
40755 690 CONTINUE
40756
40757C...Closed string: random initial breakup flavour, pT and vertex.
40758 ELSE
40759 kfl(3)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
40760 ibmo=0
40761 700 CALL pykfdi(kfl(3),0,kfl(1),kdump)
40762C.. Closed string: first vertex diq attempt => enforced second
40763C.. vertex diq
40764 IF(iabs(kfl(1)).GT.10)THEN
40765 ibmo=1
40766 mstu(121)=0
40767 GOTO 700
40768 ENDIF
40769 IF(ibmo.EQ.1) mstu(121)=-1
40770 kfl(2)=-kfl(1)
40771 CALL pyptdi(kfl(1),px(1),py(1))
40772 px(2)=-px(1)
40773 py(2)=-py(1)
40774 pr3=min(25d0,0.1d0*p(n+nr+1,5)**2)
40775 710 CALL pyzdis(kfl(1),kfl(2),pr3,z)
40776 zr=pr3/(z*p(n+nr+1,5)**2)
40777 IF(zr.GE.1d0) GOTO 710
40778 DO 720 jt=1,2
40779 mstj(93)=1
40780 pmq(jt)=pymass(kfl(jt))
40781 gam(jt)=pr3*(1d0-z)/z
40782 in1=n+nr+3+4*(jt/2)*(ns-1)
40783 p(in1,jt)=1d0-z
40784 p(in1,3-jt)=jt-1
40785 p(in1,3)=(2-jt)*(1d0-z)+(jt-1)*z
40786 p(in1+1,jt)=zr
40787 p(in1+1,3-jt)=2-jt
40788 p(in1+1,3)=(2-jt)*(1d0-zr)+(jt-1)*zr
40789 720 CONTINUE
40790 ENDIF
40791C.. MOPS variables
40792 DO 730 jt=1,2
40793 xtmo(jt)=1d0
40794 pm2qmo(jt)=pmq(jt)**2
40795 IF(iabs(kfl(jt)).GT.10) pm2qmo(jt)=0d0
40796 730 CONTINUE
40797
40798C...Find initial transverse directions (i.e. spacelike four-vectors).
40799 DO 770 jt=1,2
40800 IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
40801 in1=in(3*jt+1)
40802 in3=in(3*jt+3)
40803 DO 740 j=1,4
40804 dp(1,j)=p(in1,j)
40805 dp(2,j)=p(in1+1,j)
40806 dp(3,j)=0d0
40807 dp(4,j)=0d0
40808 740 CONTINUE
40809 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
40810 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
40811 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
40812 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
40813 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
40814 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
40815 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
40816 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
40817 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
40818 dhc12=dfour(1,2)
40819 dhcx1=dfour(3,1)/dhc12
40820 dhcx2=dfour(3,2)/dhc12
40821 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
40822 dhcy1=dfour(4,1)/dhc12
40823 dhcy2=dfour(4,2)/dhc12
40824 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
40825 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
40826 DO 750 j=1,4
40827 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
40828 p(in3,j)=dp(3,j)
40829 p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
40830 & dhcyx*dp(3,j))
40831 750 CONTINUE
40832 ELSE
40833 DO 760 j=1,4
40834 p(in3+2,j)=p(in3,j)
40835 p(in3+3,j)=p(in3+1,j)
40836 760 CONTINUE
40837 ENDIF
40838 770 CONTINUE
40839
40840C...Remove energy used up in junction string fragmentation.
40841 IF(mju(1)+mju(2).GT.0) THEN
40842 DO 790 jt=1,2
40843 IF(njs(jt).EQ.0) GOTO 790
40844 DO 780 j=1,4
40845 p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
40846 780 CONTINUE
40847 790 CONTINUE
40848 ENDIF
40849
40850C...Produce new particle: side, origin.
40851 800 i=i+1
40852 IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
40853 CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
40854 IF(mstu(21).GE.1) RETURN
40855 ENDIF
40856C.. New side priority for popcorn systems
40857 IF(mstu(121).LE.0)THEN
40858 jt=1.5d0+pyr(0)
40859 IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
40860 IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
40861 ENDIF
40862 jr=3-jt
40863 js=3-2*jt
40864 irank(jt)=irank(jt)+1
40865 k(i,1)=1
40866 k(i,3)=ie(jt)
40867 k(i,4)=0
40868 k(i,5)=0
40869
40870C...Generate flavour, hadron and pT.
40871 810 CONTINUE
40872 CALL pykfdi(kfl(jt),0,kfl(3),k(i,2))
40873 IF(k(i,2).EQ.0) GOTO 640
40874 mu90mo=mstu(90)
40875 IF(mstu(121).EQ.-1) GOTO 840
40876 IF(irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
40877 &iabs(kfl(3)).GT.10) THEN
40878 IF(pyr(0).GT.parj(19)) GOTO 810
40879 ENDIF
40880 p(i,5)=pymass(k(i,2))
40881 CALL pyptdi(kfl(jt),px(3),py(3))
40882 pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
40883
40884C...Final hadrons for small invariant mass.
40885 mstj(93)=1
40886 pmq(3)=pymass(kfl(3))
40887 parjst=parj(33)
40888 IF(mstj(11).EQ.2) parjst=parj(34)
40889 wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
40890 IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
40891 &wmin-0.5d0*parj(36)*pmq(3)
40892 wrem2=four(n+nrs,n+nrs)
40893 IF(wrem2.LT.0.10d0) GOTO 640
40894 IF(wrem2.LT.max(wmin*(1d0+(2d0*pyr(0)-1d0)*parj(37)),
40895 &parj(32)+pmq(1)+pmq(2))**2) GOTO 1010
40896
40897C...Choose z, which gives Gamma. Shift z for heavy flavours.
40898 CALL pyzdis(kfl(jt),kfl(3),pr(jt),z)
40899 IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
40900 &mstu(90).LT.8) THEN
40901 mstu(90)=mstu(90)+1
40902 mstu(90+mstu(90))=i
40903 paru(90+mstu(90))=z
40904 ENDIF
40905 kfl1a=iabs(kfl(1))
40906 kfl2a=iabs(kfl(2))
40907 IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
40908 &mod(kfl2a/1000,10)).GE.4) THEN
40909 pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
40910 pw12=sqrt(max(0d0,(wrem2-pr(1)-pr(2))**2-4d0*pr(1)*pr(2)))
40911 z=(wrem2+pr(jt)-pr(jr)+pw12*(2d0*z-1d0))/(2d0*wrem2)
40912 pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
40913 IF((1d0-z)*(wrem2-pr(jt)/z).LT.pr(jr)) GOTO 1010
40914 ENDIF
40915 gam(3)=(1d0-z)*(gam(jt)+pr(jt)/z)
40916
40917C.. MOPS baryon model modification
40918 xtmo3=(1d0-z)*xtmo(jt)
40919 IF(iabs(kfl(3)).LE.10) nrvmo=0
40920 IF(iabs(kfl(3)).GT.10.AND.mstj(12).GE.4) THEN
40921 gtstmo=1d0
40922 ptstmo=1d0
40923 rtstmo=pyr(0)
40924 IF(iabs(kfl(jt)).LE.10)THEN
40925 xbmo=min(xtmo3,1d0-(2d-10))
40926 gbmo=gam(3)
40927 pmmo=0d0
40928 pgmo=gbmo+log(1d0-xbmo)*pm2qmo(jt)
40929 gtstmo=1d0-parf(192)**pgmo
40930 ELSE
40931 IF(irank(jt).EQ.1) THEN
40932 gbmo=gam(jt)
40933 pmmo=0d0
40934 xbmo=1d0
40935 ENDIF
40936 IF(xbmo.LT.1d0-(1d-10))THEN
40937 pgnmo=gbmo*xtmo3/xbmo+pm2qmo(jt)*log(1d0-xtmo3)
40938 gtstmo=(1d0-parf(192)**pgnmo)/(1d0-parf(192)**pgmo)
40939 pgmo=pgnmo
40940 ENDIF
40941 IF(mstj(12).GE.5)THEN
40942 pmnmo=sqrt((xbmo-xtmo3)*(gam(3)/xtmo3-gbmo/xbmo))
40943 pmmo=pmmo+pmas(pycomp(k(i,2)),1)-pmas(pycomp(k(i,2)),3)
40944 ptstmo=exp((pmmo-pmnmo)*parf(193))
40945 pmmo=pmnmo
40946 ENDIF
40947 ENDIF
40948
40949C.. MOPS Accepting popcorn system hadron.
40950 IF(ptstmo*gtstmo.GT.rtstmo) THEN
40951 IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) THEN
40952 nrvmo=i-n-nr
40953 IF(i+nrvmo.GT.mstu(4)-mstu(32)-5) THEN
40954 CALL pyerrm(11,
40955 & '(PYSTRF:) no more memory left in PYJETS')
40956 IF(mstu(21).GE.1) RETURN
40957 ENDIF
40958 imo=i
40959 kflmo=kfl(jt)
40960 pmqmo=pmq(jt)
40961 pxmo=px(jt)
40962 pymo=py(jt)
40963 gammo=gam(jt)
40964 irmo=irank(jt)
40965 xmo=xtmo(jt)
40966 DO 830 j=1,9
40967 IF(j.LE.5) THEN
40968 DO 820 line=1,i-n-nr
40969 p(mstu(4)-mstu(32)-line,j)=p(n+nr+line,j)
40970 k(mstu(4)-mstu(32)-line,j)=k(n+nr+line,j)
40971 820 CONTINUE
40972 ENDIF
40973 inmo(j)=in(j)
40974 830 CONTINUE
40975 ENDIF
40976 ELSE
40977C..Reject popcorn system, flag=-1 if enforcing new one
40978 mstu(121)=-1
40979 IF(ptstmo.GT.rtstmo) mstu(121)=-2
40980 ENDIF
40981 ENDIF
40982
40983
40984C..Lift restoring string outside MOPS block
40985 840 IF(mstu(121).LT.0) THEN
40986 IF(mstu(121).EQ.-2) mstu(121)=0
40987 mstu(90)=mu90mo
40988 nrvmo=0
40989 IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) GOTO 810
40990 i=imo
40991 kfl(jt)=kflmo
40992 pmq(jt)=pmqmo
40993 px(jt)=pxmo
40994 py(jt)=pymo
40995 gam(jt)=gammo
40996 irank(jt)=irmo
40997 xtmo(jt)=xmo
40998 DO 860 j=1,9
40999 IF(j.LE.5) THEN
41000 DO 850 line=1,i-n-nr
41001 p(n+nr+line,j)=p(mstu(4)-mstu(32)-line,j)
41002 k(n+nr+line,j)=k(mstu(4)-mstu(32)-line,j)
41003 850 CONTINUE
41004 ENDIF
41005 in(j)=inmo(j)
41006 860 CONTINUE
41007 GOTO 810
41008 ENDIF
41009 xtmo(jt)=xtmo3
41010C.. MOPS end of modification
41011
41012 DO 870 j=1,3
41013 in(j)=in(3*jt+j)
41014 870 CONTINUE
41015
41016C...Stepping within or from 'low' string region easy.
41017 IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
41018 &p(in(1),5)**2.GE.pr(jt)) THEN
41019 p(in(jt)+2,4)=z*p(in(jt)+2,3)
41020 p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
41021 DO 880 j=1,4
41022 p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
41023 880 CONTINUE
41024 GOTO 970
41025 ELSEIF(in(1)+1.EQ.in(2)) THEN
41026 p(in(jr)+2,4)=p(in(jr)+2,3)
41027 p(in(jr)+2,jt)=1d0
41028 in(jr)=in(jr)+4*js
41029 IF(js*in(jr).GT.js*in(4*jr)) GOTO 640
41030 IF(four(in(1),in(2)).LE.1d-2) THEN
41031 p(in(jt)+2,4)=p(in(jt)+2,3)
41032 p(in(jt)+2,jt)=0d0
41033 in(jt)=in(jt)+4*js
41034 ENDIF
41035 ENDIF
41036
41037C...Find new transverse directions (i.e. spacelike string vectors).
41038 890 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
41039 &in(1).GT.in(2)) GOTO 640
41040 IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
41041 DO 900 j=1,4
41042 dp(1,j)=p(in(1),j)
41043 dp(2,j)=p(in(2),j)
41044 dp(3,j)=0d0
41045 dp(4,j)=0d0
41046 900 CONTINUE
41047 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
41048 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
41049 dhc12=dfour(1,2)
41050 IF(dhc12.LE.1d-2) THEN
41051 p(in(jt)+2,4)=p(in(jt)+2,3)
41052 p(in(jt)+2,jt)=0d0
41053 in(jt)=in(jt)+4*js
41054 GOTO 890
41055 ENDIF
41056 in(3)=n+nr+4*ns+5
41057 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
41058 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
41059 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
41060 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
41061 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
41062 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
41063 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
41064 dhcx1=dfour(3,1)/dhc12
41065 dhcx2=dfour(3,2)/dhc12
41066 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
41067 dhcy1=dfour(4,1)/dhc12
41068 dhcy2=dfour(4,2)/dhc12
41069 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
41070 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
41071 DO 910 j=1,4
41072 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
41073 p(in(3),j)=dp(3,j)
41074 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
41075 & dhcyx*dp(3,j))
41076 910 CONTINUE
41077C...Express pT with respect to new axes, if sensible.
41078 pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
41079 & four(in(3*jt+3)+1,in(3)))
41080 pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
41081 & four(in(3*jt+3)+1,in(3)+1))
41082 IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
41083 px(3)=pxp
41084 py(3)=pyp
41085 ENDIF
41086 ENDIF
41087
41088C...Sum up known four-momentum. Gives coefficients for m2 expression.
41089 DO 940 j=1,4
41090 dhg(j)=0d0
41091 p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
41092 & px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
41093 DO 920 in1=in(3*jt+1),in(1)-4*js,4*js
41094 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
41095 920 CONTINUE
41096 DO 930 in2=in(3*jt+2),in(2)-4*js,4*js
41097 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
41098 930 CONTINUE
41099 940 CONTINUE
41100 dhm(1)=four(i,i)
41101 dhm(2)=2d0*four(i,in(1))
41102 dhm(3)=2d0*four(i,in(2))
41103 dhm(4)=2d0*four(in(1),in(2))
41104
41105C...Find coefficients for Gamma expression.
41106 DO 960 in2=in(1)+1,in(2),4
41107 DO 950 in1=in(1),in2-1,4
41108 dhc=2d0*four(in1,in2)
41109 dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
41110 IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
41111 IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
41112 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
41113 950 CONTINUE
41114 960 CONTINUE
41115
41116C...Solve (m2, Gamma) equation system for energies taken.
41117 dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
41118 IF(abs(dhs1).LT.1d-4) GOTO 640
41119 dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
41120 &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
41121 dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
41122 p(in(jr)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
41123 &abs(dhs1)-dhs2/dhs1)
41124 IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0d0) GOTO 640
41125 p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
41126 &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
41127
41128C...Step to new region if necessary.
41129 IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
41130 p(in(jr)+2,4)=p(in(jr)+2,3)
41131 p(in(jr)+2,jt)=1d0
41132 in(jr)=in(jr)+4*js
41133 IF(js*in(jr).GT.js*in(4*jr)) GOTO 640
41134 IF(four(in(1),in(2)).LE.1d-2) THEN
41135 p(in(jt)+2,4)=p(in(jt)+2,3)
41136 p(in(jt)+2,jt)=0d0
41137 in(jt)=in(jt)+4*js
41138 ENDIF
41139 GOTO 890
41140 ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
41141 p(in(jt)+2,4)=p(in(jt)+2,3)
41142 p(in(jt)+2,jt)=0d0
41143 in(jt)=in(jt)+4*js
41144 GOTO 890
41145 ENDIF
41146
41147C...Four-momentum of particle. Remaining quantities. Loop back.
41148 970 DO 980 j=1,4
41149 p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
41150 p(n+nrs,j)=p(n+nrs,j)-p(i,j)
41151 980 CONTINUE
41152 IF(p(i,4).LT.p(i,5)) GOTO 640
41153 kfl(jt)=-kfl(3)
41154 pmq(jt)=pmq(3)
41155 px(jt)=-px(3)
41156 py(jt)=-py(3)
41157 gam(jt)=gam(3)
41158 IF(in(3).NE.in(3*jt+3)) THEN
41159 DO 990 j=1,4
41160 p(in(3*jt+3),j)=p(in(3),j)
41161 p(in(3*jt+3)+1,j)=p(in(3)+1,j)
41162 990 CONTINUE
41163 ENDIF
41164 DO 1000 jq=1,2
41165 in(3*jt+jq)=in(jq)
41166 p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
41167 p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
41168 1000 CONTINUE
41169 GOTO 800
41170
41171C...Final hadron: side, flavour, hadron, mass.
41172 1010 i=i+1
41173 k(i,1)=1
41174 k(i,3)=ie(jr)
41175 k(i,4)=0
41176 k(i,5)=0
41177 CALL pykfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
41178 IF(k(i,2).EQ.0) GOTO 640
41179 p(i,5)=pymass(k(i,2))
41180 pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
41181
41182C...Final two hadrons: find common setup of four-vectors.
41183 jq=1
41184 IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.
41185 &p(in(7)+2,3)*p(in(8)+2,3)*four(in(7),in(8))) jq=2
41186 dhc12=four(in(3*jq+1),in(3*jq+2))
41187 dhr1=four(n+nrs,in(3*jq+2))/dhc12
41188 dhr2=four(n+nrs,in(3*jq+1))/dhc12
41189 IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
41190 px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
41191 py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
41192 pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
41193 & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
41194 ENDIF
41195
41196C...Solve kinematics for final two hadrons, if possible.
41197 wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
41198 fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
41199 IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1d0) GOTO 200
41200 IF(fd.GE.1d0) GOTO 640
41201 fa=wrem2+pr(jt)-pr(jr)
41202 fb=sqrt(max(0d0,fa**2-4d0*wrem2*pr(jt)))
41203 prevcf=parj(42)
41204 IF(mstj(11).EQ.2) prevcf=parj(39)
41205 prev=1d0/(1d0+exp(min(50d0,prevcf*fb)))
41206 fb=sign(fb,js*(pyr(0)-prev))
41207 kfl1a=iabs(kfl(1))
41208 kfl2a=iabs(kfl(2))
41209 IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
41210 &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0d0,fa**2-
41211 &4d0*wrem2*pr(jt))),dble(js))
41212 DO 1020 j=1,4
41213 p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
41214 & p(in(3*jq+3)+1,j)+0.5d0*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
41215 & dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
41216 p(i,j)=p(n+nrs,j)-p(i-1,j)
41217 1020 CONTINUE
41218 IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) GOTO 640
41219
41220C...Mark jets as fragmented and give daughter pointers.
41221 n=i-nrs+1
41222 DO 1030 i=nsav+1,nsav+np
41223 im=k(i,3)
41224 k(im,1)=k(im,1)+10
41225 IF(mstu(16).NE.2) THEN
41226 k(im,4)=nsav+1
41227 k(im,5)=nsav+1
41228 ELSE
41229 k(im,4)=nsav+2
41230 k(im,5)=n
41231 ENDIF
41232 1030 CONTINUE
41233
41234C...Document string system. Move up particles.
41235 nsav=nsav+1
41236 k(nsav,1)=11
41237 k(nsav,2)=92
41238 k(nsav,3)=ip
41239 k(nsav,4)=nsav+1
41240 k(nsav,5)=n
41241 DO 1040 j=1,4
41242 p(nsav,j)=dps(j)
41243 v(nsav,j)=v(ip,j)
41244 1040 CONTINUE
41245 p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
41246 v(nsav,5)=0d0
41247 DO 1060 i=nsav+1,n
41248 DO 1050 j=1,5
41249 k(i,j)=k(i+nrs-1,j)
41250 p(i,j)=p(i+nrs-1,j)
41251 v(i,j)=0d0
41252 1050 CONTINUE
41253 1060 CONTINUE
41254 mstu91=mstu(90)
41255 DO 1070 iz=mstu90+1,mstu91
41256 mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
41257 paru9t(iz)=paru(90+iz)
41258 1070 CONTINUE
41259 mstu(90)=mstu90
41260
41261C...Order particles in rank along the chain. Update mother pointer.
41262 DO 1090 i=nsav+1,n
41263 DO 1080 j=1,5
41264 k(i-nsav+n,j)=k(i,j)
41265 p(i-nsav+n,j)=p(i,j)
41266 1080 CONTINUE
41267 1090 CONTINUE
41268 i1=nsav
41269 DO 1120 i=n+1,2*n-nsav
41270 IF(k(i,3).NE.ie(1)) GOTO 1120
41271 i1=i1+1
41272 DO 1100 j=1,5
41273 k(i1,j)=k(i,j)
41274 p(i1,j)=p(i,j)
41275 1100 CONTINUE
41276 IF(mstu(16).NE.2) k(i1,3)=nsav
41277 DO 1110 iz=mstu90+1,mstu91
41278 IF(mstu9t(iz).EQ.i) THEN
41279 mstu(90)=mstu(90)+1
41280 mstu(90+mstu(90))=i1
41281 paru(90+mstu(90))=paru9t(iz)
41282 ENDIF
41283 1110 CONTINUE
41284 1120 CONTINUE
41285 DO 1150 i=2*n-nsav,n+1,-1
41286 IF(k(i,3).EQ.ie(1)) GOTO 1150
41287 i1=i1+1
41288 DO 1130 j=1,5
41289 k(i1,j)=k(i,j)
41290 p(i1,j)=p(i,j)
41291 1130 CONTINUE
41292 IF(mstu(16).NE.2) k(i1,3)=nsav
41293 DO 1140 iz=mstu90+1,mstu91
41294 IF(mstu9t(iz).EQ.i) THEN
41295 mstu(90)=mstu(90)+1
41296 mstu(90+mstu(90))=i1
41297 paru(90+mstu(90))=paru9t(iz)
41298 ENDIF
41299 1140 CONTINUE
41300 1150 CONTINUE
41301
41302C...Boost back particle system. Set production vertices.
41303 IF(mbst.EQ.0) THEN
41304 mstu(33)=1
41305 CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),
41306 & dps(3)/dps(4))
41307 ELSE
41308 DO 1160 i=nsav+1,n
41309 hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
41310 IF(p(i,3).GT.0d0) THEN
41311 hhpez=(p(i,4)+p(i,3))*hhbz
41312 p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
41313 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
41314 ELSE
41315 hhpez=(p(i,4)-p(i,3))/hhbz
41316 p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
41317 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
41318 ENDIF
41319 1160 CONTINUE
41320 ENDIF
41321 DO 1180 i=nsav+1,n
41322 DO 1170 j=1,4
41323 v(i,j)=v(ip,j)
41324 1170 CONTINUE
41325 1180 CONTINUE
41326
41327 RETURN
41328 END
41329
41330C*********************************************************************
41331
41332C...PYINDF
41333C...Handles the fragmentation of a jet system (or a single
41334C...jet) according to independent fragmentation models.
41335
41336 SUBROUTINE pyindf(IP)
41337
41338C...Double precision and integer declarations.
41339 IMPLICIT DOUBLE PRECISION(a-h, o-z)
41340 IMPLICIT INTEGER(I-N)
41341 INTEGER PYK,PYCHGE,PYCOMP
41342C...Commonblocks.
41343 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
41344 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41345 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41346 SAVE /pyjets/,/pydat1/,/pydat2/
41347C...Local arrays.
41348 dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
41349 &kflo(2),pxo(2),pyo(2),wo(2)
41350
41351C.. MOPS error message
41352 IF(mstj(12).GT.3) CALL pyerrm(9,'(PYINDF:) MSTJ(12)>3 options'//
41353 &' are not treated as expected in independent fragmentation')
41354
41355C...Reset counters. Identify parton system and take copy. Check flavour.
41356 nsav=n
41357 mstu90=mstu(90)
41358 njet=0
41359 kqsum=0
41360 DO 100 j=1,5
41361 dps(j)=0d0
41362 100 CONTINUE
41363 i=ip-1
41364 110 i=i+1
41365 IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
41366 CALL pyerrm(12,'(PYINDF:) failed to reconstruct jet system')
41367 IF(mstu(21).GE.1) RETURN
41368 ENDIF
41369 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 110
41370 kc=pycomp(k(i,2))
41371 IF(kc.EQ.0) GOTO 110
41372 kq=kchg(kc,2)*isign(1,k(i,2))
41373 IF(kq.EQ.0) GOTO 110
41374 njet=njet+1
41375 IF(kq.NE.2) kqsum=kqsum+kq
41376 DO 120 j=1,5
41377 k(nsav+njet,j)=k(i,j)
41378 p(nsav+njet,j)=p(i,j)
41379 dps(j)=dps(j)+p(i,j)
41380 120 CONTINUE
41381 k(nsav+njet,3)=i
41382 IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
41383 &k(i+1,1).EQ.2)) GOTO 110
41384 IF(njet.NE.1.AND.kqsum.NE.0) THEN
41385 CALL pyerrm(12,'(PYINDF:) unphysical flavour combination')
41386 IF(mstu(21).GE.1) RETURN
41387 ENDIF
41388
41389C...Boost copied system to CM frame. Find CM energy and sum flavours.
41390 IF(njet.NE.1) THEN
41391 mstu(33)=1
41392 CALL pyrobo(nsav+1,nsav+njet,0d0,0d0,-dps(1)/dps(4),
41393 & -dps(2)/dps(4),-dps(3)/dps(4))
41394 ENDIF
41395 pecm=0d0
41396 DO 130 j=1,3
41397 nfi(j)=0
41398 130 CONTINUE
41399 DO 140 i=nsav+1,nsav+njet
41400 pecm=pecm+p(i,4)
41401 kfa=iabs(k(i,2))
41402 IF(kfa.LE.3) THEN
41403 nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
41404 ELSEIF(kfa.GT.1000) THEN
41405 kfla=mod(kfa/1000,10)
41406 kflb=mod(kfa/100,10)
41407 IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
41408 IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
41409 ENDIF
41410 140 CONTINUE
41411
41412C...Loop over attempts made. Reset counters.
41413 ntry=0
41414 150 ntry=ntry+1
41415 IF(ntry.GT.200) THEN
41416 CALL pyerrm(14,'(PYINDF:) caught in infinite loop')
41417 IF(mstu(21).GE.1) RETURN
41418 ENDIF
41419 n=nsav+njet
41420 mstu(90)=mstu90
41421 DO 160 j=1,3
41422 nfl(j)=nfi(j)
41423 ifet(j)=0
41424 kflf(j)=0
41425 160 CONTINUE
41426
41427C...Loop over jets to be fragmented.
41428 DO 230 ip1=nsav+1,nsav+njet
41429 mstj(91)=0
41430 nsav1=n
41431 mstu91=mstu(90)
41432
41433C...Initial flavour and momentum values. Jet along +z axis.
41434 kflh=iabs(k(ip1,2))
41435 IF(kflh.GT.10) kflh=mod(kflh/1000,10)
41436 kflo(2)=0
41437 wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
41438
41439C...Initial values for quark or diquark jet.
41440 170 IF(iabs(k(ip1,2)).NE.21) THEN
41441 nstr=1
41442 kflo(1)=k(ip1,2)
41443 CALL pyptdi(0,pxo(1),pyo(1))
41444 wo(1)=wf
41445
41446C...Initial values for gluon treated like random quark jet.
41447 ELSEIF(mstj(2).LE.2) THEN
41448 nstr=1
41449 IF(mstj(2).EQ.2) mstj(91)=1
41450 kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
41451 CALL pyptdi(0,pxo(1),pyo(1))
41452 wo(1)=wf
41453
41454C...Initial values for gluon treated like quark-antiquark jet pair,
41455C...sharing energy according to Altarelli-Parisi splitting function.
41456 ELSE
41457 nstr=2
41458 IF(mstj(2).EQ.4) mstj(91)=1
41459 kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
41460 kflo(2)=-kflo(1)
41461 CALL pyptdi(0,pxo(1),pyo(1))
41462 pxo(2)=-pxo(1)
41463 pyo(2)=-pyo(1)
41464 wo(1)=wf*pyr(0)**(1d0/3d0)
41465 wo(2)=wf-wo(1)
41466 ENDIF
41467
41468C...Initial values for rank, flavour, pT and W+.
41469 DO 220 istr=1,nstr
41470 180 i=n
41471 mstu(90)=mstu91
41472 irank=0
41473 kfl1=kflo(istr)
41474 px1=pxo(istr)
41475 py1=pyo(istr)
41476 w=wo(istr)
41477
41478C...New hadron. Generate flavour and hadron species.
41479 190 i=i+1
41480 IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
41481 CALL pyerrm(11,'(PYINDF:) no more memory left in PYJETS')
41482 IF(mstu(21).GE.1) RETURN
41483 ENDIF
41484 irank=irank+1
41485 k(i,1)=1
41486 k(i,3)=ip1
41487 k(i,4)=0
41488 k(i,5)=0
41489 200 CALL pykfdi(kfl1,0,kfl2,k(i,2))
41490 IF(k(i,2).EQ.0) GOTO 180
41491 IF(irank.EQ.1.AND.iabs(kfl1).LE.10.AND.iabs(kfl2).GT.10) THEN
41492 IF(pyr(0).GT.parj(19)) GOTO 200
41493 ENDIF
41494
41495C...Find hadron mass. Generate four-momentum.
41496 p(i,5)=pymass(k(i,2))
41497 CALL pyptdi(kfl1,px2,py2)
41498 p(i,1)=px1+px2
41499 p(i,2)=py1+py2
41500 pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
41501 CALL pyzdis(kfl1,kfl2,pr,z)
41502 mzsav=0
41503 IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
41504 mzsav=1
41505 mstu(90)=mstu(90)+1
41506 mstu(90+mstu(90))=i
41507 paru(90+mstu(90))=z
41508 ENDIF
41509 p(i,3)=0.5d0*(z*w-pr/max(1d-4,z*w))
41510 p(i,4)=0.5d0*(z*w+pr/max(1d-4,z*w))
41511 IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
41512 & p(i,3).LE.0.001d0) THEN
41513 IF(w.GE.p(i,5)+0.5d0*parj(32)) GOTO 180
41514 p(i,3)=0.0001d0
41515 p(i,4)=sqrt(pr)
41516 z=p(i,4)/w
41517 ENDIF
41518
41519C...Remaining flavour and momentum.
41520 kfl1=-kfl2
41521 px1=-px2
41522 py1=-py2
41523 w=(1d0-z)*w
41524 DO 210 j=1,5
41525 v(i,j)=0d0
41526 210 CONTINUE
41527
41528C...Check if pL acceptable. Go back for new hadron if enough energy.
41529 IF(mstj(3).GE.0.AND.p(i,3).LT.0d0) THEN
41530 i=i-1
41531 IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
41532 ENDIF
41533 IF(w.GT.parj(31)) GOTO 190
41534 n=i
41535 220 CONTINUE
41536 IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1d0*parj(32)
41537 IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) GOTO 170
41538
41539C...Rotate jet to new direction.
41540 the=pyangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
41541 phi=pyangl(p(ip1,1),p(ip1,2))
41542 mstu(33)=1
41543 CALL pyrobo(nsav1+1,n,the,phi,0d0,0d0,0d0)
41544 k(k(ip1,3),4)=nsav1+1
41545 k(k(ip1,3),5)=n
41546
41547C...End of jet generation loop. Skip conservation in some cases.
41548 230 CONTINUE
41549 IF(njet.EQ.1.OR.mstj(3).LE.0) GOTO 490
41550 IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) GOTO 150
41551
41552C...Subtract off produced hadron flavours, finished if zero.
41553 DO 240 i=nsav+njet+1,n
41554 kfa=iabs(k(i,2))
41555 kfla=mod(kfa/1000,10)
41556 kflb=mod(kfa/100,10)
41557 kflc=mod(kfa/10,10)
41558 IF(kfla.EQ.0) THEN
41559 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
41560 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
41561 ELSE
41562 IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
41563 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
41564 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
41565 ENDIF
41566 240 CONTINUE
41567 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
41568 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
41569 IF(nreq.EQ.0) GOTO 320
41570
41571C...Take away flavour of low-momentum particles until enough freedom.
41572 nrem=0
41573 250 irem=0
41574 p2min=pecm**2
41575 DO 260 i=nsav+njet+1,n
41576 p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
41577 IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
41578 IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
41579 260 CONTINUE
41580 IF(irem.EQ.0) GOTO 150
41581 k(irem,1)=7
41582 kfa=iabs(k(irem,2))
41583 kfla=mod(kfa/1000,10)
41584 kflb=mod(kfa/100,10)
41585 kflc=mod(kfa/10,10)
41586 IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
41587 IF(k(irem,1).EQ.8) GOTO 250
41588 IF(kfla.EQ.0) THEN
41589 isgn=isign(1,k(irem,2))*(-1)**kflb
41590 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
41591 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
41592 ELSE
41593 IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
41594 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
41595 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
41596 ENDIF
41597 nrem=nrem+1
41598 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
41599 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
41600 IF(nreq.GT.nrem) GOTO 250
41601 DO 270 i=nsav+njet+1,n
41602 IF(k(i,1).EQ.8) k(i,1)=1
41603 270 CONTINUE
41604
41605C...Find combination of existing and new flavours for hadron.
41606 280 nfet=2
41607 IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
41608 IF(nreq.LT.nrem) nfet=1
41609 IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
41610 DO 290 j=1,nfet
41611 ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*pyr(0)
41612 kflf(j)=isign(1,nfl(1))
41613 IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
41614 IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
41615 290 CONTINUE
41616 IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
41617 &GOTO 280
41618 IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
41619 &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
41620 &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) GOTO 280
41621 IF(nfet.EQ.0) kflf(1)=1+int((2d0+parj(2))*pyr(0))
41622 IF(nfet.EQ.0) kflf(2)=-kflf(1)
41623 IF(nfet.EQ.1) kflf(2)=isign(1+int((2d0+parj(2))*pyr(0)),-kflf(1))
41624 IF(nfet.LE.2) kflf(3)=0
41625 IF(kflf(3).NE.0) THEN
41626 kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
41627 & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
41628 IF(kflf(1).EQ.kflf(3).OR.(1d0+3d0*parj(4))*pyr(0).GT.1d0)
41629 & kflfc=kflfc+isign(2,kflfc)
41630 ELSE
41631 kflfc=kflf(1)
41632 ENDIF
41633 CALL pykfdi(kflfc,kflf(2),kfldmp,kf)
41634 IF(kf.EQ.0) GOTO 280
41635 DO 300 j=1,max(2,nfet)
41636 nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
41637 300 CONTINUE
41638
41639C...Store hadron at random among free positions.
41640 npos=min(1+int(pyr(0)*nrem),nrem)
41641 DO 310 i=nsav+njet+1,n
41642 IF(k(i,1).EQ.7) npos=npos-1
41643 IF(k(i,1).EQ.1.OR.npos.NE.0) GOTO 310
41644 k(i,1)=1
41645 k(i,2)=kf
41646 p(i,5)=pymass(k(i,2))
41647 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
41648 310 CONTINUE
41649 nrem=nrem-1
41650 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
41651 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
41652 IF(nrem.GT.0) GOTO 280
41653
41654C...Compensate for missing momentum in global scheme (3 options).
41655 320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
41656 DO 340 j=1,3
41657 psi(j)=0d0
41658 DO 330 i=nsav+njet+1,n
41659 psi(j)=psi(j)+p(i,j)
41660 330 CONTINUE
41661 340 CONTINUE
41662 psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
41663 pws=0d0
41664 DO 350 i=nsav+njet+1,n
41665 IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
41666 IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
41667 & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
41668 IF(mod(mstj(3),5).EQ.3) pws=pws+1d0
41669 350 CONTINUE
41670 DO 370 i=nsav+njet+1,n
41671 IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
41672 IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
41673 & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
41674 IF(mod(mstj(3),5).EQ.3) pw=1d0
41675 DO 360 j=1,3
41676 p(i,j)=p(i,j)-psi(j)*pw/pws
41677 360 CONTINUE
41678 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
41679 370 CONTINUE
41680
41681C...Compensate for missing momentum withing each jet separately.
41682 ELSEIF(mod(mstj(3),5).EQ.4) THEN
41683 DO 390 i=n+1,n+njet
41684 k(i,1)=0
41685 DO 380 j=1,5
41686 p(i,j)=0d0
41687 380 CONTINUE
41688 390 CONTINUE
41689 DO 410 i=nsav+njet+1,n
41690 ir1=k(i,3)
41691 ir2=n+ir1-nsav
41692 k(ir2,1)=k(ir2,1)+1
41693 pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
41694 & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
41695 DO 400 j=1,3
41696 p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
41697 400 CONTINUE
41698 p(ir2,4)=p(ir2,4)+p(i,4)
41699 p(ir2,5)=p(ir2,5)+pls
41700 410 CONTINUE
41701 pss=0d0
41702 DO 420 i=n+1,n+njet
41703 IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8d0*p(i,5)+0.2d0))
41704 420 CONTINUE
41705 DO 440 i=nsav+njet+1,n
41706 ir1=k(i,3)
41707 ir2=n+ir1-nsav
41708 pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
41709 & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
41710 DO 430 j=1,3
41711 p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1d0/(p(ir2,5)*pss)-1d0)*
41712 & pls*p(ir1,j)
41713 430 CONTINUE
41714 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
41715 440 CONTINUE
41716 ENDIF
41717
41718C...Scale momenta for energy conservation.
41719 IF(mod(mstj(3),5).NE.0) THEN
41720 pms=0d0
41721 pes=0d0
41722 pqs=0d0
41723 DO 450 i=nsav+njet+1,n
41724 pms=pms+p(i,5)
41725 pes=pes+p(i,4)
41726 pqs=pqs+p(i,5)**2/p(i,4)
41727 450 CONTINUE
41728 IF(pms.GE.pecm) GOTO 150
41729 neco=0
41730 460 neco=neco+1
41731 pfac=(pecm-pqs)/(pes-pqs)
41732 pes=0d0
41733 pqs=0d0
41734 DO 480 i=nsav+njet+1,n
41735 DO 470 j=1,3
41736 p(i,j)=pfac*p(i,j)
41737 470 CONTINUE
41738 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
41739 pes=pes+p(i,4)
41740 pqs=pqs+p(i,5)**2/p(i,4)
41741 480 CONTINUE
41742 IF(neco.LT.10.AND.abs(pecm-pes).GT.2d-6*pecm) GOTO 460
41743 ENDIF
41744
41745C...Origin of produced particles and parton daughter pointers.
41746 490 DO 500 i=nsav+njet+1,n
41747 IF(mstu(16).NE.2) k(i,3)=nsav+1
41748 IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
41749 500 CONTINUE
41750 DO 510 i=nsav+1,nsav+njet
41751 i1=k(i,3)
41752 k(i1,1)=k(i1,1)+10
41753 IF(mstu(16).NE.2) THEN
41754 k(i1,4)=nsav+1
41755 k(i1,5)=nsav+1
41756 ELSE
41757 k(i1,4)=k(i1,4)-njet+1
41758 k(i1,5)=k(i1,5)-njet+1
41759 IF(k(i1,5).LT.k(i1,4)) THEN
41760 k(i1,4)=0
41761 k(i1,5)=0
41762 ENDIF
41763 ENDIF
41764 510 CONTINUE
41765
41766C...Document independent fragmentation system. Remove copy of jets.
41767 nsav=nsav+1
41768 k(nsav,1)=11
41769 k(nsav,2)=93
41770 k(nsav,3)=ip
41771 k(nsav,4)=nsav+1
41772 k(nsav,5)=n-njet+1
41773 DO 520 j=1,4
41774 p(nsav,j)=dps(j)
41775 v(nsav,j)=v(ip,j)
41776 520 CONTINUE
41777 p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
41778 v(nsav,5)=0d0
41779 DO 540 i=nsav+njet,n
41780 DO 530 j=1,5
41781 k(i-njet+1,j)=k(i,j)
41782 p(i-njet+1,j)=p(i,j)
41783 v(i-njet+1,j)=v(i,j)
41784 530 CONTINUE
41785 540 CONTINUE
41786 n=n-njet+1
41787 DO 550 iz=mstu90+1,mstu(90)
41788 mstu(90+iz)=mstu(90+iz)-njet+1
41789 550 CONTINUE
41790
41791C...Boost back particle system. Set production vertices.
41792 IF(njet.NE.1) CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),
41793 &dps(2)/dps(4),dps(3)/dps(4))
41794 DO 570 i=nsav+1,n
41795 DO 560 j=1,4
41796 v(i,j)=v(ip,j)
41797 560 CONTINUE
41798 570 CONTINUE
41799
41800 RETURN
41801 END
41802
41803C*********************************************************************
41804
41805C...PYDECY
41806C...Handles the decay of unstable particles.
41807
41808 SUBROUTINE pydecy(IP)
41809
41810C...Double precision and integer declarations.
41811 IMPLICIT DOUBLE PRECISION(a-h, o-z)
41812 IMPLICIT INTEGER(I-N)
41813 INTEGER PYK,PYCHGE,PYCOMP
41814C...Commonblocks.
41815 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
41816 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41817 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41818 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
41819 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
41820C...Local arrays.
41821 dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
41822 &wtcor(10),ptau(4),pcmtau(4),dbetau(3)
41823 CHARACTER CIDC*4
41824 DATA wtcor/2d0,5d0,15d0,60d0,250d0,1500d0,1.2d4,1.2d5,150d0,16d0/
41825
41826C...Functions: momentum in two-particle decays and four-product.
41827 pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)
41828 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)
41829
41830C...Initial values.
41831 ntry=0
41832 nsav=n
41833 kfa=iabs(k(ip,2))
41834 kfs=isign(1,k(ip,2))
41835 kc=pycomp(kfa)
41836 mstj(92)=0
41837
41838C...Choose lifetime and determine decay vertex.
41839 IF(k(ip,1).EQ.5) THEN
41840 v(ip,5)=0d0
41841 ELSEIF(k(ip,1).NE.4) THEN
41842 v(ip,5)=-pmas(kc,4)*log(pyr(0))
41843 ENDIF
41844 DO 100 j=1,4
41845 vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
41846 100 CONTINUE
41847
41848C...Determine whether decay allowed or not.
41849 mout=0
41850 IF(mstj(22).EQ.2) THEN
41851 IF(pmas(kc,4).GT.parj(71)) mout=1
41852 ELSEIF(mstj(22).EQ.3) THEN
41853 IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
41854 ELSEIF(mstj(22).EQ.4) THEN
41855 IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
41856 IF(abs(vdcy(3)).GT.parj(74)) mout=1
41857 ENDIF
41858 IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
41859 k(ip,1)=4
41860 RETURN
41861 ENDIF
41862
41863C...Interface to external tau decay library (for tau polarization).
41864 IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
41865
41866C...Starting values for pointers and momenta.
41867 itau=ip
41868 DO 110 j=1,4
41869 ptau(j)=p(itau,j)
41870 pcmtau(j)=p(itau,j)
41871 110 CONTINUE
41872
41873C...Iterate to find position and code of mother of tau.
41874 imtau=itau
41875 120 imtau=k(imtau,3)
41876
41877 IF(imtau.EQ.0) THEN
41878C...If no known origin then impossible to do anything further.
41879 kforig=0
41880 iorig=0
41881
41882 ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
41883C...If tau -> tau + gamma then add gamma energy and loop.
41884 IF(k(k(imtau,4),2).EQ.22) THEN
41885 DO 130 j=1,4
41886 pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
41887 130 CONTINUE
41888 ELSEIF(k(k(imtau,5),2).EQ.22) THEN
41889 DO 140 j=1,4
41890 pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
41891 140 CONTINUE
41892 ENDIF
41893 GOTO 120
41894
41895 ELSEIF(iabs(k(imtau,2)).GT.100) THEN
41896C...If coming from weak decay of hadron then W is not stored in record,
41897C...but can be reconstructed by adding neutrino momentum.
41898 kforig=-isign(24,k(itau,2))
41899 iorig=0
41900 DO 160 ii=k(imtau,4),k(imtau,5)
41901 IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
41902 DO 150 j=1,4
41903 pcmtau(j)=pcmtau(j)+p(ii,j)
41904 150 CONTINUE
41905 ENDIF
41906 160 CONTINUE
41907
41908 ELSE
41909C...If coming from resonance decay then find latest copy of this
41910C...resonance (may not completely agree).
41911 kforig=k(imtau,2)
41912 iorig=imtau
41913 DO 170 ii=imtau+1,ip-1
41914 IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
41915 & abs(p(ii,5)-p(iorig,5)).LT.1d-5*p(iorig,5)) iorig=ii
41916 170 CONTINUE
41917 DO 180 j=1,4
41918 pcmtau(j)=p(iorig,j)
41919 180 CONTINUE
41920 ENDIF
41921
41922C...Boost tau to rest frame of production process (where known)
41923C...and rotate it to sit along +z axis.
41924 DO 190 j=1,3
41925 dbetau(j)=pcmtau(j)/pcmtau(4)
41926 190 CONTINUE
41927 IF(kforig.NE.0) CALL pyrobo(itau,itau,0d0,0d0,-dbetau(1),
41928 & -dbetau(2),-dbetau(3))
41929 phitau=pyangl(p(itau,1),p(itau,2))
41930 CALL pyrobo(itau,itau,0d0,-phitau,0d0,0d0,0d0)
41931 thetau=pyangl(p(itau,3),p(itau,1))
41932 CALL pyrobo(itau,itau,-thetau,0d0,0d0,0d0,0d0)
41933
41934C...Call tau decay routine (if meaningful) and fill extra info.
41935 IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
41936 CALL pytaud(itau,iorig,kforig,ndecay)
41937 DO 200 ii=nsav+1,nsav+ndecay
41938 k(ii,1)=1
41939 k(ii,3)=ip
41940 k(ii,4)=0
41941 k(ii,5)=0
41942 200 CONTINUE
41943 n=nsav+ndecay
41944 ENDIF
41945
41946C...Boost back decay tau and decay products.
41947 DO 210 j=1,4
41948 p(itau,j)=ptau(j)
41949 210 CONTINUE
41950 IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
41951 CALL pyrobo(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
41952 IF(kforig.NE.0) CALL pyrobo(nsav+1,n,0d0,0d0,dbetau(1),
41953 & dbetau(2),dbetau(3))
41954
41955C...Skip past ordinary tau decay treatment.
41956 mmat=0
41957 mbst=0
41958 nd=0
41959 GOTO 630
41960 ENDIF
41961 ENDIF
41962
41963C...B-Bbar mixing: flip sign of meson appropriately.
41964 mmix=0
41965 IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
41966 xbbmix=parj(76)
41967 IF(kfa.EQ.531) xbbmix=parj(77)
41968 IF(sin(0.5d0*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.pyr(0)) mmix=1
41969 IF(mmix.EQ.1) kfs=-kfs
41970 ENDIF
41971
41972C...Check existence of decay channels. Particle/antiparticle rules.
41973 kca=kc
41974 IF(mdcy(kc,2).GT.0) THEN
41975 mdmdcy=mdme(mdcy(kc,2),2)
41976 IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
41977 ENDIF
41978 IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
41979 CALL pyerrm(9,'(PYDECY:) no decay channel defined')
41980 RETURN
41981 ENDIF
41982 IF(mod(kfa/1000,10).EQ.0.AND.kca.EQ.85) kfs=-kfs
41983 IF(kchg(kc,3).EQ.0) THEN
41984 kfsp=1
41985 kfsn=0
41986 IF(pyr(0).GT.0.5d0) kfs=-kfs
41987 ELSEIF(kfs.GT.0) THEN
41988 kfsp=1
41989 kfsn=0
41990 ELSE
41991 kfsp=0
41992 kfsn=1
41993 ENDIF
41994
41995C...Sum branching ratios of allowed decay channels.
41996 220 nope=0
41997 brsu=0d0
41998 DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
41999 IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
42000 & kfsn*mdme(idl,1).NE.3) GOTO 230
42001 IF(mdme(idl,2).GT.100) GOTO 230
42002 nope=nope+1
42003 brsu=brsu+brat(idl)
42004 230 CONTINUE
42005 IF(nope.EQ.0) THEN
42006 CALL pyerrm(2,'(PYDECY:) all decay channels closed by user')
42007 RETURN
42008 ENDIF
42009
42010C...Select decay channel among allowed ones.
42011 240 rbr=brsu*pyr(0)
42012 idl=mdcy(kca,2)-1
42013 250 idl=idl+1
42014 IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
42015 &kfsn*mdme(idl,1).NE.3) THEN
42016 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 250
42017 ELSEIF(mdme(idl,2).GT.100) THEN
42018 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 250
42019 ELSE
42020 idc=idl
42021 rbr=rbr-brat(idl)
42022 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0d0) GOTO 250
42023 ENDIF
42024
42025C...Start readout of decay channel: matrix element, reset counters.
42026 mmat=mdme(idc,2)
42027 260 ntry=ntry+1
42028 IF(mod(ntry,200).EQ.0) THEN
42029 WRITE(cidc,'(I4)') idc
42030C...Do not print warning for some well-known special cases.
42031 IF(kfa.NE.113.AND.kfa.NE.115.AND.kfa.NE.215)
42032 & CALL pyerrm(4,'(PYDECY:) caught in loop for decay channel'//
42033 & cidc)
42034 GOTO 240
42035 ENDIF
42036 IF(ntry.GT.1000) THEN
42037 CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
42038 IF(mstu(21).GE.1) RETURN
42039 ENDIF
42040 i=n
42041 np=0
42042 nq=0
42043 mbst=0
42044 IF(mmat.GE.11.AND.p(ip,4).GT.20d0*p(ip,5)) mbst=1
42045 DO 270 j=1,4
42046 pv(1,j)=0d0
42047 IF(mbst.EQ.0) pv(1,j)=p(ip,j)
42048 270 CONTINUE
42049 IF(mbst.EQ.1) pv(1,4)=p(ip,5)
42050 pv(1,5)=p(ip,5)
42051 ps=0d0
42052 psq=0d0
42053 mrem=0
42054 mhaddy=0
42055 IF(kfa.GT.80) mhaddy=1
42056C.. Random flavour and popcorn system memory.
42057 irndmo=0
42058 jtmo=0
42059 mstu(121)=0
42060 mstu(125)=10
42061
42062C...Read out decay products. Convert to standard flavour code.
42063 jtmax=5
42064 IF(mdme(idc+1,2).EQ.101) jtmax=10
42065 DO 280 jt=1,jtmax
42066 IF(jt.LE.5) kp=kfdp(idc,jt)
42067 IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
42068 IF(kp.EQ.0) GOTO 280
42069 kpa=iabs(kp)
42070 kcp=pycomp(kpa)
42071 IF(kpa.GT.80) mhaddy=1
42072 IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
42073 kfp=kp
42074 ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
42075 kfp=kfs*kp
42076 ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
42077 kfp=-kfs*mod(kfa/10,10)
42078 ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
42079 kfp=kfs*(100*mod(kfa/10,100)+3)
42080 ELSEIF(kpa.EQ.81) THEN
42081 kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
42082 ELSEIF(kp.EQ.82) THEN
42083 CALL pydcyk(-kfs*int(1d0+(2d0+parj(2))*pyr(0)),0,kfp,kdump)
42084 IF(kfp.EQ.0) GOTO 260
42085 kfp=-kfp
42086 irndmo=1
42087 mstj(93)=1
42088 IF(pv(1,5).LT.parj(32)+2d0*pymass(kfp)) GOTO 260
42089 ELSEIF(kp.EQ.-82) THEN
42090 kfp=mstu(124)
42091 ENDIF
42092 IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=pycomp(kfp)
42093
42094C...Add decay product to event record or to quark flavour list.
42095 kfpa=iabs(kfp)
42096 kqp=kchg(kcp,2)
42097 IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
42098 nq=nq+1
42099 kflo(nq)=kfp
42100C...set rndmflav popcorn system pointer
42101 IF(kp.EQ.82.AND.mstu(121).GT.0) jtmo=nq
42102 mstj(93)=2
42103 psq=psq+pymass(kflo(nq))
42104 ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
42105 & mod(nq,2).EQ.1) THEN
42106 nq=nq-1
42107 ps=ps-p(i,5)
42108 k(i,1)=1
42109 kfi=k(i,2)
42110 CALL pykfdi(kfp,kfi,kfldmp,k(i,2))
42111 IF(k(i,2).EQ.0) GOTO 260
42112 mstj(93)=1
42113 p(i,5)=pymass(k(i,2))
42114 ps=ps+p(i,5)
42115 ELSE
42116 i=i+1
42117 np=np+1
42118 IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
42119 IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
42120 k(i,1)=1+mod(nq,2)
42121 IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
42122 IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
42123 k(i,2)=kfp
42124 k(i,3)=ip
42125 k(i,4)=0
42126 k(i,5)=0
42127 p(i,5)=pymass(kfp)
42128 ps=ps+p(i,5)
42129 ENDIF
42130 280 CONTINUE
42131
42132C...Check masses for resonance decays.
42133 IF(mhaddy.EQ.0) THEN
42134 IF(ps+parj(64).GT.pv(1,5)) GOTO 240
42135 ENDIF
42136
42137C...Choose decay multiplicity in phase space model.
42138 290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
42139 psp=ps
42140 cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1d0))
42141 IF(mmat.EQ.12) cnde=cnde+parj(63)
42142 300 ntry=ntry+1
42143C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
42144 IF(irndmo.EQ.0) THEN
42145 mstu(121)=0
42146 jtmo=0
42147 ELSEIF(irndmo.EQ.1) THEN
42148 irndmo=2
42149 ELSE
42150 GOTO 260
42151 ENDIF
42152 IF(ntry.GT.1000) THEN
42153 CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
42154 IF(mstu(21).GE.1) RETURN
42155 ENDIF
42156 IF(mmat.LE.20) THEN
42157 gauss=sqrt(-2d0*cnde*log(max(1d-10,pyr(0))))*
42158 & sin(paru(2)*pyr(0))
42159 nd=0.5d0+0.5d0*np+0.25d0*nq+cnde+gauss
42160 IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) GOTO 300
42161 IF(mmat.EQ.13.AND.nd.EQ.2) GOTO 300
42162 IF(mmat.EQ.14.AND.nd.LE.3) GOTO 300
42163 IF(mmat.EQ.15.AND.nd.LE.4) GOTO 300
42164 ELSE
42165 nd=mmat-20
42166 ENDIF
42167C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
42168 mstu(125)=nd-nq/2
42169 IF(mstu(121).GT.mstu(125)) GOTO 300
42170
42171C...Form hadrons from flavour content.
42172 DO 310 jt=1,nq
42173 kfl1(jt)=kflo(jt)
42174 310 CONTINUE
42175 IF(nd.EQ.np+nq/2) GOTO 330
42176 DO 320 i=n+np+1,n+nd-nq/2
42177C.. Stick to started popcorn system, else pick side at random
42178 jt=jtmo
42179 IF(jt.EQ.0) jt=1+int((nq-1)*pyr(0))
42180 CALL pydcyk(kfl1(jt),0,kfl2,k(i,2))
42181 IF(k(i,2).EQ.0) GOTO 300
42182 mstu(125)=mstu(125)-1
42183 jtmo=0
42184 IF(mstu(121).GT.0) jtmo=jt
42185 kfl1(jt)=-kfl2
42186 320 CONTINUE
42187 330 jt=2
42188 jt2=3
42189 jt3=4
42190 IF(nq.EQ.4.AND.pyr(0).LT.parj(66)) jt=4
42191 IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
42192 & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
42193 IF(jt.EQ.3) jt2=2
42194 IF(jt.EQ.4) jt3=2
42195 CALL pydcyk(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
42196 IF(k(n+nd-nq/2+1,2).EQ.0) GOTO 300
42197 IF(nq.EQ.4) CALL pydcyk(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
42198 IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) GOTO 300
42199
42200C...Check that sum of decay product masses not too large.
42201 ps=psp
42202 DO 340 i=n+np+1,n+nd
42203 k(i,1)=1
42204 k(i,3)=ip
42205 k(i,4)=0
42206 k(i,5)=0
42207 p(i,5)=pymass(k(i,2))
42208 ps=ps+p(i,5)
42209 340 CONTINUE
42210 IF(ps+parj(64).GT.pv(1,5)) GOTO 300
42211
42212C...Rescale energy to subtract off spectator quark mass.
42213 ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44)
42214 & .AND.np.GE.3) THEN
42215 ps=ps-p(n+np,5)
42216 pqt=(p(n+np,5)+parj(65))/pv(1,5)
42217 DO 350 j=1,5
42218 p(n+np,j)=pqt*pv(1,j)
42219 pv(1,j)=(1d0-pqt)*pv(1,j)
42220 350 CONTINUE
42221 IF(ps+parj(64).GT.pv(1,5)) GOTO 260
42222 nd=np-1
42223 mrem=1
42224
42225C...Fully specified final state: check mass broadening effects.
42226 ELSE
42227 IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) GOTO 260
42228 nd=np
42229 ENDIF
42230
42231C...Determine position of grandmother, number of sisters.
42232 nm=0
42233 kfas=0
42234 msgn=0
42235 IF(mmat.EQ.3) THEN
42236 im=k(ip,3)
42237 IF(im.LT.0.OR.im.GE.ip) im=0
42238 IF(im.NE.0) kfam=iabs(k(im,2))
42239 IF(im.NE.0) THEN
42240 DO 360 il=max(ip-2,im+1),min(ip+2,n)
42241 IF(k(il,3).EQ.im) nm=nm+1
42242 IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
42243 360 CONTINUE
42244 IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
42245 & mod(kfam/1000,10).NE.0) nm=0
42246 IF(nm.EQ.2) THEN
42247 kfas=iabs(k(isis,2))
42248 IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
42249 & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
42250 ENDIF
42251 ENDIF
42252 ENDIF
42253
42254C...Kinematics of one-particle decays.
42255 IF(nd.EQ.1) THEN
42256 DO 370 j=1,4
42257 p(n+1,j)=p(ip,j)
42258 370 CONTINUE
42259 GOTO 630
42260 ENDIF
42261
42262C...Calculate maximum weight ND-particle decay.
42263 pv(nd,5)=p(n+nd,5)
42264 IF(nd.GE.3) THEN
42265 wtmax=1d0/wtcor(nd-2)
42266 pmax=pv(1,5)-ps+p(n+nd,5)
42267 pmin=0d0
42268 DO 380 il=nd-1,1,-1
42269 pmax=pmax+p(n+il,5)
42270 pmin=pmin+p(n+il+1,5)
42271 wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
42272 380 CONTINUE
42273 ENDIF
42274
42275C...Find virtual gamma mass in Dalitz decay.
42276 390 IF(nd.EQ.2) THEN
42277 ELSEIF(mmat.EQ.2) THEN
42278 pmes=4d0*pmas(11,1)**2
42279 pmrho2=pmas(131,1)**2
42280 pgrho2=pmas(131,2)**2
42281 400 pmst=pmes*(p(ip,5)**2/pmes)**pyr(0)
42282 wt=(1+0.5d0*pmes/pmst)*sqrt(max(0d0,1d0-pmes/pmst))*
42283 & (1d0-pmst/p(ip,5)**2)**3*(1d0+pgrho2/pmrho2)/
42284 & ((1d0-pmst/pmrho2)**2+pgrho2/pmrho2)
42285 IF(wt.LT.pyr(0)) GOTO 400
42286 pv(2,5)=max(2.00001d0*pmas(11,1),sqrt(pmst))
42287
42288C...M-generator gives weight. If rejected, try again.
42289 ELSE
42290 410 rord(1)=1d0
42291 DO 440 il1=2,nd-1
42292 rsav=pyr(0)
42293 DO 420 il2=il1-1,1,-1
42294 IF(rsav.LE.rord(il2)) GOTO 430
42295 rord(il2+1)=rord(il2)
42296 420 CONTINUE
42297 430 rord(il2+1)=rsav
42298 440 CONTINUE
42299 rord(nd)=0d0
42300 wt=1d0
42301 DO 450 il=nd-1,1,-1
42302 pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*
42303 & (pv(1,5)-ps)
42304 wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
42305 450 CONTINUE
42306 IF(wt.LT.pyr(0)*wtmax) GOTO 410
42307 ENDIF
42308
42309C...Perform two-particle decays in respective CM frame.
42310 460 DO 480 il=1,nd-1
42311 pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
42312 ue(3)=2d0*pyr(0)-1d0
42313 phi=paru(2)*pyr(0)
42314 ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
42315 ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
42316 DO 470 j=1,3
42317 p(n+il,j)=pa*ue(j)
42318 pv(il+1,j)=-pa*ue(j)
42319 470 CONTINUE
42320 p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
42321 pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
42322 480 CONTINUE
42323
42324C...Lorentz transform decay products to lab frame.
42325 DO 490 j=1,4
42326 p(n+nd,j)=pv(nd,j)
42327 490 CONTINUE
42328 DO 530 il=nd-1,1,-1
42329 DO 500 j=1,3
42330 be(j)=pv(il,j)/pv(il,4)
42331 500 CONTINUE
42332 ga=pv(il,4)/pv(il,5)
42333 DO 520 i=n+il,n+nd
42334 bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
42335 DO 510 j=1,3
42336 p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
42337 510 CONTINUE
42338 p(i,4)=ga*(p(i,4)+bep)
42339 520 CONTINUE
42340 530 CONTINUE
42341
42342C...Check that no infinite loop in matrix element weight.
42343 ntry=ntry+1
42344 IF(ntry.GT.800) GOTO 560
42345
42346C...Matrix elements for omega and phi decays.
42347 IF(mmat.EQ.1) THEN
42348 wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
42349 & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
42350 & +2d0*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
42351 IF(max(wt*wtcor(9)/p(ip,5)**6,0.001d0).LT.pyr(0)) GOTO 390
42352
42353C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
42354 ELSEIF(mmat.EQ.2) THEN
42355 four12=four(n+1,n+2)
42356 four13=four(n+1,n+3)
42357 wt=(pmst-0.5d0*pmes)*(four12**2+four13**2)+
42358 & pmes*(four12*four13+four12**2+four13**2)
42359 IF(wt.LT.pyr(0)*0.25d0*pmst*(p(ip,5)**2-pmst)**2) GOTO 460
42360
42361C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
42362C...V vector), of form cos**2(theta02) in V1 rest frame, and for
42363C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
42364 ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
42365 four10=four(ip,im)
42366 four12=four(ip,n+1)
42367 four02=four(im,n+1)
42368 pms1=p(ip,5)**2
42369 pms0=p(im,5)**2
42370 pms2=p(n+1,5)**2
42371 IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
42372 IF(kfas.EQ.22) hnum=pms1*(2d0*four10*four12*four02-
42373 & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
42374 hnum=max(1d-6*pms1**2*pms0*pms2,hnum)
42375 hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
42376 IF(hnum.LT.pyr(0)*hden) GOTO 460
42377
42378C...Matrix element for "onium" -> g + g + g or gamma + g + g.
42379 ELSEIF(mmat.EQ.4) THEN
42380 hx1=2d0*four(ip,n+1)/p(ip,5)**2
42381 hx2=2d0*four(ip,n+2)/p(ip,5)**2
42382 hx3=2d0*four(ip,n+3)/p(ip,5)**2
42383 wt=((1d0-hx1)/(hx2*hx3))**2+((1d0-hx2)/(hx1*hx3))**2+
42384 & ((1d0-hx3)/(hx1*hx2))**2
42385 IF(wt.LT.2d0*pyr(0)) GOTO 390
42386 IF(k(ip+1,2).EQ.22.AND.(1d0-hx1)*p(ip,5)**2.LT.4d0*parj(32)**2)
42387 & GOTO 390
42388
42389C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
42390 ELSEIF(mmat.EQ.41) THEN
42391 hx1=2d0*four(ip,n+1)/p(ip,5)**2
42392 hxm=min(0.75d0,2d0*(1d0-ps/p(ip,5)))
42393 IF(hx1*(3d0-2d0*hx1).LT.pyr(0)*hxm*(3d0-2d0*hxm)) GOTO 390
42394
42395C...Matrix elements for weak decays (only semileptonic for c and b)
42396 ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
42397 & .AND.nd.EQ.3) THEN
42398 IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
42399 IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
42400 IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 390
42401 ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
42402 DO 550 j=1,4
42403 p(n+np+1,j)=0d0
42404 DO 540 is=n+3,n+np
42405 p(n+np+1,j)=p(n+np+1,j)+p(is,j)
42406 540 CONTINUE
42407 550 CONTINUE
42408 IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
42409 IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
42410 IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 390
42411 ENDIF
42412
42413C...Scale back energy and reattach spectator.
42414 560 IF(mrem.EQ.1) THEN
42415 DO 570 j=1,5
42416 pv(1,j)=pv(1,j)/(1d0-pqt)
42417 570 CONTINUE
42418 nd=nd+1
42419 mrem=0
42420 ENDIF
42421
42422C...Low invariant mass for system with spectator quark gives particle,
42423C...not two jets. Readjust momenta accordingly.
42424 IF(mmat.EQ.31.AND.nd.EQ.3) THEN
42425 mstj(93)=1
42426 pm2=pymass(k(n+2,2))
42427 mstj(93)=1
42428 pm3=pymass(k(n+3,2))
42429 IF(p(n+2,5)**2+p(n+3,5)**2+2d0*four(n+2,n+3).GE.
42430 & (parj(32)+pm2+pm3)**2) GOTO 630
42431 k(n+2,1)=1
42432 kftemp=k(n+2,2)
42433 CALL pykfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
42434 IF(k(n+2,2).EQ.0) GOTO 260
42435 p(n+2,5)=pymass(k(n+2,2))
42436 ps=p(n+1,5)+p(n+2,5)
42437 pv(2,5)=p(n+2,5)
42438 mmat=0
42439 nd=2
42440 GOTO 460
42441 ELSEIF(mmat.EQ.44) THEN
42442 mstj(93)=1
42443 pm3=pymass(k(n+3,2))
42444 mstj(93)=1
42445 pm4=pymass(k(n+4,2))
42446 IF(p(n+3,5)**2+p(n+4,5)**2+2d0*four(n+3,n+4).GE.
42447 & (parj(32)+pm3+pm4)**2) GOTO 600
42448 k(n+3,1)=1
42449 kftemp=k(n+3,2)
42450 CALL pykfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
42451 IF(k(n+3,2).EQ.0) GOTO 260
42452 p(n+3,5)=pymass(k(n+3,2))
42453 DO 580 j=1,3
42454 p(n+3,j)=p(n+3,j)+p(n+4,j)
42455 580 CONTINUE
42456 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)
42457 ha=p(n+1,4)**2-p(n+2,4)**2
42458 hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
42459 hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
42460 & (p(n+1,3)-p(n+2,3))**2
42461 hd=(pv(1,4)-p(n+3,4))**2
42462 he=ha**2-2d0*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
42463 hf=hd*hc-hb**2
42464 hg=hd*hc-ha*hb
42465 hh=(sqrt(hg**2+he*hf)-hg)/(2d0*hf)
42466 DO 590 j=1,3
42467 pcor=hh*(p(n+1,j)-p(n+2,j))
42468 p(n+1,j)=p(n+1,j)+pcor
42469 p(n+2,j)=p(n+2,j)-pcor
42470 590 CONTINUE
42471 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)
42472 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)
42473 nd=nd-1
42474 ENDIF
42475
42476C...Check invariant mass of W jets. May give one particle or start over.
42477 600 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
42478 &.AND.iabs(k(n+1,2)).LT.10) THEN
42479 pmr=sqrt(max(0d0,p(n+1,5)**2+p(n+2,5)**2+2d0*four(n+1,n+2)))
42480 mstj(93)=1
42481 pm1=pymass(k(n+1,2))
42482 mstj(93)=1
42483 pm2=pymass(k(n+2,2))
42484 IF(pmr.GT.parj(32)+pm1+pm2) GOTO 610
42485 kfldum=int(1.5d0+pyr(0))
42486 CALL pykfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
42487 CALL pykfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
42488 IF(kf1.EQ.0.OR.kf2.EQ.0) GOTO 260
42489 psm=pymass(kf1)+pymass(kf2)
42490 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) GOTO 610
42491 IF(mmat.GE.43.AND.pmr.GT.0.2d0*parj(32)+psm) GOTO 610
42492 IF(mmat.EQ.48) GOTO 390
42493 IF(nd.EQ.4.OR.kfa.EQ.15) GOTO 260
42494 k(n+1,1)=1
42495 kftemp=k(n+1,2)
42496 CALL pykfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
42497 IF(k(n+1,2).EQ.0) GOTO 260
42498 p(n+1,5)=pymass(k(n+1,2))
42499 k(n+2,2)=k(n+3,2)
42500 p(n+2,5)=p(n+3,5)
42501 ps=p(n+1,5)+p(n+2,5)
42502 IF(ps+parj(64).GT.pv(1,5)) GOTO 260
42503 pv(2,5)=p(n+3,5)
42504 mmat=0
42505 nd=2
42506 GOTO 460
42507 ENDIF
42508
42509C...Phase space decay of partons from W decay.
42510 610 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
42511 kflo(1)=k(n+1,2)
42512 kflo(2)=k(n+2,2)
42513 k(n+1,1)=k(n+3,1)
42514 k(n+1,2)=k(n+3,2)
42515 DO 620 j=1,5
42516 pv(1,j)=p(n+1,j)+p(n+2,j)
42517 p(n+1,j)=p(n+3,j)
42518 620 CONTINUE
42519 pv(1,5)=pmr
42520 n=n+1
42521 np=0
42522 nq=2
42523 ps=0d0
42524 mstj(93)=2
42525 psq=pymass(kflo(1))
42526 mstj(93)=2
42527 psq=psq+pymass(kflo(2))
42528 mmat=11
42529 GOTO 290
42530 ENDIF
42531
42532C...Boost back for rapidly moving particle.
42533 630 n=n+nd
42534 IF(mbst.EQ.1) THEN
42535 DO 640 j=1,3
42536 be(j)=p(ip,j)/p(ip,4)
42537 640 CONTINUE
42538 ga=p(ip,4)/p(ip,5)
42539 DO 660 i=nsav+1,n
42540 bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
42541 DO 650 j=1,3
42542 p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
42543 650 CONTINUE
42544 p(i,4)=ga*(p(i,4)+bep)
42545 660 CONTINUE
42546 ENDIF
42547
42548C...Fill in position of decay vertex.
42549 DO 680 i=nsav+1,n
42550 DO 670 j=1,4
42551 v(i,j)=vdcy(j)
42552 670 CONTINUE
42553 v(i,5)=0d0
42554 680 CONTINUE
42555
42556C...Set up for parton shower evolution from jets.
42557 IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
42558 k(nsav+1,1)=3
42559 k(nsav+2,1)=3
42560 k(nsav+3,1)=3
42561 k(nsav+1,4)=mstu(5)*(nsav+2)
42562 k(nsav+1,5)=mstu(5)*(nsav+3)
42563 k(nsav+2,4)=mstu(5)*(nsav+3)
42564 k(nsav+2,5)=mstu(5)*(nsav+1)
42565 k(nsav+3,4)=mstu(5)*(nsav+1)
42566 k(nsav+3,5)=mstu(5)*(nsav+2)
42567 mstj(92)=-(nsav+1)
42568 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
42569 k(nsav+2,1)=3
42570 k(nsav+3,1)=3
42571 k(nsav+2,4)=mstu(5)*(nsav+3)
42572 k(nsav+2,5)=mstu(5)*(nsav+3)
42573 k(nsav+3,4)=mstu(5)*(nsav+2)
42574 k(nsav+3,5)=mstu(5)*(nsav+2)
42575 mstj(92)=nsav+2
42576 ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
42577 & iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
42578 k(nsav+1,1)=3
42579 k(nsav+2,1)=3
42580 k(nsav+1,4)=mstu(5)*(nsav+2)
42581 k(nsav+1,5)=mstu(5)*(nsav+2)
42582 k(nsav+2,4)=mstu(5)*(nsav+1)
42583 k(nsav+2,5)=mstu(5)*(nsav+1)
42584 mstj(92)=nsav+1
42585 ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
42586 & iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
42587 mstj(92)=nsav+1
42588 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
42589 & THEN
42590 k(nsav+1,1)=3
42591 k(nsav+2,1)=3
42592 k(nsav+3,1)=3
42593 kcp=pycomp(k(nsav+1,2))
42594 kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
42595 jcon=4
42596 IF(kqp.LT.0) jcon=5
42597 k(nsav+1,jcon)=mstu(5)*(nsav+2)
42598 k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
42599 k(nsav+2,jcon)=mstu(5)*(nsav+3)
42600 k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
42601 mstj(92)=nsav+1
42602 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
42603 k(nsav+1,1)=3
42604 k(nsav+3,1)=3
42605 k(nsav+1,4)=mstu(5)*(nsav+3)
42606 k(nsav+1,5)=mstu(5)*(nsav+3)
42607 k(nsav+3,4)=mstu(5)*(nsav+1)
42608 k(nsav+3,5)=mstu(5)*(nsav+1)
42609 mstj(92)=nsav+1
42610 ENDIF
42611
42612C...Mark decayed particle; special option for B-Bbar mixing.
42613 IF(k(ip,1).EQ.5) k(ip,1)=15
42614 IF(k(ip,1).LE.10) k(ip,1)=11
42615 IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
42616 k(ip,4)=nsav+1
42617 k(ip,5)=n
42618
42619 RETURN
42620 END
42621
42622
42623C*********************************************************************
42624
42625C...PYDCYK
42626C...Handles flavour production in the decay of unstable particles
42627C...and small string clusters.
42628
42629 SUBROUTINE pydcyk(KFL1,KFL2,KFL3,KF)
42630
42631C...Double precision and integer declarations.
42632 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42633 IMPLICIT INTEGER(I-N)
42634 INTEGER PYK,PYCHGE,PYCOMP
42635C...Commonblocks.
42636 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42637 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42638 SAVE /pydat1/,/pydat2/
42639
42640
42641C.. Call PYKFDI directly if no popcorn option is on
42642 IF(mstj(12).LT.2) THEN
42643 CALL pykfdi(kfl1,kfl2,kfl3,kf)
42644 mstu(124)=kfl3
42645 RETURN
42646 ENDIF
42647
42648 kfl3=0
42649 kf=0
42650 IF(kfl1.EQ.0) RETURN
42651 kf1a=iabs(kfl1)
42652 kf2a=iabs(kfl2)
42653
42654 nsto=130
42655 nmax=min(mstu(125),10)
42656
42657C.. Identify rank 0 cluster qq
42658 irank=1
42659 IF(kf1a.GT.10.AND.kf1a.LT.10000) irank=0
42660
42661 IF(kf2a.GT.0)THEN
42662C.. Join jets: Fails if store not empty
42663 IF(mstu(121).GT.0) THEN
42664 mstu(121)=0
42665 RETURN
42666 ENDIF
42667 CALL pykfdi(kfl1,kfl2,kfl3,kf)
42668 ELSEIF(kf1a.GT.10.AND.mstu(121).GT.0)THEN
42669C.. Pick popcorn meson from store, return same qq, decrease store
42670 kf=mstu(nsto+mstu(121))
42671 kfl3=-kfl1
42672 mstu(121)=mstu(121)-1
42673 ELSE
42674C.. Generate new flavour. Then done if no diquark is generated
42675 100 CALL pykfdi(kfl1,0,kfl3,kf)
42676 IF(mstu(121).EQ.-1) GOTO 100
42677 mstu(124)=kfl3
42678 IF(kf.EQ.0.OR.iabs(kfl3).LE.10) RETURN
42679
42680C.. Simple case if no dynamical popcorn suppressions are considered
42681 IF(mstj(12).LT.4) THEN
42682 IF(mstu(121).EQ.0) RETURN
42683 nmes=1
42684 kfprev=-kfl3
42685 CALL pykfdi(kfprev,0,kfl3,kfm)
42686C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
42687 IF(iabs(kfl3).LE.10)THEN
42688 kfl3=-kfprev
42689 RETURN
42690 ENDIF
42691 GOTO 120
42692 ENDIF
42693
42694C test output qq against fake Gamma, then return if no popcorn.
42695 gb=2d0
42696 IF(irank.NE.0)THEN
42697 CALL pyzdis(1,2103,5d0,z)
42698 gb=5d0*(1d0-z)/z
42699 IF(1d0-parf(192)**gb.LT.pyr(0)) THEN
42700 mstu(121)=0
42701 GOTO 100
42702 ENDIF
42703 ENDIF
42704 IF(mstu(121).EQ.0) RETURN
42705
42706C..Set store size memory. Pick fake dynamical variables of qq.
42707 nmes=mstu(121)
42708 CALL pyptdi(1,px3,py3)
42709 x=1d0
42710 popm=0d0
42711 g=gb
42712 popg=gb
42713
42714C.. Pick next popcorn meson, test with fake dynamical variables
42715 110 kfprev=-kfl3
42716 px1=-px3
42717 py1=-py3
42718 CALL pykfdi(kfprev,0,kfl3,kfm)
42719 IF(mstu(121).EQ.-1) GOTO 100
42720 CALL pyptdi(kfl3,px3,py3)
42721 pm=pymass(kfm)**2+(px1+px3)**2+(py1+py3)**2
42722 CALL pyzdis(kfprev,kfl3,pm,z)
42723 g=(1d0-z)*(g+pm/z)
42724 x=(1d0-z)*x
42725
42726 ptst=1d0
42727 gtst=1d0
42728 rtst=pyr(0)
42729 IF(mstj(12).GT.4)THEN
42730 popmn=sqrt((1d0-x)*(g/x-gb))
42731 popm=popm+pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
42732 ptst=exp((popm-popmn)*parf(193))
42733 popm=popmn
42734 ENDIF
42735 IF(irank.NE.0)THEN
42736 popgn=x*gb
42737 gtst=(1d0-parf(192)**popgn)/(1d0-parf(192)**popg)
42738 popg=popgn
42739 ENDIF
42740 IF(rtst.GT.ptst*gtst)THEN
42741 mstu(121)=0
42742 IF(rtst.GT.ptst) mstu(121)=-1
42743 GOTO 100
42744 ENDIF
42745
42746C.. Store meson
42747 120 IF(nmes.LE.nmax) mstu(nsto+mstu(121)+1)=kfm
42748 IF(mstu(121).GT.0) GOTO 110
42749
42750C.. Test accepted system size. If OK set global popcorn size variable.
42751 IF(nmes.GT.nmax)THEN
42752 kf=0
42753 kfl3=0
42754 RETURN
42755 ENDIF
42756 mstu(121)=nmes
42757 ENDIF
42758
42759 RETURN
42760 END
42761
42762C********************************************************************
42763
42764C...PYKFDI
42765C...Generates a new flavour pair and combines off a hadron
42766
42767 SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)
42768
42769C...Double precision and integer declarations.
42770 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42771 IMPLICIT INTEGER(I-N)
42772 INTEGER PYK,PYCHGE,PYCOMP
42773C...Commonblocks.
42774 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42775 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42776 SAVE /pydat1/,/pydat2/
42777C...Local arrays.
42778 dimension pd(7)
42779
42780 IF(mstu(123).EQ.0.AND.mstj(12).GT.0) CALL pykfin
42781
42782C...Default flavour values. Input consistency checks.
42783 kf1a=iabs(kfl1)
42784 kf2a=iabs(kfl2)
42785 kfl3=0
42786 kf=0
42787 IF(kf1a.EQ.0) RETURN
42788 IF(kf2a.NE.0)THEN
42789 IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
42790 IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
42791 IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
42792 ENDIF
42793
42794C...Check if tabulated flavour probabilities are to be used.
42795 IF(mstj(15).EQ.1) THEN
42796 IF(mstj(12).GE.5) CALL pyerrm(29,
42797 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
42798 & ' together with MSTJ(12)>=5 modification')
42799 ktab1=-1
42800 IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
42801 kfl1a=mod(kf1a/1000,10)
42802 kfl1b=mod(kf1a/100,10)
42803 kfl1s=mod(kf1a,10)
42804 IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
42805 & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
42806 IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
42807 IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
42808 ktab2=0
42809 IF(kf2a.NE.0) THEN
42810 ktab2=-1
42811 IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
42812 kfl2a=mod(kf2a/1000,10)
42813 kfl2b=mod(kf2a/100,10)
42814 kfl2s=mod(kf2a,10)
42815 IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
42816 & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
42817 IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
42818 ENDIF
42819 IF(ktab1.GE.0.AND.ktab2.GE.0) GOTO 140
42820 ENDIF
42821
42822C.. Recognize rank 0 diquark case
42823 100 irank=1
42824 kfdiq=max(kf1a,kf2a)
42825 IF(kfdiq.GT.10.AND.kfdiq.LT.10000) irank=0
42826
42827C.. Join two flavours to meson or baryon. Test for popcorn.
42828 IF(kf2a.GT.0)THEN
42829 mbary=0
42830 IF(kfdiq.GT.10) THEN
42831 IF(irank.EQ.0.AND.mstj(12).LT.5)
42832 & CALL pynmes(kfdiq)
42833 IF(mstu(121).NE.0) THEN
42834 mstu(121)=0
42835 RETURN
42836 ENDIF
42837 mbary=2
42838 ENDIF
42839 kfqold=kf1a
42840 kfqver=kf2a
42841 GOTO 130
42842 ENDIF
42843
42844C.. Separate incoming flavours, curtain flavour consistency check
42845 kfin=kfl1
42846 kfqold=kf1a
42847 kfqpop=kf1a/10000
42848 IF(kf1a.GT.10)THEN
42849 kfin=-kfl1
42850 kfl1a=mod(kf1a/1000,10)
42851 kfl1b=mod(kf1a/100,10)
42852 IF(irank.EQ.0)THEN
42853 qawt=1d0
42854 IF(kfl1a.GE.3) qawt=parf(136+kfl1a/4)
42855 IF(kfl1b.GE.3) qawt=qawt/parf(136+kfl1b/4)
42856 kfqpop=kfl1a+(kfl1b-kfl1a)*int(1d0/(qawt+1d0)+pyr(0))
42857 ENDIF
42858 IF(kfqpop.NE.kfl1b.AND.kfqpop.NE.kfl1a) THEN
42859 mstu(121)=0
42860 RETURN
42861 ENDIF
42862 kfqold=kfl1a+kfl1b-kfqpop
42863 ENDIF
42864
42865C...Meson/baryon choice. Set number of mesons if starting a popcorn
42866C...system.
42867 110 mbary=0
42868 IF(kf1a.LE.10.AND.mstj(12).GT.0)THEN
42869 IF(mstu(121).EQ.-1.OR.(1d0+parj(1))*pyr(0).GT.1d0)THEN
42870 mbary=1
42871 CALL pynmes(0)
42872 ENDIF
42873 ELSEIF(kf1a.GT.10)THEN
42874 mbary=2
42875 IF(irank.EQ.0) CALL pynmes(kf1a)
42876 IF(mstu(121).GT.0) mbary=-1
42877 ENDIF
42878
42879C..x->H+q: Choose single vertex quark. Jump to form hadron.
42880 IF(mbary.EQ.0.OR.mbary.EQ.2)THEN
42881 kfqver=1+int((2d0+parj(2))*pyr(0))
42882 kfl3=isign(kfqver,-kfin)
42883 GOTO 130
42884 ENDIF
42885
42886C..x->H+qq: (IDW=proper PARF position for diquark weights)
42887 idw=160
42888 IF(mbary.EQ.1)THEN
42889 IF(mstu(121).EQ.0) idw=150
42890 sqwt=parf(idw+1)
42891 IF(mstu(121).GT.0) sqwt=sqwt*parf(135)*parf(138)**mstu(121)
42892 kfqpop=1+int((2d0+sqwt)*pyr(0))
42893C.. Shift to s-curtain parameters if needed
42894 IF(kfqpop.GE.3.AND.mstj(12).GE.5)THEN
42895 parf(194)=parf(138)*parf(139)
42896 parf(193)=parj(8)+parj(9)
42897 ENDIF
42898 ENDIF
42899
42900C.. x->H+qq: Get vertex quark
42901 IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
42902 idw=mstu(122)
42903 mstu(121)=mstu(121)-1
42904 IF(idw.EQ.170) THEN
42905 IF(mstu(121).EQ.0)THEN
42906 ipos=3*min(kfqpop-1,2)+min(kfqold-1,2)
42907 ELSE
42908 ipos=3*3+3*max(0,min(kfqpop-2,1))+min(kfqold-1,2)
42909 ENDIF
42910 ELSE
42911 IF(mstu(121).EQ.0)THEN
42912 ipos=3*5+5*min(kfqpop-1,3)+min(kfqold-1,4)
42913 ELSE
42914 ipos=3*5+5*4+min(kfqold-1,4)
42915 ENDIF
42916 ENDIF
42917 ipos=200+30*ipos+1
42918
42919 imes=-1
42920 rmes=pyr(0)*parf(194)
42921 120 imes=imes+1
42922 rmes=rmes-parf(ipos+imes)
42923 IF(imes.EQ.30) THEN
42924 mstu(121)=-1
42925 kf=-111
42926 RETURN
42927 ENDIF
42928 IF(rmes.GT.0d0) GOTO 120
42929 kmul=imes/5
42930 kfj=2*kmul+1
42931 IF(kmul.EQ.2) kfj=10003
42932 IF(kmul.EQ.3) kfj=10001
42933 IF(kmul.EQ.4) kfj=20003
42934 IF(kmul.EQ.5) kfj=5
42935 idiag=0
42936 kfqver=mod(imes,5)+1
42937 IF(kfqver.GE.kfqold) kfqver=kfqver+1
42938 IF(kfqver.GT.3)THEN
42939 idiag=kfqver-3
42940 kfqver=kfqold
42941 ENDIF
42942 ELSE
42943 IF(mbary.EQ.-1) idw=170
42944 sqwt=parf(idw+2)
42945 IF(kfqpop.EQ.3) sqwt=parf(idw+3)
42946 IF(kfqpop.GT.3) sqwt=parf(idw+3)*(1d0/parf(idw+5)+1d0)/2d0
42947 kfqver=min(3,1+int((2d0+sqwt)*pyr(0)))
42948 IF(kfqpop.LT.3.AND.kfqver.LT.3)THEN
42949 kfqver=kfqpop
42950 IF(pyr(0).GT.parf(idw+4)) kfqver=3-kfqpop
42951 ENDIF
42952 ENDIF
42953
42954C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
42955 kflds=3
42956 IF(kfqpop.NE.kfqver)THEN
42957 swt=parf(idw+7)
42958 IF(kfqver.EQ.3) swt=parf(idw+6)
42959 IF(kfqpop.GE.3) swt=parf(idw+5)
42960 IF((1d0+swt)*pyr(0).LT.1d0) kflds=1
42961 ENDIF
42962 kfdiq=900*max(kfqver,kfqpop)+100*(kfqver+kfqpop)+kflds
42963 & +10000*kfqpop
42964 kfl3=isign(kfdiq,kfin)
42965
42966C..x->M+y: flavour for meson.
42967 130 IF(mbary.LE.0)THEN
42968 kfla=max(kfqold,kfqver)
42969 kflb=min(kfqold,kfqver)
42970 kfs=isign(1,kfl1)
42971 IF(kfla.NE.kfqold) kfs=-kfs
42972C... Form meson, with spin and flavour mixing for diagonal states.
42973 IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
42974 IF(idiag.GT.0) kf=110*idiag+kfj
42975 IF(idiag.EQ.0) kf=(100*kfla+10*kflb+kfj)*kfs*(-1)**kfla
42976 RETURN
42977 ENDIF
42978 IF(kfla.LE.2) kmul=int(parj(11)+pyr(0))
42979 IF(kfla.EQ.3) kmul=int(parj(12)+pyr(0))
42980 IF(kfla.GE.4) kmul=int(parj(13)+pyr(0))
42981 IF(kmul.EQ.0.AND.parj(14).GT.0d0)THEN
42982 IF(pyr(0).LT.parj(14)) kmul=2
42983 ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0d0)THEN
42984 rmul=pyr(0)
42985 IF(rmul.LT.parj(15)) kmul=3
42986 IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
42987 IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
42988 ENDIF
42989 kfls=3
42990 IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
42991 IF(kmul.EQ.5) kfls=5
42992 IF(kfla.NE.kflb)THEN
42993 kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
42994 ELSE
42995 rmix=pyr(0)
42996 imix=2*kfla+10*kmul
42997 IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
42998 & int(rmix+parf(imix)))+kfls
42999 IF(kfla.GE.4) kf=110*kfla+kfls
43000 ENDIF
43001 IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
43002 IF(kmul.EQ.4) kf=kf+isign(20000,kf)
43003
43004C..Optional extra suppression of eta and eta'.
43005C..Allow shift to qq->B+q in old version (set IRANK to 0)
43006 IF(kf.EQ.221.OR.kf.EQ.331)THEN
43007 IF(pyr(0).GT.parj(25+kf/300))THEN
43008 IF(kf2a.GT.0) GOTO 130
43009 IF(mstj(12).LT.4) irank=0
43010 GOTO 110
43011 ENDIF
43012 ENDIF
43013 mstu(121)=0
43014
43015C.. x->B+y: Flavour for baryon
43016 ELSE
43017 kfla=kfqver
43018 IF(kf1a.LE.10) kfla=kfqold
43019 kflb=mod(kfdiq/1000,10)
43020 kflc=mod(kfdiq/100,10)
43021 kflds=mod(kfdiq,10)
43022 kfld=max(kfla,kflb,kflc)
43023 kflf=min(kfla,kflb,kflc)
43024 kfle=kfla+kflb+kflc-kfld-kflf
43025
43026C... SU(6) factors for formation of baryon.
43027 kbary=3
43028 kdmax=5
43029 kflg=kflb
43030 IF(kflb.NE.kflc)THEN
43031 kbary=2*kflds-1
43032 kdmax=1+kflds/2
43033 IF(kflb.GT.2) kdmax=kdmax+2
43034 ENDIF
43035 IF(kfla.NE.kflb.AND.kfla.NE.kflc)THEN
43036 kbary=kbary+1
43037 kflg=kfla
43038 ENDIF
43039
43040 su6max=parf(140+kdmax)
43041 su6dec=parj(18)
43042 su6s =parf(146)
43043 IF(mstj(12).GE.5.AND.irank.EQ.0) THEN
43044 su6max=1d0
43045 su6dec=1d0
43046 su6s =1d0
43047 ENDIF
43048 su6oct=parf(60+kbary)
43049 IF(kflg.GT.max(kfla+kflb-kflg,2))THEN
43050 su6oct=su6oct*4*su6s/(3*su6s+1)
43051 IF(kbary.EQ.2) su6oct=parf(60+kbary)*4/(3*su6s+1)
43052 ELSE
43053 IF(kbary.EQ.6) su6oct=su6oct*(3+su6s)/(3*su6s+1)
43054 ENDIF
43055 su6wt=su6oct+su6dec*parf(70+kbary)
43056
43057C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
43058 IF(su6wt.LT.pyr(0)*su6max.AND.kf2a.EQ.0)THEN
43059 mstu(121)=0
43060 IF(mstj(12).LE.2.AND.mbary.EQ.1) mstu(121)=-1
43061 GOTO 110
43062 ENDIF
43063
43064C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
43065 ksig=1
43066 kfls=2
43067 IF(su6wt*pyr(0).GT.su6oct) kfls=4
43068 IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf)THEN
43069 ksig=kflds/3
43070 IF(kfla.NE.kfld) ksig=int(3*su6s/(3*su6s+kflds**2)+pyr(0))
43071 ENDIF
43072 kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
43073 IF(ksig.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
43074 ENDIF
43075 RETURN
43076
43077C...Use tabulated probabilities to select new flavour and hadron.
43078 140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
43079 kt3l=1
43080 kt3u=6
43081 ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
43082 kt3l=1
43083 kt3u=6
43084 ELSEIF(ktab2.EQ.0) THEN
43085 kt3l=1
43086 kt3u=22
43087 ELSE
43088 kt3l=ktab2
43089 kt3u=ktab2
43090 ENDIF
43091 rfl=0d0
43092 DO 160 kts=0,2
43093 DO 150 kt3=kt3l,kt3u
43094 rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
43095 150 CONTINUE
43096 160 CONTINUE
43097 rfl=pyr(0)*rfl
43098 DO 180 kts=0,2
43099 ktabs=kts
43100 DO 170 kt3=kt3l,kt3u
43101 ktab3=kt3
43102 rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
43103 IF(rfl.LE.0d0) GOTO 190
43104 170 CONTINUE
43105 180 CONTINUE
43106 190 CONTINUE
43107
43108C...Reconstruct flavour of produced quark/diquark.
43109 IF(ktab3.LE.6) THEN
43110 kfl3a=ktab3
43111 kfl3b=0
43112 kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
43113 ELSE
43114 kfl3a=1
43115 IF(ktab3.GE.8) kfl3a=2
43116 IF(ktab3.GE.11) kfl3a=3
43117 IF(ktab3.GE.16) kfl3a=4
43118 kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
43119 kfl3=1000*kfl3a+100*kfl3b+1
43120 IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
43121 & kfl3+2
43122 kfl3=isign(kfl3,kfl1*(13-2*ktab1))
43123 ENDIF
43124
43125C...Reconstruct meson code.
43126 IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
43127 &kfl3b.NE.0)) THEN
43128 rfl=pyr(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
43129 & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
43130 kf=110+2*ktabs+1
43131 IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
43132 IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
43133 & 25*ktabs)) kf=330+2*ktabs+1
43134 ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
43135 kfla=max(ktab1,ktab3)
43136 kflb=min(ktab1,ktab3)
43137 kfs=isign(1,kfl1)
43138 IF(kfla.NE.kf1a) kfs=-kfs
43139 kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
43140 ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
43141 kfs=isign(1,kfl1)
43142 IF(kfl1a.EQ.kfl3a) THEN
43143 kfla=max(kfl1b,kfl3b)
43144 kflb=min(kfl1b,kfl3b)
43145 IF(kfla.NE.kfl1b) kfs=-kfs
43146 ELSEIF(kfl1a.EQ.kfl3b) THEN
43147 kfla=kfl3a
43148 kflb=kfl1b
43149 kfs=-kfs
43150 ELSEIF(kfl1b.EQ.kfl3a) THEN
43151 kfla=kfl1a
43152 kflb=kfl3b
43153 ELSEIF(kfl1b.EQ.kfl3b) THEN
43154 kfla=max(kfl1a,kfl3a)
43155 kflb=min(kfl1a,kfl3a)
43156 IF(kfla.NE.kfl1a) kfs=-kfs
43157 ELSE
43158 CALL pyerrm(2,'(PYKFDI:) no matching flavours for qq -> qq')
43159 GOTO 100
43160 ENDIF
43161 kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
43162
43163C...Reconstruct baryon code.
43164 ELSE
43165 IF(ktab1.GE.7) THEN
43166 kfla=kfl3a
43167 kflb=kfl1a
43168 kflc=kfl1b
43169 ELSE
43170 kfla=kfl1a
43171 kflb=kfl3a
43172 kflc=kfl3b
43173 ENDIF
43174 kfld=max(kfla,kflb,kflc)
43175 kflf=min(kfla,kflb,kflc)
43176 kfle=kfla+kflb+kflc-kfld-kflf
43177 IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
43178 IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
43179 ENDIF
43180
43181C...Check that constructed flavour code is an allowed one.
43182 IF(kfl2.NE.0) kfl3=0
43183 kc=pycomp(kf)
43184 IF(kc.EQ.0) THEN
43185 CALL pyerrm(2,'(PYKFDI:) user-defined flavour probabilities '//
43186 & 'failed')
43187 GOTO 100
43188 ENDIF
43189
43190 RETURN
43191 END
43192
43193C*********************************************************************
43194
43195C...PYNMES
43196C...Generates number of popcorn mesons and stores some relevant
43197C...parameters.
43198
43199 SUBROUTINE pynmes(KFDIQ)
43200
43201C...Double precision and integer declarations.
43202 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43203 IMPLICIT INTEGER(I-N)
43204 INTEGER PYK,PYCHGE,PYCOMP
43205C...Commonblocks.
43206 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43207 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43208 SAVE /pydat1/,/pydat2/
43209
43210 mstu(121)=0
43211 IF(mstj(12).LT.2) RETURN
43212
43213C..Old version: Get 1 or 0 popcorn mesons
43214 IF(mstj(12).LT.5)THEN
43215 popwt=parf(131)
43216 IF(kfdiq.NE.0) THEN
43217 kfdiqa=iabs(kfdiq)
43218 kfa=mod(kfdiqa/1000,10)
43219 kfb=mod(kfdiqa/100,10)
43220 kfs=mod(kfdiqa,10)
43221 popwt=parf(132)
43222 IF(kfa.EQ.3) popwt=parf(133)
43223 IF(kfb.EQ.3) popwt=parf(134)
43224 IF(kfs.EQ.1) popwt=popwt*sqrt(parj(4))
43225 ENDIF
43226 mstu(121)=int(popwt/(1d0+popwt)+pyr(0))
43227 RETURN
43228 ENDIF
43229
43230C..New version: Store popcorn- or rank 0 diquark parameters
43231 mstu(122)=170
43232 parf(193)=parj(8)
43233 parf(194)=parf(139)
43234 IF(kfdiq.NE.0) THEN
43235 mstu(122)=180
43236 parf(193)=parj(10)
43237 parf(194)=parf(140)
43238 ENDIF
43239 IF(parf(194).LT.1d-5.OR.parf(194).GT.1d0-1d-5) THEN
43240 IF(parf(194).GT.1d0-1d-5) CALL pyerrm(9,
43241 & '(PYNMES:) Neglecting too large popcorn possibility')
43242 RETURN
43243 ENDIF
43244
43245C..New version: Get number of popcorn mesons
43246 100 rtst=pyr(0)
43247 mstu(121)=-1
43248 110 mstu(121)=mstu(121)+1
43249 rtst=rtst/parf(194)
43250 IF(rtst.LT.1d0) GOTO 110
43251 IF(kfdiq.EQ.0.AND.pyr(0)*(2d0+parf(135)*parf(161)).GT.
43252 & (2d0+parf(135)*parf(161)*parf(138)**mstu(121))) GOTO 100
43253 RETURN
43254 END
43255
43256C***************************************************************
43257
43258C...PYKFIN
43259C...Precalculates a set of diquark and popcorn weights.
43260
43261 SUBROUTINE pykfin
43262
43263C...Double precision and integer declarations.
43264 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43265 IMPLICIT INTEGER(I-N)
43266 INTEGER PYK,PYCHGE,PYCOMP
43267C...Commonblocks.
43268 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43269 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43270 SAVE /pydat1/,/pydat2/
43271
43272 dimension su6(12),su6m(7),qbb(7),qbm(7),dmb(14)
43273
43274
43275 mstu(123)=1
43276C..Diquark indices for dimensional variables
43277 iud1=1
43278 iuu1=2
43279 ius0=3
43280 isu0=4
43281 ius1=5
43282 isu1=6
43283 iss1=7
43284
43285C.. *** SU(6) factors **
43286C..Modify with decuplet- (and Sigma/Lambda-) suppression.
43287 parf(146)=1d0
43288 IF(mstj(12).GE.5) parf(146)=3d0*parj(18)/(2d0*parj(18)+1d0)
43289 IF(parj(18).LT.1d0-1d-5.AND.mstj(12).LT.5) CALL pyerrm(9,
43290 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
43291 DO 100 i=1,6
43292 su6(i)=parf(60+i)
43293 su6(6+i)=su6(i)*4*parf(146)/(3*parf(146)+1)
43294 100 CONTINUE
43295 su6(8)=su6(2)*4/(3*parf(146)+1)
43296 su6(6)=su6(6)*(3+parf(146))/(3*parf(146)+1)
43297 DO 110 i=1,6
43298 su6(i)=su6(i)+parj(18)*parf(70+i)
43299 su6(6+i)=su6(6+i)+parj(18)*parf(70+i)
43300 110 CONTINUE
43301
43302C..SU(6)max q q' s,c,b
43303 su6mud =max(su6(1) , su6(8) )
43304 su6m(iud1)=max(su6(5) , su6(12))
43305 su6m(isu0)=max(su6(7) ,su6(2),su6mud )
43306 su6m(iuu1)=max(su6(3) ,su6(4),su6(10))
43307 su6m(isu1)=max(su6(11),su6(6),su6m(iud1))
43308 su6m(ius0)=su6m(isu0)
43309 su6m(iss1)=su6m(iuu1)
43310 su6m(ius1)=su6m(isu1)
43311
43312C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
43313 parf(141)=su6mud
43314 parf(142)=su6m(iud1)
43315 parf(143)=su6m(isu0)
43316 parf(144)=su6m(isu1)
43317 parf(145)=su6m(iss1)
43318
43319C..diquark SU(6) survival =
43320C..sum over quark (quark tunnel weight)*(SU(6)).
43321 pud0=(2d0*su6(1)+parj(2)*su6(8))
43322 dmb(isu0)=(su6(7)+su6(2)+parj(2)*su6(1))/pud0
43323 dmb(ius0)=dmb(isu0)
43324 dmb(iss1)=(2d0*su6(4)+parj(2)*su6(3))/pud0
43325 dmb(iuu1)=(su6(3)+su6(4)+parj(2)*su6(10))/pud0
43326 dmb(isu1)=(su6(11)+su6(6)+parj(2)*su6(5))/pud0
43327 dmb(ius1)=dmb(isu1)
43328 dmb(iud1)=(2d0*su6(5)+parj(2)*su6(12))/pud0
43329
43330C.. *** Tunneling factors for Diquark production***
43331C.. T: half a curtain pair = sqrt(curtain pair factor)
43332 IF(mstj(12).GE.5) THEN
43333 pmud0=pymass(2101)
43334 pmud1=pymass(2103)-pmud0
43335 pmus0=pymass(3201)-pmud0
43336 pmus1=pymass(3203)-pmus0-pmud0
43337 pmss1=pymass(3303)-pmus0-pmud0
43338 qbb(isu0)=exp(-(parj(9)+parj(8))*pmus0-parj(9)*parf(191))
43339 qbb(ius0)=exp(-parj(8)*pmus0)
43340 qbb(iss1)=exp(-(parj(9)+parj(8))*pmss1)*qbb(isu0)
43341 qbb(iuu1)=exp(-parj(8)*pmud1)
43342 qbb(isu1)=exp(-(parj(9)+parj(8))*pmus1)*qbb(isu0)
43343 qbb(ius1)=exp(-parj(8)*pmus1)*qbb(ius0)
43344 qbb(iud1)=qbb(iuu1)
43345 ELSE
43346 par2m=sqrt(parj(2))
43347 par3m=sqrt(parj(3))
43348 par4m=sqrt(parj(4))
43349 qbb(isu0)=par2m*par3m
43350 qbb(ius0)=par3m
43351 qbb(iss1)=par2m*parj(3)*par4m
43352 qbb(iuu1)=par4m
43353 qbb(isu1)=par4m*qbb(isu0)
43354 qbb(ius1)=par4m*qbb(ius0)
43355 qbb(iud1)=par4m
43356 ENDIF
43357
43358C.. tau: spin*(vertex factor)*(T = half-curtain factor)
43359 qbm(isu0)=qbb(isu0)
43360 qbm(ius0)=parj(2)*qbb(ius0)
43361 qbm(iss1)=parj(2)*6d0*qbb(iss1)
43362 qbm(iuu1)=6d0*qbb(iuu1)
43363 qbm(isu1)=3d0*qbb(isu1)
43364 qbm(ius1)=parj(2)*3d0*qbb(ius1)
43365 qbm(iud1)=3d0*qbb(iud1)
43366
43367C.. Combine T and tau to diquark weight for q-> B+B+..
43368 DO 120 i=1,7
43369 qbb(i)=qbb(i)*qbm(i)
43370 120 CONTINUE
43371
43372 IF(mstj(12).GE.5)THEN
43373C..New version: tau for rank 0 diquark.
43374 dmb(7+isu0)=exp(-parj(10)*pmus0)
43375 dmb(7+ius0)=parj(2)*dmb(7+isu0)
43376 dmb(7+iss1)=6d0*parj(2)*exp(-parj(10)*pmss1)*dmb(7+isu0)
43377 dmb(7+iuu1)=6d0*exp(-parj(10)*pmud1)
43378 dmb(7+isu1)=3d0*exp(-parj(10)*pmus1)*dmb(7+isu0)
43379 dmb(7+ius1)=parj(2)*dmb(7+isu1)
43380 dmb(7+iud1)=dmb(7+iuu1)/2d0
43381
43382C..New version: curtain flavour ratios.
43383C.. s/u for q->B+M+...
43384C.. s/u for rank 0 diquark: su -> ...M+B+...
43385C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
43386 wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
43387 parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
43388 wu=1d0+dmb(7+iud1)+dmb(7+ius0)+dmb(7+ius1)+dmb(7+iuu1)
43389 parf(136)=(2d0*(dmb(7+isu0)+dmb(7+isu1))+dmb(7+iss1))/wu
43390 parf(137)=(dmb(7+isu0)+dmb(7+isu1))*
43391 & (2d0+dmb(7+iss1)/(2d0*dmb(7+isu1)))/wu
43392 ELSE
43393C..Old version: reset unused rank 0 diquark weights and
43394C.. unused diquark SU(6) survival weights
43395 DO 130 i=1,7
43396 IF(mstj(12).LT.3) dmb(i)=1d0
43397 dmb(7+i)=1d0
43398 130 CONTINUE
43399
43400C..Old version: Shuffle PARJ(7) into tau
43401 qbm(ius0)=qbm(ius0)*parj(7)
43402 qbm(iss1)=qbm(iss1)*parj(7)
43403 qbm(ius1)=qbm(ius1)*parj(7)
43404
43405C..Old version: curtain flavour ratios.
43406C.. s/u for q->B+M+...
43407C.. s/u for rank 0 diquark: su -> ...M+B+...
43408C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
43409 wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
43410 parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
43411 parf(136)=parf(135)*parj(6)*qbm(isu0)/qbm(ius0)
43412 parf(137)=(1d0+qbm(iud1))*(2d0+qbm(ius0))/wu
43413 ENDIF
43414
43415C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
43416C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
43417 DO 140 i=1,7
43418 dmb(7+i)=dmb(7+i)*dmb(i)
43419 dmb(i)=dmb(i)*qbm(i)
43420 qbm(i)=qbm(i)*su6m(i)/su6mud
43421 qbb(i)=qbb(i)*su6m(i)/su6mud
43422 140 CONTINUE
43423
43424C.. *** Popcorn factors ***
43425
43426 IF(mstj(12).LT.5)THEN
43427C.. Old version: Resulting popcorn weights.
43428 parf(138)=parj(6)
43429 ws=parf(135)*parf(138)
43430 wq=wu*parj(5)/3d0
43431 parf(132)=wq*qbm(iud1)/qbb(iud1)
43432 parf(133)=wq*
43433 & (qbm(ius1)/qbb(ius1)+ws*qbm(isu1)/qbb(isu1))/2d0
43434 parf(134)=wq*ws*qbm(iss1)/qbb(iss1)
43435 parf(131)=wq*(1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1)+
43436 & ws*(qbm(isu0)+qbm(isu1)+qbm(iss1)/2d0))/
43437 & (1d0+qbb(iud1)+qbb(iuu1)+
43438 & 2d0*(qbb(ius0)+qbb(ius1))+qbb(iss1)/2d0)
43439 ELSE
43440C..New version: Store weights for popcorn mesons,
43441C..get prel. popcorn weights.
43442 DO 150 ipos=201,1400
43443 parf(ipos)=0d0
43444 150 CONTINUE
43445 DO 160 i=138,140
43446 parf(i)=0d0
43447 160 CONTINUE
43448 ipos=200
43449 parf(193)=parj(8)
43450 DO 240 mr=0,7,7
43451 IF(mr.EQ.7) parf(193)=parj(10)
43452 sqwt=2d0*(dmb(mr+ius0)+dmb(mr+ius1))/
43453 & (1d0+dmb(mr+iud1)+dmb(mr+iuu1))
43454 qqwt=dmb(mr+iuu1)/(1d0+dmb(mr+iud1)+dmb(mr+iuu1))
43455 DO 230 nmes=0,1
43456 IF(nmes.EQ.1) sqwt=parj(2)
43457 DO 220 kfqpop=1,4
43458 IF(mr.EQ.0.AND.kfqpop.GT.3) GOTO 220
43459 IF(nmes.EQ.0.AND.kfqpop.GE.3)THEN
43460 sqwt=dmb(mr+iss1)/(dmb(mr+isu0)+dmb(mr+isu1))
43461 qqwt=0.5d0
43462 IF(mr.EQ.0) parf(193)=parj(8)+parj(9)
43463 IF(kfqpop.EQ.4) sqwt=sqwt*(1d0/dmb(7+isu1)+1d0)/2d0
43464 ENDIF
43465 DO 210 kfqold =1,5
43466 IF(mr.EQ.0.AND.kfqold.GT.3) GOTO 210
43467 IF(nmes.EQ.1) THEN
43468 IF(mr.EQ.0.AND.kfqpop.EQ.1) GOTO 210
43469 IF(mr.EQ.7.AND.kfqpop.NE.1) GOTO 210
43470 ENDIF
43471 wttot=0d0
43472 wtfail=0d0
43473 DO 190 kmul=0,5
43474 pjwt=parj(12+kmul)
43475 IF(kmul.EQ.0) pjwt=1d0-parj(14)
43476 IF(kmul.EQ.1) pjwt=1d0-parj(15)-parj(16)-parj(17)
43477 IF(pjwt.LE.0d0) GOTO 190
43478 IF(pjwt.GT.1d0) pjwt=1d0
43479 imes=5*kmul
43480 imix=2*kfqold+10*kmul
43481 kfj=2*kmul+1
43482 IF(kmul.EQ.2) kfj=10003
43483 IF(kmul.EQ.3) kfj=10001
43484 IF(kmul.EQ.4) kfj=20003
43485 IF(kmul.EQ.5) kfj=5
43486 DO 180 kfqver =1,3
43487 kfla=max(kfqold,kfqver)
43488 kflb=min(kfqold,kfqver)
43489 swt=parj(11+kfla/3+kfla/4)
43490 IF(kmul.EQ.0.OR.kmul.EQ.2) swt=1d0-swt
43491 swt=swt*pjwt
43492 qwt=sqwt/(2d0+sqwt)
43493 IF(kfqver.LT.3)THEN
43494 IF(kfqver.EQ.kfqpop) qwt=(1d0-qwt)*qqwt
43495 IF(kfqver.NE.kfqpop) qwt=(1d0-qwt)*(1d0-qqwt)
43496 ENDIF
43497 IF(kfqver.NE.kfqold)THEN
43498 imes=imes+1
43499 kfm=100*kfla+10*kflb+kfj
43500 pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
43501 parf(ipos+imes)=qwt*swt*exp(-parf(193)*pmm)
43502 wttot=wttot+parf(ipos+imes)
43503 ELSE
43504 DO 170 id=3,5
43505 IF(id.EQ.3) dwt=1d0-parf(imix-1)
43506 IF(id.EQ.4) dwt=parf(imix-1)-parf(imix)
43507 IF(id.EQ.5) dwt=parf(imix)
43508 kfm=110*(id-2)+kfj
43509 pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
43510 parf(ipos+5*kmul+id)=qwt*swt*dwt*exp(-parf(193)*pmm)
43511 IF(kmul.EQ.0.AND.id.GT.3) THEN
43512 wtfail=wtfail+qwt*swt*dwt*(1d0-parj(21+id))
43513 parf(ipos+5*kmul+id)=
43514 & parf(ipos+5*kmul+id)*parj(21+id)
43515 ENDIF
43516 wttot=wttot+parf(ipos+5*kmul+id)
43517 170 CONTINUE
43518 ENDIF
43519 180 CONTINUE
43520 190 CONTINUE
43521 DO 200 imes=1,30
43522 parf(ipos+imes)=parf(ipos+imes)/(1d0-wtfail)
43523 200 CONTINUE
43524 IF(mr.EQ.7) parf(140)=
43525 & max(parf(140),wttot/(1d0-wtfail))
43526 IF(mr.EQ.0) parf(139-kfqpop/3)=
43527 & max(parf(139-kfqpop/3),wttot/(1d0-wtfail))
43528 ipos=ipos+30
43529 210 CONTINUE
43530 220 CONTINUE
43531 230 CONTINUE
43532 240 CONTINUE
43533 IF(parf(139).GT.1d-10) parf(138)=parf(138)/parf(139)
43534 mstu(121)=0
43535
43536 ENDIF
43537
43538C..Recombine diquark weights to flavour and spin ratios
43539 parf(151)=(2d0*(qbb(isu0)+qbb(isu1))+qbb(iss1))/
43540 & (1d0+qbb(iud1)+qbb(iuu1)+qbb(ius0)+qbb(ius1))
43541 parf(152)=2d0*(qbb(ius0)+qbb(ius1))/(1d0+qbb(iud1)+qbb(iuu1))
43542 parf(153)=qbb(iss1)/(qbb(isu0)+qbb(isu1))
43543 parf(154)=qbb(iuu1)/(1d0+qbb(iud1)+qbb(iuu1))
43544 parf(155)=qbb(isu1)/qbb(isu0)
43545 parf(156)=qbb(ius1)/qbb(ius0)
43546 parf(157)=qbb(iud1)
43547
43548 parf(161)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/
43549 & (1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1))
43550 parf(162)=2d0*(qbm(ius0)+qbm(ius1))/(1d0+qbm(iud1)+qbm(iuu1))
43551 parf(163)=qbm(iss1)/(qbm(isu0)+qbm(isu1))
43552 parf(164)=qbm(iuu1)/(1d0+qbm(iud1)+qbm(iuu1))
43553 parf(165)=qbm(isu1)/qbm(isu0)
43554 parf(166)=qbm(ius1)/qbm(ius0)
43555 parf(167)=qbm(iud1)
43556
43557 parf(171)=(2d0*(dmb(isu0)+dmb(isu1))+dmb(iss1))/
43558 & (1d0+dmb(iud1)+dmb(iuu1)+dmb(ius0)+dmb(ius1))
43559 parf(172)=2d0*(dmb(ius0)+dmb(ius1))/(1d0+dmb(iud1)+dmb(iuu1))
43560 parf(173)=dmb(iss1)/(dmb(isu0)+dmb(isu1))
43561 parf(174)=dmb(iuu1)/(1d0+dmb(iud1)+dmb(iuu1))
43562 parf(175)=dmb(isu1)/dmb(isu0)
43563 parf(176)=dmb(ius1)/dmb(ius0)
43564 parf(177)=dmb(iud1)
43565
43566 parf(185)=dmb(7+isu1)/dmb(7+isu0)
43567 parf(186)=dmb(7+ius1)/dmb(7+ius0)
43568 parf(187)=dmb(7+iud1)
43569
43570 RETURN
43571 END
43572
43573
43574C*********************************************************************
43575
43576C...PYPTDI
43577C...Generates transverse momentum according to a Gaussian.
43578
43579 SUBROUTINE pyptdi(KFL,PX,PY)
43580
43581C...Double precision and integer declarations.
43582 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43583 IMPLICIT INTEGER(I-N)
43584 INTEGER PYK,PYCHGE,PYCOMP
43585C...Commonblocks.
43586 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43587 SAVE /pydat1/
43588
43589C...Generate p_T and azimuthal angle, gives p_x and p_y.
43590 kfla=iabs(kfl)
43591 pt=parj(21)*sqrt(-log(max(1d-10,pyr(0))))
43592 IF(parj(23).GT.pyr(0)) pt=parj(24)*pt
43593 IF(mstj(91).EQ.1) pt=parj(22)*pt
43594 IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0d0
43595 phi=paru(2)*pyr(0)
43596 px=pt*cos(phi)
43597 py=pt*sin(phi)
43598
43599 RETURN
43600 END
43601
43602C*********************************************************************
43603
43604C...PYZDIS
43605C...Generates the longitudinal splitting variable z.
43606
43607 SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)
43608
43609C...Double precision and integer declarations.
43610 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43611 IMPLICIT INTEGER(I-N)
43612 INTEGER PYK,PYCHGE,PYCOMP
43613C...Commonblocks.
43614 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43615 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43616 SAVE /pydat1/,/pydat2/
43617
43618C...Check if heavy flavour fragmentation.
43619 kfla=iabs(kfl1)
43620 kflb=iabs(kfl2)
43621 kflh=kfla
43622 IF(kfla.GE.10) kflh=mod(kfla/1000,10)
43623
43624C...Lund symmetric scaling function: determine parameters of shape.
43625 IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
43626 &mstj(11).GE.4) THEN
43627 fa=parj(41)
43628 IF(mstj(91).EQ.1) fa=parj(43)
43629 IF(kflb.GE.10) fa=fa+parj(45)
43630 fbb=parj(42)
43631 IF(mstj(91).EQ.1) fbb=parj(44)
43632 fb=fbb*pr
43633 fc=1d0
43634 IF(kfla.GE.10) fc=fc-parj(45)
43635 IF(kflb.GE.10) fc=fc+parj(45)
43636 IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN
43637 fred=parj(46)
43638 IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
43639 fc=fc+fred*fbb*parf(100+kflh)**2
43640 ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN
43641 fred=parj(46)
43642 IF(mstj(11).EQ.5) fred=parj(48)
43643 fc=fc+fred*fbb*pmas(kflh,1)**2
43644 ENDIF
43645 mc=1
43646 IF(abs(fc-1d0).GT.0.01d0) mc=2
43647
43648C...Determine position of maximum. Special cases for a = 0 or a = c.
43649 IF(fa.LT.0.02d0) THEN
43650 ma=1
43651 zmax=1d0
43652 IF(fc.GT.fb) zmax=fb/fc
43653 ELSEIF(abs(fc-fa).LT.0.01d0) THEN
43654 ma=2
43655 zmax=fb/(fb+fc)
43656 ELSE
43657 ma=3
43658 zmax=0.5d0*(fb+fc-sqrt((fb-fc)**2+4d0*fa*fb))/(fc-fa)
43659 IF(zmax.GT.0.9999d0.AND.fb.GT.100d0) zmax=min(zmax,1d0-fa/fb)
43660 ENDIF
43661
43662C...Subdivide z range if distribution very peaked near endpoint.
43663 mmax=2
43664 IF(zmax.LT.0.1d0) THEN
43665 mmax=1
43666 zdiv=2.75d0*zmax
43667 IF(mc.EQ.1) THEN
43668 fint=1d0-log(zdiv)
43669 ELSE
43670 zdivc=zdiv**(1d0-fc)
43671 fint=1d0+(1d0-1d0/zdivc)/(fc-1d0)
43672 ENDIF
43673 ELSEIF(zmax.GT.0.85d0.AND.fb.GT.1d0) THEN
43674 mmax=3
43675 fscb=sqrt(4d0+(fc/fb)**2)
43676 zdiv=fscb-1d0/zmax-(fc/fb)*log(zmax*0.5d0*(fscb+fc/fb))
43677 IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1d0-zmax)
43678 zdiv=min(zmax,max(0d0,zdiv))
43679 fint=1d0+fb*(1d0-zdiv)
43680 ENDIF
43681
43682C...Choice of z, preweighted for peaks at low or high z.
43683 100 z=pyr(0)
43684 fpre=1d0
43685 IF(mmax.EQ.1) THEN
43686 IF(fint*pyr(0).LE.1d0) THEN
43687 z=zdiv*z
43688 ELSEIF(mc.EQ.1) THEN
43689 z=zdiv**z
43690 fpre=zdiv/z
43691 ELSE
43692 z=(zdivc+z*(1d0-zdivc))**(1d0/(1d0-fc))
43693 fpre=(zdiv/z)**fc
43694 ENDIF
43695 ELSEIF(mmax.EQ.3) THEN
43696 IF(fint*pyr(0).LE.1d0) THEN
43697 z=zdiv+log(z)/fb
43698 fpre=exp(fb*(z-zdiv))
43699 ELSE
43700 z=zdiv+z*(1d0-zdiv)
43701 ENDIF
43702 ENDIF
43703
43704C...Weighting according to correct formula.
43705 IF(z.LE.0d0.OR.z.GE.1d0) GOTO 100
43706 fexp=fc*log(zmax/z)+fb*(1d0/zmax-1d0/z)
43707 IF(ma.GE.2) fexp=fexp+fa*log((1d0-z)/(1d0-zmax))
43708 fval=exp(max(-50d0,min(50d0,fexp)))
43709 IF(fval.LT.pyr(0)*fpre) GOTO 100
43710
43711C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
43712 ELSE
43713 fc=parj(50+max(1,kflh))
43714 IF(mstj(91).EQ.1) fc=parj(59)
43715 110 z=pyr(0)
43716 IF(fc.GE.0d0.AND.fc.LE.1d0) THEN
43717 IF(fc.GT.pyr(0)) z=1d0-z**(1d0/3d0)
43718 ELSEIF(fc.GT.-1.AND.fc.LT.0d0) THEN
43719 IF(-4d0*fc*z*(1d0-z)**2.LT.pyr(0)*((1d0-z)**2-fc*z)**2)
43720 & GOTO 110
43721 ELSE
43722 IF(fc.GT.0d0) z=1d0-z**(1d0/fc)
43723 IF(fc.LT.0d0) z=z**(-1d0/fc)
43724 ENDIF
43725 ENDIF
43726
43727 RETURN
43728 END
43729
43730C*********************************************************************
43731
43732C...PYSHOW
43733C...Generates timelike parton showers from given partons.
43734
43735 SUBROUTINE pyshow(IP1,IP2,QMAX)
43736
43737C...Double precision and integer declarations.
43738 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43739 IMPLICIT INTEGER(I-N)
43740 INTEGER PYK,PYCHGE,PYCOMP
43741C...Commonblocks.
43742 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
43743 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43744 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43745 SAVE /pyjets/,/pydat1/,/pydat2/
43746C...Local arrays.
43747 dimension pmth(5,50),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
43748 &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),
43749 &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),
43750 &isii(2),isset(3)
43751
43752C...Check that QMAX not too low.
43753 IF(mstj(41).LE.0) THEN
43754 RETURN
43755 ELSEIF(mstj(41).EQ.1) THEN
43756 IF(qmax.LE.parj(82).AND.ip2.GT.-5) RETURN
43757 ELSE
43758 IF(qmax.LE.min(parj(82),parj(83),parj(90)).AND.ip2.GT.-5)
43759 & RETURN
43760 ENDIF
43761
43762C...Initialization of cutoff masses etc.
43763 DO 100 ifl=0,40
43764 ksh(ifl)=0
43765 100 CONTINUE
43766 ksh(21)=1
43767 pmth(1,21)=pymass(21)
43768 pmth(2,21)=sqrt(pmth(1,21)**2+0.25d0*parj(82)**2)
43769 pmth(3,21)=2d0*pmth(2,21)
43770 pmth(4,21)=pmth(3,21)
43771 pmth(5,21)=pmth(3,21)
43772 pmth(1,22)=pymass(22)
43773 pmth(2,22)=sqrt(pmth(1,22)**2+0.25d0*parj(83)**2)
43774 pmth(3,22)=2d0*pmth(2,22)
43775 pmth(4,22)=pmth(3,22)
43776 pmth(5,22)=pmth(3,22)
43777 pmqth1=parj(82)
43778 IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
43779 pmqt1e=min(pmqth1,parj(90))
43780 pmqth2=pmth(2,21)
43781 IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
43782 pmqt2e=min(pmqth2,0.5d0*parj(90))
43783 DO 110 ifl=1,8
43784 ksh(ifl)=1
43785 pmth(1,ifl)=pymass(ifl)
43786 pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*pmqth1**2)
43787 pmth(3,ifl)=pmth(2,ifl)+pmqth2
43788 pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(82)**2)+pmth(2,21)
43789 pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)+pmth(2,22)
43790 110 CONTINUE
43791 DO 120 ifl=11,17,2
43792 IF(mstj(41).GE.2) ksh(ifl)=1
43793 pmth(1,ifl)=pymass(ifl)
43794 pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(90)**2)
43795 pmth(3,ifl)=pmth(2,ifl)+0.5d0*parj(90)
43796 pmth(4,ifl)=pmth(3,ifl)
43797 pmth(5,ifl)=pmth(3,ifl)
43798 120 CONTINUE
43799 pt2min=max(0.5d0*parj(82),1.1d0*parj(81))**2
43800 alams=parj(81)**2
43801 alfm=log(pt2min/alams)
43802
43803C...Store positions of shower initiating partons.
43804 mpspd=0
43805 IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
43806 npa=1
43807 ipa(1)=ip1
43808 ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
43809 & mstu(32))) THEN
43810 npa=2
43811 ipa(1)=ip1
43812 ipa(2)=ip2
43813 ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
43814 & .AND.ip2.GE.-3) THEN
43815 npa=iabs(ip2)
43816 DO 130 i=1,npa
43817 ipa(i)=ip1+i-1
43818 130 CONTINUE
43819 ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.
43820 &ip2.EQ.-8) THEN
43821 mpspd=1
43822 npa=2
43823 ipa(1)=ip1+6
43824 ipa(2)=ip1+7
43825 ELSE
43826 CALL pyerrm(12,
43827 & '(PYSHOW:) failed to reconstruct showering system')
43828 IF(mstu(21).GE.1) RETURN
43829 ENDIF
43830
43831C...Check on phase space available for emission.
43832 irej=0
43833 DO 140 j=1,5
43834 ps(j)=0d0
43835 140 CONTINUE
43836 pm=0d0
43837 DO 160 i=1,npa
43838 kfla(i)=iabs(k(ipa(i),2))
43839 pma(i)=p(ipa(i),5)
43840C...Special cutoff masses for t, l, h with variable masses.
43841 ifla=kfla(i)
43842 IF(kfla(i).GE.6.AND.kfla(i).LE.8) THEN
43843 ifla=37+kfla(i)+isign(2,k(ipa(i),2))
43844 pmth(1,ifla)=pma(i)
43845 pmth(2,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*pmqth1**2)
43846 pmth(3,ifla)=pmth(2,ifla)+pmqth2
43847 pmth(4,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*parj(82)**2)+
43848 & pmth(2,21)
43849 pmth(5,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*parj(83)**2)+
43850 & pmth(2,22)
43851 ENDIF
43852 IF(kfla(i).LE.40) THEN
43853 IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,ifla)
43854 ENDIF
43855 pm=pm+pma(i)
43856 IF(kfla(i).GT.40) THEN
43857 irej=irej+1
43858 ELSE
43859 IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1
43860 ENDIF
43861 DO 150 j=1,4
43862 ps(j)=ps(j)+p(ipa(i),j)
43863 150 CONTINUE
43864 160 CONTINUE
43865 IF(irej.EQ.npa.AND.ip2.GT.-5) RETURN
43866 ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
43867 IF(npa.EQ.1) ps(5)=ps(4)
43868 IF(ps(5).LE.pm+pmqt1e) RETURN
43869
43870C...Check if 3-jet matrix elements to be used.
43871 m3jc=0
43872 IF(npa.EQ.2.AND.mstj(47).GE.1.AND.mpspd.EQ.0) THEN
43873 IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
43874 & kfla(2).LE.8) m3jc=1
43875 IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
43876 & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1
43877 IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
43878 & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1
43879 IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.
43880 & kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1
43881 IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1
43882 m3jcm=0
43883 IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN
43884 m3jcm=1
43885 pqmes=pmth(1,kfla(1))**2
43886 qme=4d0*pqmes/ps(5)**2
43887 rescz=min(1d0,log(pmth(2,kfla(1))/ps(5))/
43888 & log(pmth(2,21)/ps(5)))
43889 ENDIF
43890 ENDIF
43891
43892C...Find if interference with initial state partons.
43893 miis=0
43894 IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2.AND.mpspd.EQ.0)
43895 &miis=mstj(50)
43896 IF(miis.NE.0) THEN
43897 DO 180 i=1,2
43898 kcii(i)=0
43899 kca=pycomp(kfla(i))
43900 IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
43901 niis(i)=0
43902 IF(kcii(i).NE.0) THEN
43903 DO 170 j=1,2
43904 icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
43905 IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
43906 & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
43907 niis(i)=niis(i)+1
43908 iiis(i,niis(i))=icsi
43909 ENDIF
43910 170 CONTINUE
43911 ENDIF
43912 180 CONTINUE
43913 IF(niis(1)+niis(2).EQ.0) miis=0
43914 ENDIF
43915
43916C...Boost interfering initial partons to rest frame
43917C...and reconstruct their polar and azimuthal angles.
43918 IF(miis.NE.0) THEN
43919 DO 200 i=1,2
43920 DO 190 j=1,5
43921 k(n+i,j)=k(ipa(i),j)
43922 p(n+i,j)=p(ipa(i),j)
43923 v(n+i,j)=0d0
43924 190 CONTINUE
43925 200 CONTINUE
43926 DO 220 i=3,2+niis(1)
43927 DO 210 j=1,5
43928 k(n+i,j)=k(iiis(1,i-2),j)
43929 p(n+i,j)=p(iiis(1,i-2),j)
43930 v(n+i,j)=0d0
43931 210 CONTINUE
43932 220 CONTINUE
43933 DO 240 i=3+niis(1),2+niis(1)+niis(2)
43934 DO 230 j=1,5
43935 k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
43936 p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
43937 v(n+i,j)=0d0
43938 230 CONTINUE
43939 240 CONTINUE
43940 CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,0d0,-ps(1)/ps(4),
43941 & -ps(2)/ps(4),-ps(3)/ps(4))
43942 phi=pyangl(p(n+1,1),p(n+1,2))
43943 CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,-phi,0d0,0d0,0d0)
43944 the=pyangl(p(n+1,3),p(n+1,1))
43945 CALL pyrobo(n+1,n+2+niis(1)+niis(2),-the,0d0,0d0,0d0,0d0)
43946 DO 250 i=3,2+niis(1)
43947 theiis(1,i-2)=pyangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
43948 phiiis(1,i-2)=pyangl(p(n+i,1),p(n+i,2))
43949 250 CONTINUE
43950 DO 260 i=3+niis(1),2+niis(1)+niis(2)
43951 theiis(2,i-2-niis(1))=paru(1)-pyangl(p(n+i,3),
43952 & sqrt(p(n+i,1)**2+p(n+i,2)**2))
43953 phiiis(2,i-2-niis(1))=pyangl(p(n+i,1),p(n+i,2))
43954 260 CONTINUE
43955 ENDIF
43956
43957C...Define imagined single initiator of shower for parton system.
43958 ns=n
43959 IF(n.GT.mstu(4)-mstu(32)-5) THEN
43960 CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
43961 IF(mstu(21).GE.1) RETURN
43962 ENDIF
43963 265 n=ns
43964 IF(npa.GE.2) THEN
43965 k(n+1,1)=11
43966 k(n+1,2)=21
43967 k(n+1,3)=0
43968 k(n+1,4)=0
43969 k(n+1,5)=0
43970 p(n+1,1)=0d0
43971 p(n+1,2)=0d0
43972 p(n+1,3)=0d0
43973 p(n+1,4)=ps(5)
43974 p(n+1,5)=ps(5)
43975 v(n+1,5)=ps(5)**2
43976 n=n+1
43977 ENDIF
43978
43979C...Loop over partons that may branch.
43980 nep=npa
43981 im=ns
43982 IF(npa.EQ.1) im=ns-1
43983 270 im=im+1
43984 IF(n.GT.ns) THEN
43985 IF(im.GT.n) GOTO 510
43986 kflm=iabs(k(im,2))
43987 IF(kflm.GT.40) GOTO 270
43988 IF(ksh(kflm).EQ.0) GOTO 270
43989 iflm=kflm
43990 IF(kflm.GE.6.AND.kflm.LE.8) iflm=37+kflm+isign(2,k(im,2))
43991 IF(p(im,5).LT.pmth(2,iflm)) GOTO 270
43992 igm=k(im,3)
43993 ELSE
43994 igm=-1
43995 ENDIF
43996 IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
43997 CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
43998 IF(mstu(21).GE.1) RETURN
43999 ENDIF
44000
44001C...Position of aunt (sister to branching parton).
44002C...Origin and flavour of daughters.
44003 iau=0
44004 IF(igm.GT.0) THEN
44005 IF(k(im-1,3).EQ.igm) iau=im-1
44006 IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
44007 ENDIF
44008 IF(igm.GE.0) THEN
44009 k(im,4)=n+1
44010 DO 280 i=1,nep
44011 k(n+i,3)=im
44012 280 CONTINUE
44013 ELSE
44014 k(n+1,3)=ipa(1)
44015 ENDIF
44016 IF(igm.LE.0) THEN
44017 DO 290 i=1,nep
44018 k(n+i,2)=k(ipa(i),2)
44019 290 CONTINUE
44020 ELSEIF(kflm.NE.21) THEN
44021 k(n+1,2)=k(im,2)
44022 k(n+2,2)=k(im,5)
44023 ELSEIF(k(im,5).EQ.21) THEN
44024 k(n+1,2)=21
44025 k(n+2,2)=21
44026 ELSE
44027 k(n+1,2)=k(im,5)
44028 k(n+2,2)=-k(im,5)
44029 ENDIF
44030
44031C...Reset flags on daughters and tries made.
44032 DO 300 ip=1,nep
44033 k(n+ip,1)=3
44034 k(n+ip,4)=0
44035 k(n+ip,5)=0
44036 kfld(ip)=iabs(k(n+ip,2))
44037 IF(kchg(pycomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
44038 itry(ip)=0
44039 isl(ip)=0
44040 isi(ip)=0
44041 IF(kfld(ip).LE.40) THEN
44042 IF(ksh(kfld(ip)).EQ.1) isi(ip)=1
44043 ENDIF
44044 300 CONTINUE
44045 islm=0
44046
44047C...Maximum virtuality of daughters.
44048 IF(igm.LE.0) THEN
44049 DO 310 i=1,npa
44050 IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
44051 & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
44052 p(n+i,5)=min(qmax,ps(5))
44053 IF(ip2.LE.-5) p(n+i,5)=max(p(n+i,5),
44054 & 2d0*pmth(3,iabs(k(n+i,2))))
44055 IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
44056 IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
44057 310 CONTINUE
44058 ELSE
44059 IF(mstj(43).LE.2) pem=v(im,2)
44060 IF(mstj(43).GE.3) pem=p(im,4)
44061 p(n+1,5)=min(p(im,5),v(im,1)*pem)
44062 p(n+2,5)=min(p(im,5),(1d0-v(im,1))*pem)
44063 IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
44064 ENDIF
44065 DO 320 i=1,nep
44066 pmsd(i)=p(n+i,5)
44067 IF(isi(i).EQ.1) THEN
44068 ifld=kfld(i)
44069 IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
44070 & isign(2,k(n+i,2))
44071 IF(p(n+i,5).LE.pmth(3,ifld)) p(n+i,5)=pmth(1,ifld)
44072 ENDIF
44073 v(n+i,5)=p(n+i,5)**2
44074 320 CONTINUE
44075
44076C...Choose one of the daughters for evolution.
44077 330 inum=0
44078 IF(nep.EQ.1) inum=1
44079 DO 340 i=1,nep
44080 IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
44081 340 CONTINUE
44082 DO 350 i=1,nep
44083 IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
44084 ifld=kfld(i)
44085 IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
44086 & isign(2,k(n+i,2))
44087 IF(p(n+i,5).GE.pmth(2,ifld)) inum=i
44088 ENDIF
44089 350 CONTINUE
44090 IF(inum.EQ.0) THEN
44091 rmax=0d0
44092 DO 360 i=1,nep
44093 IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqt2e) THEN
44094 rpm=p(n+i,5)/pmsd(i)
44095 ifld=kfld(i)
44096 IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
44097 & isign(2,k(n+i,2))
44098 IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ifld)) THEN
44099 rmax=rpm
44100 inum=i
44101 ENDIF
44102 ENDIF
44103 360 CONTINUE
44104 ENDIF
44105
44106C...Cancel choice of predetermined daughter already treated.
44107 inum=max(1,inum)
44108 inumt=inum
44109 IF(mpspd.EQ.1.AND.igm.EQ.0.AND.itry(inumt).GE.1) THEN
44110 IF(k(ip1-1+inum,4).GT.0) inum=3-inum
44111 ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2.AND.itry(inumt).GE.1) THEN
44112 IF(kfld(inumt).NE.21.AND.k(ip1+2,4).GT.0) inum=3-inum
44113 IF(kfld(inumt).EQ.21.AND.k(ip1+3,4).GT.0) inum=3-inum
44114 ENDIF
44115
44116C...Store information on choice of evolving daughter.
44117 iep(1)=n+inum
44118 DO 370 i=2,nep
44119 iep(i)=iep(i-1)+1
44120 IF(iep(i).GT.n+nep) iep(i)=n+1
44121 370 CONTINUE
44122 DO 380 i=1,nep
44123 kfl(i)=iabs(k(iep(i),2))
44124 380 CONTINUE
44125 itry(inum)=itry(inum)+1
44126 IF(itry(inum).GT.200) THEN
44127 CALL pyerrm(14,'(PYSHOW:) caught in infinite loop')
44128 IF(mstu(21).GE.1) RETURN
44129 ENDIF
44130 z=0.5d0
44131 IF(kfl(1).GT.40) GOTO 430
44132 IF(ksh(kfl(1)).EQ.0) GOTO 430
44133 ifl=kfl(1)
44134 IF(kfl(1).GE.6.AND.kfl(1).LE.8) ifl=37+kfl(1)+
44135 &isign(2,k(iep(1),2))
44136 IF(p(iep(1),5).LT.pmth(2,ifl)) GOTO 430
44137
44138C...Check if evolution already predetermined for daughter.
44139 ipspd=0
44140 IF(mpspd.EQ.1.AND.igm.EQ.0) THEN
44141 IF(k(ip1-1+inum,4).GT.0) ipspd=ip1-1+inum
44142 ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2) THEN
44143 IF(kfl(1).NE.21.AND.k(ip1+2,4).GT.0) ipspd=ip1+2
44144 IF(kfl(1).EQ.21.AND.k(ip1+3,4).GT.0) ipspd=ip1+3
44145 ENDIF
44146 isset(inum)=0
44147 IF(ipspd.NE.0) isset(inum)=1
44148
44149C...Select side for interference with initial state partons.
44150 IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
44151 iii=iep(1)-ns-1
44152 isii(iii)=0
44153 IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
44154 isii(iii)=1
44155 ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
44156 IF(pyr(0).GT.0.5d0) isii(iii)=1
44157 ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
44158 isii(iii)=1
44159 IF(pyr(0).GT.0.5d0) isii(iii)=2
44160 ENDIF
44161 ENDIF
44162
44163C...Calculate allowed z range.
44164 IF(nep.EQ.1) THEN
44165 pmed=ps(4)
44166 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
44167 pmed=p(im,5)
44168 ELSE
44169 IF(inum.EQ.1) pmed=v(im,1)*pem
44170 IF(inum.EQ.2) pmed=(1d0-v(im,1))*pem
44171 ENDIF
44172 IF(mod(mstj(43),2).EQ.1) THEN
44173 zc=pmth(2,21)/pmed
44174 zce=pmth(2,22)/pmed
44175 IF(kfl(1).GE.11.AND.kfl(1).LE.18) zce=0.5d0*parj(90)/pmed
44176 ELSE
44177 zc=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,21)/pmed)**2)))
44178 IF(zc.LT.1d-6) zc=(pmth(2,21)/pmed)**2
44179 pmtmpe=pmth(2,22)
44180 IF(kfl(1).GE.11.AND.kfl(1).LE.18) pmtmpe=0.5d0*parj(90)
44181 zce=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmtmpe/pmed)**2)))
44182 IF(zce.LT.1d-6) zce=(pmtmpe/pmed)**2
44183 ENDIF
44184 zc=min(zc,0.491d0)
44185 zce=min(zce,0.49991d0)
44186 IF(((mstj(41).EQ.1.AND.zc.GT.0.49d0).OR.(mstj(41).GE.2.AND.
44187 &min(zc,zce).GT.0.4999d0)).AND.ipspd.EQ.0) THEN
44188 p(iep(1),5)=pmth(1,ifl)
44189 v(iep(1),5)=p(iep(1),5)**2
44190 GOTO 430
44191 ENDIF
44192
44193C...Integral of Altarelli-Parisi z kernel for QCD.
44194 IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
44195 fbr=6d0*log((1d0-zc)/zc)+mstj(45)*0.5d0
44196 ELSEIF(mstj(49).EQ.0) THEN
44197 fbr=(8d0/3d0)*log((1d0-zc)/zc)
44198
44199C...Integral of Altarelli-Parisi z kernel for scalar gluon.
44200 ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
44201 fbr=(parj(87)+mstj(45)*parj(88))*(1d0-2d0*zc)
44202 ELSEIF(mstj(49).EQ.1) THEN
44203 fbr=(1d0-2d0*zc)/3d0
44204 IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4d0*fbr
44205
44206C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
44207 ELSEIF(kfl(1).EQ.21) THEN
44208 fbr=6d0*mstj(45)*(0.5d0-zc)
44209 ELSE
44210 fbr=2d0*log((1d0-zc)/zc)
44211 ENDIF
44212
44213C...Reset QCD probability for lepton.
44214 IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0d0
44215
44216C...Integral of Altarelli-Parisi kernel for photon emission.
44217 IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
44218 fbre=(kchg(kfl(1),1)/3d0)**2*2d0*log((1d0-zce)/zce)
44219 IF(mstj(41).EQ.10) fbre=parj(84)*fbre
44220 ENDIF
44221
44222C...Inner veto algorithm starts. Find maximum mass for evolution.
44223 390 pms=v(iep(1),5)
44224 IF(igm.GE.0) THEN
44225 pm2=0d0
44226 DO 400 i=2,nep
44227 pm=p(iep(i),5)
44228 IF(kfl(i).LE.40) THEN
44229 ifli=kfl(i)
44230 IF(kfl(i).GE.6.AND.kfl(i).LE.8) ifli=37+kfl(i)+
44231 & isign(2,k(iep(i),2))
44232 IF(ksh(kfl(i)).EQ.1) pm=pmth(2,ifli)
44233 ENDIF
44234 pm2=pm2+pm
44235 400 CONTINUE
44236 pms=min(pms,(p(im,5)-pm2)**2)
44237 ENDIF
44238
44239C...Select mass for daughter in QCD evolution.
44240 b0=27d0/6d0
44241 DO 410 iff=4,mstj(45)
44242 IF(pms.GT.4d0*pmth(2,iff)**2) b0=(33d0-2d0*iff)/6d0
44243 410 CONTINUE
44244C...Already predetermined choice.
44245 IF(ipspd.NE.0) THEN
44246 pmsqcd=p(ipspd,5)**2
44247 ELSEIF(fbr.LT.1d-3) THEN
44248 pmsqcd=0d0
44249 ELSEIF(mstj(44).LE.0) THEN
44250 pmsqcd=pms*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(111)*fbr)))
44251 ELSEIF(mstj(44).EQ.1) THEN
44252 pmsqcd=4d0*alams*(0.25d0*pms/alams)**(pyr(0)**(b0/fbr))
44253 ELSE
44254 pmsqcd=pms*exp(max(-50d0,alfm*b0*log(pyr(0))/fbr))
44255 ENDIF
44256 IF(zc.GT.0.49d0.OR.pmsqcd.LE.pmth(4,ifl)**2) pmsqcd=
44257 & pmth(2,ifl)**2
44258 v(iep(1),5)=pmsqcd
44259 mce=1
44260
44261C...Select mass for daughter in QED evolution.
44262 IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18.AND.
44263 &ipspd.EQ.0) THEN
44264 pmsqed=pms*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(101)*fbre)))
44265 IF(zce.GT.0.4999d0.OR.pmsqed.LE.pmth(5,ifl)**2) pmsqed=
44266 & pmth(2,ifl)**2
44267 IF(pmsqed.GT.pmsqcd) THEN
44268 v(iep(1),5)=pmsqed
44269 mce=2
44270 ENDIF
44271 ENDIF
44272
44273C...Check whether daughter mass below cutoff.
44274 p(iep(1),5)=sqrt(v(iep(1),5))
44275 IF(p(iep(1),5).LE.pmth(3,ifl)) THEN
44276 p(iep(1),5)=pmth(1,ifl)
44277 v(iep(1),5)=p(iep(1),5)**2
44278 GOTO 430
44279 ENDIF
44280
44281C...Already predetermined choice of z, and flavour in g -> qqbar.
44282 IF(ipspd.NE.0) THEN
44283 ipsgd1=k(ipspd,4)
44284 ipsgd2=k(ipspd,5)
44285 pmsgd1=p(ipsgd1,5)**2
44286 pmsgd2=p(ipsgd2,5)**2
44287 alamps=sqrt(max(1d-10,(pmsqcd-pmsgd1-pmsgd2)**2-
44288 & 4d0*pmsgd1*pmsgd2))
44289 z=0.5d0*(pmsqcd*(2d0*p(ipsgd1,4)/p(ipspd,4)-1d0)+alamps-
44290 & pmsgd1+pmsgd2)/alamps
44291 z=max(0.00001d0,min(0.99999d0,z))
44292 IF(kfl(1).NE.21) THEN
44293 k(iep(1),5)=21
44294 ELSE
44295 k(iep(1),5)=iabs(k(ipsgd1,2))
44296 ENDIF
44297
44298C...Select z value of branching: q -> qgamma.
44299 ELSEIF(mce.EQ.2) THEN
44300 z=1d0-(1d0-zce)*(zce/(1d0-zce))**pyr(0)
44301 IF(1d0+z**2.LT.2d0*pyr(0)) GOTO 390
44302 k(iep(1),5)=22
44303
44304C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
44305 ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
44306 z=1d0-(1d0-zc)*(zc/(1d0-zc))**pyr(0)
44307 IF(igm.EQ.0.AND.m3jcm.EQ.1) z=1d0-(1d0-z)**rescz
44308 IF(1d0+z**2.LT.2d0*pyr(0)) GOTO 390
44309 k(iep(1),5)=21
44310 ELSEIF(mstj(49).EQ.0.AND.mstj(45)*0.5d0.LT.pyr(0)*fbr) THEN
44311 z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
44312 IF(pyr(0).GT.0.5d0) z=1d0-z
44313 IF((1d0-z*(1d0-z))**2.LT.pyr(0)) GOTO 390
44314 k(iep(1),5)=21
44315 ELSEIF(mstj(49).NE.1) THEN
44316 z=pyr(0)
44317 IF(z**2+(1d0-z)**2.LT.pyr(0)) GOTO 390
44318 kflb=1+int(mstj(45)*pyr(0))
44319 pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
44320 IF(pmq.GE.1d0) GOTO 390
44321 IF(mstj(44).LE.2) THEN
44322 IF(z.LT.zc.OR.z.GT.1d0-zc) GOTO 390
44323 pmq0=4d0*pmth(2,21)**2/v(iep(1),5)
44324 IF(mod(mstj(43),2).EQ.0.AND.(1d0+0.5d0*pmq)*sqrt(1d0-pmq)
44325 & .LT.pyr(0)*(1d0+0.5d0*pmq0)*sqrt(1d0-pmq0)) GOTO 390
44326 ELSE
44327 IF((1d0+0.5d0*pmq)*sqrt(1d0-pmq).LT.pyr(0)) GOTO 390
44328 ENDIF
44329 k(iep(1),5)=kflb
44330
44331C...Ditto for scalar gluon model.
44332 ELSEIF(kfl(1).NE.21) THEN
44333 z=1d0-sqrt(zc**2+pyr(0)*(1d0-2d0*zc))
44334 k(iep(1),5)=21
44335 ELSEIF(pyr(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
44336 z=zc+(1d0-2d0*zc)*pyr(0)
44337 k(iep(1),5)=21
44338 ELSE
44339 z=zc+(1d0-2d0*zc)*pyr(0)
44340 kflb=1+int(mstj(45)*pyr(0))
44341 pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
44342 IF(pmq.GE.1d0) GOTO 390
44343 k(iep(1),5)=kflb
44344 ENDIF
44345
44346C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
44347 IF(mce.EQ.1.AND.mstj(44).GE.2.AND.ipspd.EQ.0) THEN
44348 IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.mstj(44).EQ.3) THEN
44349 IF(alfm/log(v(iep(1),5)*0.25d0/alams).LT.pyr(0)) GOTO 390
44350 ELSE
44351 IF(z*(1d0-z)*v(iep(1),5).LT.pt2min) GOTO 390
44352 IF(alfm/log(v(iep(1),5)*z*(1d0-z)/alams).LT.pyr(0)) GOTO 390
44353 ENDIF
44354 ENDIF
44355
44356C...Check if z consistent with chosen m.
44357 IF(kfl(1).EQ.21) THEN
44358 kflgd1=iabs(k(iep(1),5))
44359 kflgd2=kflgd1
44360 ELSE
44361 kflgd1=kfl(1)
44362 kflgd2=iabs(k(iep(1),5))
44363 ENDIF
44364 IF(nep.EQ.1) THEN
44365 ped=ps(4)
44366 ELSEIF(nep.GE.3) THEN
44367 ped=p(iep(1),4)
44368 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
44369 ped=0.5d0*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
44370 ELSE
44371 IF(iep(1).EQ.n+1) ped=v(im,1)*pem
44372 IF(iep(1).EQ.n+2) ped=(1d0-v(im,1))*pem
44373 ENDIF
44374 IF(mod(mstj(43),2).EQ.1) THEN
44375 iflgd1=kflgd1
44376 IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=ifl
44377 pmqth3=0.5d0*parj(82)
44378 IF(kflgd2.EQ.22) pmqth3=0.5d0*parj(83)
44379 IF(kfl(1).GE.11.AND.kfl(1).LE.18) pmqth3=0.5d0*parj(90)
44380 pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(iep(1),5)
44381 pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
44382 zd=sqrt(max(0d0,(1d0-v(iep(1),5)/ped**2)*((1d0-pmq1-pmq2)**2-
44383 & 4d0*pmq1*pmq2)))
44384 zh=1d0+pmq1-pmq2
44385 ELSE
44386 zd=sqrt(max(0d0,1d0-v(iep(1),5)/ped**2))
44387 zh=1d0
44388 ENDIF
44389 IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.mstj(44).EQ.3) THEN
44390 ELSEIF(ipspd.NE.0) THEN
44391 ELSE
44392 zl=0.5d0*(zh-zd)
44393 zu=0.5d0*(zh+zd)
44394 IF(z.LT.zl.OR.z.GT.zu) GOTO 390
44395 ENDIF
44396 IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1d0-zl)/max(1d-20,zl*
44397 &(1d0-zu)))
44398 IF(kfl(1).NE.21) v(iep(1),3)=log((1d0-zl)/max(1d-10,1d0-zu))
44399
44400C...Width suppression for q -> q + g.
44401 IF(mstj(40).NE.0.AND.kfl(1).NE.21.AND.ipspd.EQ.0) THEN
44402 IF(igm.EQ.0) THEN
44403 eglu=0.5d0*ps(5)*(1d0-z)*(1d0+v(iep(1),5)/v(ns+1,5))
44404 ELSE
44405 eglu=pmed*(1d0-z)
44406 ENDIF
44407 chi=parj(89)**2/(parj(89)**2+eglu**2)
44408 IF(mstj(40).EQ.1) THEN
44409 IF(chi.LT.pyr(0)) GOTO 390
44410 ELSEIF(mstj(40).EQ.2) THEN
44411 IF(1d0-chi.LT.pyr(0)) GOTO 390
44412 ENDIF
44413 ENDIF
44414
44415C...Three-jet matrix element correction (on both sides).
44416 IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
44417 x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
44418 x2=1d0-v(iep(1),5)/v(ns+1,5)
44419 x3=(1d0-x1)+(1d0-x2)
44420 IF(mce.EQ.2) THEN
44421 ki1=k(ipa(inum),2)
44422 ki2=k(ipa(3-inum),2)
44423 qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3d0
44424 qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3d0
44425 wshow=qf1**2*(1d0-x1)/x3*(1d0+(x1/(2d0-x2))**2)+
44426 & qf2**2*(1d0-x2)/x3*(1d0+(x2/(2d0-x1))**2)
44427 wme=(qf1*(1d0-x1)/x3-qf2*(1d0-x2)/x3)**2*(x1**2+x2**2)
44428 ELSEIF(mstj(49).NE.1.AND.m3jcm.NE.1) THEN
44429 wshow=1d0+(1d0-x1)/x3*(x1/(2d0-x2))**2+
44430 & (1d0-x2)/x3*(x2/(2d0-x1))**2
44431 wme=x1**2+x2**2
44432 ELSEIF(mstj(49).NE.1) THEN
44433 x1=(1d0+(v(iep(1),5)-pqmes)/v(ns+1,5))*
44434 & (z+(1d0-z)*pqmes/v(iep(1),5))
44435 x2=1d0-(v(iep(1),5)-pqmes)/v(ns+1,5)
44436 x3=(1d0-x1)+(1d0-x2)
44437 z1sh=(x1-(pqmes/v(ns+1,5))*(x3/max(1d-10,1d0-x2)))/(2d0-x2)
44438 z2sh=(x2-(pqmes/v(ns+1,5))*(x3/max(1d-10,1d0-x1)))/(2d0-x1)
44439 wshow=(((1d0-x1)/(2d0-x2))*(1d0+z1sh**2)/max(1d-10,1d0-z1sh)+
44440 & ((1d0-x2)/(2d0-x1))*(1d0+z2sh**2)/max(1d-10,1d0-z2sh))/rescz
44441 wme=x1**2+x2**2-qme*x3-0.5d0*qme**2-
44442 & (0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/max(1d-10,1d0-x1)+
44443 & (1d0-x1)/max(1d-10,1d0-x2))
44444 ELSE
44445 wshow=4d0*x3*((1d0-x1)/(2d0-x2)**2+(1d0-x2)/(2d0-x1)**2)
44446 wme=x3**2
44447 IF(mstj(102).GE.2) wme=x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*
44448 & parj(171)
44449 ENDIF
44450 IF(wme.LT.pyr(0)*wshow) GOTO 390
44451
44452C...Impose angular ordering by rejection of nonordered emission.
44453 ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2.AND.ipspd.EQ.0)
44454 &THEN
44455 pemao=v(im,1)*p(im,4)
44456 IF(iep(1).EQ.n+2) pemao=(1d0-v(im,1))*p(im,4)
44457 IF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.mstj(42).EQ.4) THEN
44458 maod=0
44459 ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.mstj(42).EQ.3)
44460 & THEN
44461 maod=1
44462 pmdao=pmth(2,k(iep(1),5))
44463 the2id=z*(1d0-z)*pemao**2/(v(iep(1),5)-4d0*pmdao**2)
44464 ELSE
44465 maod=1
44466 the2id=z*(1d0-z)*pemao**2/v(iep(1),5)
44467 ENDIF
44468 maom=1
44469 iaom=im
44470 420 IF(k(iaom,5).EQ.22) THEN
44471 iaom=k(iaom,3)
44472 IF(k(iaom,3).LE.ns) maom=0
44473 IF(maom.EQ.1) GOTO 420
44474 ENDIF
44475 IF(maom.EQ.1.AND.maod.EQ.1) THEN
44476 the2im=v(iaom,1)*(1d0-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
44477 IF(the2id.LT.the2im) GOTO 390
44478 ENDIF
44479 ENDIF
44480
44481C...Impose user-defined maximum angle at first branching.
44482 IF(mstj(48).EQ.1.AND.ipspd.EQ.0) THEN
44483 IF(nep.EQ.1.AND.im.EQ.ns) THEN
44484 the2id=z*(1d0-z)*ps(4)**2/v(iep(1),5)
44485 IF(parj(85)**2*the2id.LT.1d0) GOTO 390
44486 ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
44487 the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
44488 IF(parj(85)**2*the2id.LT.1d0) GOTO 390
44489 ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
44490 the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
44491 IF(parj(86)**2*the2id.LT.1d0) GOTO 390
44492 ENDIF
44493 ENDIF
44494
44495C...Impose angular constraint in first branching from interference
44496C...with initial state partons.
44497 IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
44498 the2d=max((1d0-z)/z,z/(1d0-z))*v(iep(1),5)/(0.5d0*p(im,4))**2
44499 IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
44500 IF(the2d.GT.theiis(1,isii(1))**2) GOTO 390
44501 ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
44502 IF(the2d.GT.theiis(2,isii(2))**2) GOTO 390
44503 ENDIF
44504 ENDIF
44505
44506C...End of inner veto algorithm. Check if only one leg evolved so far.
44507 430 v(iep(1),1)=z
44508 isl(1)=0
44509 isl(2)=0
44510 IF(nep.EQ.1) GOTO 460
44511 IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) GOTO 330
44512 DO 440 i=1,nep
44513 IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN
44514 IF(ksh(kfld(i)).EQ.1) THEN
44515 ifld=kfld(i)
44516 IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
44517 & isign(2,k(n+i,2))
44518 IF(p(n+i,5).GE.pmth(2,ifld)) GOTO 330
44519 ENDIF
44520 ENDIF
44521 440 CONTINUE
44522
44523C...Check if chosen multiplet m1,m2,z1,z2 is physical.
44524 IF(nep.EQ.3) THEN
44525 pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
44526 pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
44527 pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
44528 pts=0.25d0*(2d0*pa1s*pa2s+2d0*pa1s*pa3s+2d0*pa2s*pa3s-
44529 & pa1s**2-pa2s**2-pa3s**2)/pa1s
44530 IF(pts.LE.0d0) GOTO 330
44531 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
44532 DO 450 i1=n+1,n+2
44533 kflda=iabs(k(i1,2))
44534 IF(kflda.GT.40) GOTO 450
44535 IF(ksh(kflda).EQ.0) GOTO 450
44536 iflda=kflda
44537 IF(kflda.GE.6.AND.kflda.LE.8) iflda=37+kflda+
44538 & isign(2,k(i1,2))
44539 IF(p(i1,5).LT.pmth(2,iflda)) GOTO 450
44540 IF(kflda.EQ.21) THEN
44541 kflgd1=iabs(k(i1,5))
44542 kflgd2=kflgd1
44543 ELSE
44544 kflgd1=kflda
44545 kflgd2=iabs(k(i1,5))
44546 ENDIF
44547 i2=2*n+3-i1
44548 IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
44549 ped=0.5d0*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
44550 ELSE
44551 IF(i1.EQ.n+1) zm=v(im,1)
44552 IF(i1.EQ.n+2) zm=1d0-v(im,1)
44553 pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
44554 & 4d0*v(n+1,5)*v(n+2,5))
44555 ped=pem*(0.5d0*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/
44556 & v(im,5)
44557 ENDIF
44558 IF(mod(mstj(43),2).EQ.1) THEN
44559 pmqth3=0.5d0*parj(82)
44560 IF(kflgd2.EQ.22) pmqth3=0.5d0*parj(83)
44561 IF(kflda.GE.11.AND.kflda.LE.18) pmqth3=0.5d0*parj(90)
44562 iflgd1=kflgd1
44563 IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=iflda
44564 pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(i1,5)
44565 pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
44566 zd=sqrt(max(0d0,(1d0-v(i1,5)/ped**2)*((1d0-pmq1-pmq2)**2-
44567 & 4d0*pmq1*pmq2)))
44568 zh=1d0+pmq1-pmq2
44569 ELSE
44570 zd=sqrt(max(0d0,1d0-v(i1,5)/ped**2))
44571 zh=1d0
44572 ENDIF
44573 IF(kflda.EQ.21.AND.kflgd1.LT.10.AND.mstj(44).EQ.3) THEN
44574 ELSE
44575 zl=0.5d0*(zh-zd)
44576 zu=0.5d0*(zh+zd)
44577 IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
44578 & isset(1).EQ.0) THEN
44579 isl(1)=1
44580 ELSEIF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
44581 & isset(2).EQ.0) THEN
44582 isl(2)=1
44583 ENDIF
44584 ENDIF
44585 IF(kflda.EQ.21) v(i1,4)=log(zu*(1d0-zl)/max(1d-20,
44586 & zl*(1d0-zu)))
44587 IF(kflda.NE.21) v(i1,4)=log((1d0-zl)/max(1d-10,1d0-zu))
44588 450 CONTINUE
44589 IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
44590 isl(3-islm)=0
44591 islm=3-islm
44592 ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
44593 zdr1=max(0d0,v(n+1,3)/max(1d-6,v(n+1,4))-1d0)
44594 zdr2=max(0d0,v(n+2,3)/max(1d-6,v(n+2,4))-1d0)
44595 IF(zdr2.GT.pyr(0)*(zdr1+zdr2)) isl(1)=0
44596 IF(isl(1).EQ.1) isl(2)=0
44597 IF(isl(1).EQ.0) islm=1
44598 IF(isl(2).EQ.0) islm=2
44599 ENDIF
44600 IF(isl(1).EQ.1.OR.isl(2).EQ.1) GOTO 330
44601 ENDIF
44602 ifld1=kfld(1)
44603 IF(kfld(1).GE.6.AND.kfld(1).LE.8) ifld1=37+kfld(1)+
44604 &isign(2,k(n+1,2))
44605 ifld2=kfld(2)
44606 IF(kfld(2).GE.6.AND.kfld(2).LE.8) ifld2=37+kfld(2)+
44607 &isign(2,k(n+2,2))
44608 IF(igm.GT.0) THEN
44609 IF(mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
44610 & pmth(2,ifld1).OR.p(n+2,5).GE.pmth(2,ifld2))) THEN
44611 pmq1=v(n+1,5)/v(im,5)
44612 pmq2=v(n+2,5)/v(im,5)
44613 zd=sqrt(max(0d0,(1d0-v(im,5)/pem**2)*((1d0-pmq1-pmq2)**2-
44614 & 4d0*pmq1*pmq2)))
44615 zh=1d0+pmq1-pmq2
44616 zl=0.5d0*(zh-zd)
44617 zu=0.5d0*(zh+zd)
44618 IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) GOTO 330
44619 ENDIF
44620 ENDIF
44621
44622C...Accepted branch. Construct four-momentum for initial partons.
44623 460 mazip=0
44624 mazic=0
44625 IF(nep.EQ.1) THEN
44626 p(n+1,1)=0d0
44627 p(n+1,2)=0d0
44628 p(n+1,3)=sqrt(max(0d0,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
44629 & p(n+1,5))))
44630 p(n+1,4)=p(ipa(1),4)
44631 v(n+1,2)=p(n+1,4)
44632 ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
44633 ped1=0.5d0*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
44634 p(n+1,1)=0d0
44635 p(n+1,2)=0d0
44636 p(n+1,3)=sqrt(max(0d0,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
44637 p(n+1,4)=ped1
44638 p(n+2,1)=0d0
44639 p(n+2,2)=0d0
44640 p(n+2,3)=-p(n+1,3)
44641 p(n+2,4)=p(im,5)-ped1
44642 v(n+1,2)=p(n+1,4)
44643 v(n+2,2)=p(n+2,4)
44644 ELSEIF(nep.EQ.3) THEN
44645 p(n+1,1)=0d0
44646 p(n+1,2)=0d0
44647 p(n+1,3)=sqrt(max(0d0,pa1s))
44648 p(n+2,1)=sqrt(pts)
44649 p(n+2,2)=0d0
44650 p(n+2,3)=0.5d0*(pa3s-pa2s-pa1s)/p(n+1,3)
44651 p(n+3,1)=-p(n+2,1)
44652 p(n+3,2)=0d0
44653 p(n+3,3)=-(p(n+1,3)+p(n+2,3))
44654 v(n+1,2)=p(n+1,4)
44655 v(n+2,2)=p(n+2,4)
44656 v(n+3,2)=p(n+3,4)
44657
44658C...Construct transverse momentum for ordinary branching in shower.
44659 ELSE
44660 zm=v(im,1)
44661 looppt=0
44662 465 looppt=looppt+1
44663 pzm=sqrt(max(0d0,(pem+p(im,5))*(pem-p(im,5))))
44664 pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4d0*v(n+1,5)*v(n+2,5)
44665 IF(pzm.LE.0d0) THEN
44666 pts=0d0
44667 ELSEIF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
44668 & mstj(44).EQ.3) THEN
44669 pts=pmls*zm*(1d0-zm)/v(im,5)
44670 ELSEIF(mod(mstj(43),2).EQ.1) THEN
44671 pts=(pem**2*(zm*(1d0-zm)*v(im,5)-(1d0-zm)*v(n+1,5)-
44672 & zm*v(n+2,5))-0.25d0*pmls)/pzm**2
44673 ELSE
44674 pts=pmls*(zm*(1d0-zm)*pem**2/v(im,5)-0.25d0)/pzm**2
44675 ENDIF
44676 IF(pts.LT.0d0.AND.looppt.LT.10) THEN
44677 zm=0.05d0+0.9d0*zm
44678 GOTO 465
44679 ELSEIF(pts.LT.0d0) THEN
44680 GOTO 265
44681 ENDIF
44682 pt=sqrt(max(0d0,pts))
44683
44684C...Find coefficient of azimuthal asymmetry due to gluon polarization.
44685 hazip=0d0
44686 IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21
44687 & .AND.iau.NE.0) THEN
44688 IF(k(igm,3).NE.0) mazip=1
44689 zau=v(igm,1)
44690 IF(iau.EQ.im+1) zau=1d0-v(igm,1)
44691 IF(mazip.EQ.0) zau=0d0
44692 IF(k(igm,2).NE.21) THEN
44693 hazip=2d0*zau/(1d0+zau**2)
44694 ELSE
44695 hazip=(zau/(1d0-zau*(1d0-zau)))**2
44696 ENDIF
44697 IF(k(n+1,2).NE.21) THEN
44698 hazip=hazip*(-2d0*zm*(1d0-zm))/(1d0-2d0*zm*(1d0-zm))
44699 ELSE
44700 hazip=hazip*(zm*(1d0-zm)/(1d0-zm*(1d0-zm)))**2
44701 ENDIF
44702 ENDIF
44703
44704C...Find coefficient of azimuthal asymmetry due to soft gluon
44705C...interference.
44706 hazic=0d0
44707 IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
44708 & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
44709 IF(k(igm,3).NE.0) mazic=n+1
44710 IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
44711 IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
44712 & zm.GT.0.5d0) mazic=n+2
44713 IF(k(iau,2).EQ.22) mazic=0
44714 zs=zm
44715 IF(mazic.EQ.n+2) zs=1d0-zm
44716 zgm=v(igm,1)
44717 IF(iau.EQ.im-1) zgm=1d0-v(igm,1)
44718 IF(mazic.EQ.0) zgm=1d0
44719 IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
44720 & sqrt((1d0-zs)*(1d0-zgm)/(zs*zgm))
44721 hazic=min(0.95d0,hazic)
44722 ENDIF
44723 ENDIF
44724
44725C...Construct energies for ordinary branching in shower.
44726 470 IF(nep.EQ.2.AND.igm.GT.0) THEN
44727 IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
44728 & mstj(44).EQ.3) THEN
44729 p(n+1,4)=0.5d0*(pem*(v(im,5)+v(n+1,5)-v(n+2,5))+
44730 & pzm*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
44731 ELSEIF(mod(mstj(43),2).EQ.1) THEN
44732 p(n+1,4)=pem*v(im,1)
44733 ELSE
44734 p(n+1,4)=pem*(0.5d0*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
44735 & sqrt(pmls)*zm)/v(im,5)
44736 ENDIF
44737
44738C...Already predetermined choice of phi angle or not
44739 phi=paru(2)*pyr(0)
44740 IF(mpspd.EQ.1.AND.igm.EQ.ns+1) THEN
44741 ipspd=ip1+im-ns-2
44742 IF(k(ipspd,4).GT.0) THEN
44743 ipsgd1=k(ipspd,4)
44744 IF(im.EQ.ns+2) THEN
44745 phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
44746 ELSE
44747 phi=pyangl(-p(ipsgd1,1),p(ipsgd1,2))
44748 ENDIF
44749 ENDIF
44750 ELSEIF(mpspd.EQ.1.AND.igm.EQ.ns+2) THEN
44751 ipspd=ip1+im-ns-2
44752 IF(k(ipspd,4).GT.0) THEN
44753 ipsgd1=k(ipspd,4)
44754 phipsm=pyangl(p(ipspd,1),p(ipspd,2))
44755 thepsm=pyangl(p(ipspd,3),sqrt(p(ipspd,1)**2+p(ipspd,2)**2))
44756 CALL pyrobo(ipsgd1,ipsgd1,0d0,-phipsm,0d0,0d0,0d0)
44757 CALL pyrobo(ipsgd1,ipsgd1,-thepsm,0d0,0d0,0d0,0d0)
44758 phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
44759 CALL pyrobo(ipsgd1,ipsgd1,thepsm,phipsm,0d0,0d0,0d0)
44760 ENDIF
44761 ENDIF
44762
44763C...Construct momenta for ordinary branching in shower.
44764 p(n+1,1)=pt*cos(phi)
44765 p(n+1,2)=pt*sin(phi)
44766 IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
44767 & mstj(44).EQ.3) THEN
44768 p(n+1,3)=0.5d0*(pzm*(v(im,5)+v(n+1,5)-v(n+2,5))+
44769 & pem*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
44770 ELSEIF(pzm.GT.0d0) THEN
44771 p(n+1,3)=0.5d0*(v(n+2,5)-v(n+1,5)-v(im,5)+
44772 & 2d0*pem*p(n+1,4))/pzm
44773 ELSE
44774 p(n+1,3)=0d0
44775 ENDIF
44776 p(n+2,1)=-p(n+1,1)
44777 p(n+2,2)=-p(n+1,2)
44778 p(n+2,3)=pzm-p(n+1,3)
44779 p(n+2,4)=pem-p(n+1,4)
44780 IF(mstj(43).LE.2) THEN
44781 v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
44782 v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
44783 ENDIF
44784 ENDIF
44785
44786C...Rotate and boost daughters.
44787 IF(igm.GT.0) THEN
44788 IF(mstj(43).LE.2) THEN
44789 bex=p(igm,1)/p(igm,4)
44790 bey=p(igm,2)/p(igm,4)
44791 bez=p(igm,3)/p(igm,4)
44792 ga=p(igm,4)/p(igm,5)
44793 gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1d0+ga)-
44794 & p(im,4))
44795 ELSE
44796 bex=0d0
44797 bey=0d0
44798 bez=0d0
44799 ga=1d0
44800 gabep=0d0
44801 ENDIF
44802 ptimb=sqrt((p(im,1)+gabep*bex)**2+(p(im,2)+gabep*bey)**2)
44803 the=pyangl(p(im,3)+gabep*bez,ptimb)
44804 IF(ptimb.GT.1d-4) THEN
44805 phi=pyangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
44806 ELSE
44807 phi=0d0
44808 ENDIF
44809 DO 480 i=n+1,n+2
44810 dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
44811 & sin(the)*cos(phi)*p(i,3)
44812 dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
44813 & sin(the)*sin(phi)*p(i,3)
44814 dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
44815 dp(4)=p(i,4)
44816 dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
44817 dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
44818 p(i,1)=dp(1)+dgabp*bex
44819 p(i,2)=dp(2)+dgabp*bey
44820 p(i,3)=dp(3)+dgabp*bez
44821 p(i,4)=ga*(dp(4)+dbp)
44822 480 CONTINUE
44823 ENDIF
44824
44825C...Weight with azimuthal distribution, if required.
44826 IF(mazip.NE.0.OR.mazic.NE.0) THEN
44827 DO 490 j=1,3
44828 dpt(1,j)=p(im,j)
44829 dpt(2,j)=p(iau,j)
44830 dpt(3,j)=p(n+1,j)
44831 490 CONTINUE
44832 dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
44833 dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
44834 dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
44835 DO 500 j=1,3
44836 dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
44837 dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
44838 500 CONTINUE
44839 dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
44840 dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
44841 IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
44842 cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
44843 & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
44844 IF(mazip.NE.0) THEN
44845 IF(1d0+hazip*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(hazip)))
44846 & GOTO 470
44847 ENDIF
44848 IF(mazic.NE.0) THEN
44849 IF(mazic.EQ.n+2) cad=-cad
44850 IF((1d0-hazic)*(1d0-hazic*cad)/(1d0+hazic**2-2d0*hazic*cad)
44851 & .LT.pyr(0)) GOTO 470
44852 ENDIF
44853 ENDIF
44854 ENDIF
44855
44856C...Azimuthal anisotropy due to interference with initial state partons.
44857 IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
44858 &k(n+2,2).EQ.21)) THEN
44859 iii=im-ns-1
44860 IF(isii(iii).GE.1) THEN
44861 iaziid=n+1
44862 IF(k(n+1,2).NE.21) iaziid=n+2
44863 IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
44864 & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
44865 theiid=pyangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
44866 IF(iii.EQ.2) theiid=paru(1)-theiid
44867 phiiid=pyangl(p(iaziid,1),p(iaziid,2))
44868 hazii=min(0.95d0,theiid/theiis(iii,isii(iii)))
44869 cad=cos(phiiid-phiiis(iii,isii(iii)))
44870 phirel=abs(phiiid-phiiis(iii,isii(iii)))
44871 IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
44872 IF((1d0-hazii)*(1d0-hazii*cad)/(1d0+hazii**2-2d0*hazii*cad)
44873 & .LT.pyr(0)) GOTO 470
44874 ENDIF
44875 ENDIF
44876
44877C...Continue loop over partons that may branch, until none left.
44878 IF(igm.GE.0) k(im,1)=14
44879 n=n+nep
44880 nep=2
44881 IF(n.GT.mstu(4)-mstu(32)-5) THEN
44882 CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
44883 IF(mstu(21).GE.1) n=ns
44884 IF(mstu(21).GE.1) RETURN
44885 ENDIF
44886 GOTO 270
44887
44888C...Set information on imagined shower initiator.
44889 510 IF(npa.GE.2) THEN
44890 k(ns+1,1)=11
44891 k(ns+1,2)=94
44892 k(ns+1,3)=ip1
44893 IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
44894 k(ns+1,4)=ns+2
44895 k(ns+1,5)=ns+1+npa
44896 iim=1
44897 ELSE
44898 iim=0
44899 ENDIF
44900
44901C...Reconstruct string drawing information.
44902 DO 520 i=ns+1+iim,n
44903 IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
44904 k(i,1)=1
44905 ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
44906 & iabs(k(i,2)).LE.18) THEN
44907 k(i,1)=1
44908 ELSEIF(k(i,1).LE.10) THEN
44909 k(i,4)=mstu(5)*(k(i,4)/mstu(5))
44910 k(i,5)=mstu(5)*(k(i,5)/mstu(5))
44911 ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
44912 id1=mod(k(i,4),mstu(5))
44913 IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
44914 id2=2*mod(k(i,4),mstu(5))+1-id1
44915 k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
44916 k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
44917 k(id1,4)=k(id1,4)+mstu(5)*i
44918 k(id1,5)=k(id1,5)+mstu(5)*id2
44919 k(id2,4)=k(id2,4)+mstu(5)*id1
44920 k(id2,5)=k(id2,5)+mstu(5)*i
44921 ELSE
44922 id1=mod(k(i,4),mstu(5))
44923 id2=id1+1
44924 k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
44925 k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
44926 IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN
44927 k(id1,4)=k(id1,4)+mstu(5)*i
44928 k(id1,5)=k(id1,5)+mstu(5)*i
44929 ELSE
44930 k(id1,4)=0
44931 k(id1,5)=0
44932 ENDIF
44933 k(id2,4)=0
44934 k(id2,5)=0
44935 ENDIF
44936 520 CONTINUE
44937
44938C...Transformation from CM frame.
44939 IF(npa.GE.2) THEN
44940 bex=ps(1)/ps(4)
44941 bey=ps(2)/ps(4)
44942 bez=ps(3)/ps(4)
44943 ga=ps(4)/ps(5)
44944 gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
44945 & /(1d0+ga)-p(ipa(1),4))
44946 ELSE
44947 bex=0d0
44948 bey=0d0
44949 bez=0d0
44950 gabep=0d0
44951 ENDIF
44952 the=pyangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
44953 &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
44954 phi=pyangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
44955 IF(npa.EQ.3) THEN
44956 chi=pyangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
44957 & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
44958 & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
44959 & gabep*bey))
44960 mstu(33)=1
44961 CALL pyrobo(ns+1,n,0d0,chi,0d0,0d0,0d0)
44962 ENDIF
44963 mstu(33)=1
44964 CALL pyrobo(ns+1,n,the,phi,bex,bey,bez)
44965
44966C...Decay vertex of shower.
44967 DO 540 i=ns+1,n
44968 DO 530 j=1,5
44969 v(i,j)=v(ip1,j)
44970 530 CONTINUE
44971 540 CONTINUE
44972
44973C...Delete trivial shower, else connect initiators.
44974 IF(n.LE.ns+npa+iim) THEN
44975 n=ns
44976 ELSE
44977 DO 550 ip=1,npa
44978 k(ipa(ip),1)=14
44979 k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
44980 k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
44981 k(ns+iim+ip,3)=ipa(ip)
44982 IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
44983 IF(k(ns+iim+ip,1).NE.1) THEN
44984 k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
44985 k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
44986 ENDIF
44987 550 CONTINUE
44988 ENDIF
44989
44990 RETURN
44991 END
44992
44993C*********************************************************************
44994
44995C...PYBOEI
44996C...Modifies an event so as to approximately take into account
44997C...Bose-Einstein effects according to a simple phenomenological
44998C...parametrization.
44999
45000 SUBROUTINE pyboei(NSAV)
45001
45002C...Double precision and integer declarations.
45003 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45004 IMPLICIT INTEGER(I-N)
45005 INTEGER PYK,PYCHGE,PYCOMP
45006 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
45007C...Commonblocks.
45008 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
45009 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45010 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45011 SAVE /pyjets/,/pydat1/,/pydat2/
45012C...Local arrays and data.
45013 dimension dps(4),kfbe(9),nbe(0:10),bei(100),bei3(100),
45014 &beiw(100),bei3w(100)
45015 DATA kfbe/211,-211,111,321,-321,130,310,221,331/
45016C...Statement function: squared invariant mass.
45017 sdip(i,j)=((p(i,4)+p(j,4))**2-(p(i,3)+p(j,3))**2-
45018 &(p(i,2)+p(j,2))**2-(p(i,1)+p(j,1))**2)
45019
45020C...Boost event to overall CM frame. Calculate CM energy.
45021 IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
45022 DO 100 j=1,4
45023 dps(j)=0d0
45024 100 CONTINUE
45025 DO 120 i=1,n
45026 kfa=iabs(k(i,2))
45027 IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22)
45028 & .AND.k(i,3).GT.0) THEN
45029 kfma=iabs(k(k(i,3),2))
45030 IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
45031 ENDIF
45032 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
45033 DO 110 j=1,4
45034 dps(j)=dps(j)+p(i,j)
45035 110 CONTINUE
45036 120 CONTINUE
45037 CALL pyrobo(0,0,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
45038 &-dps(3)/dps(4))
45039 pecm=0d0
45040 DO 130 i=1,n
45041 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
45042 130 CONTINUE
45043
45044C...Reserve copy of particles by species at end of record.
45045 iwp=0
45046 iwn=0
45047 nbe(0)=n+mstu(3)
45048 nmax=nbe(0)
45049 smmin=pecm
45050 DO 180 ibe=1,min(10,mstj(52)+1)
45051 nbe(ibe)=nbe(ibe-1)
45052 DO 170 i=nsav+1,n
45053 IF(ibe.EQ.min(10,mstj(52)+1)) THEN
45054 DO 140 iibe=1,ibe-1
45055 IF(k(i,2).EQ.kfbe(iibe)) GOTO 170
45056 140 CONTINUE
45057 ELSE
45058 IF(k(i,2).NE.kfbe(ibe)) GOTO 170
45059 ENDIF
45060 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 170
45061 IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
45062 CALL pyerrm(11,'(PYBOEI:) no more memory left in PYJETS')
45063 RETURN
45064 ENDIF
45065 nbe(ibe)=nbe(ibe)+1
45066 nmax=nbe(ibe)
45067 k(nbe(ibe),1)=i
45068 k(nbe(ibe),5)=0
45069 smmin=min(smmin,p(i,5))
45070 IF(mstj(53).NE.0.OR.mstj(56).GT.0) THEN
45071 im=i
45072 150 IF(k(im,3).GT.0) THEN
45073 im=k(im,3)
45074 IF(abs(k(im,2)).NE.24) GOTO 150
45075 k(nbe(ibe),5)=k(im,2)
45076 IF(iwp.EQ.0.AND.k(im,2).EQ.24) iwp=im
45077 IF(iwn.EQ.0.AND.k(im,2).EQ.-24) iwn=im
45078 ENDIF
45079 ENDIF
45080 DO 160 j=1,3
45081 p(nbe(ibe),j)=0d0
45082 v(nbe(ibe),j)=0d0
45083 160 CONTINUE
45084 p(nbe(ibe),5)=-1.0d0
45085 170 CONTINUE
45086 180 CONTINUE
45087 IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) GOTO 500
45088
45089C...Calculate separation between W+ and W-
45090 sigw=parj(93)
45091 IF(iwp.GT.0.AND.iwn.GT.0.AND.mstj(56).GT.0) THEN
45092 dmw=pmas(24,1)
45093 dgw=pmas(24,2)
45094 dmp=p(iwp,5)
45095 dmn=p(iwn,5)
45096 taupd=dmp/sqrt((dmp**2-dmw**2)**2+(dgw*(dmp**2)/dmw)**2)
45097 taund=dmn/sqrt((dmn**2-dmw**2)**2+(dgw*(dmn**2)/dmw)**2)
45098 taup=-taupd*log(pyr(idum))
45099 taun=-taund*log(pyr(idum))
45100 dxp=taup*pyp(iwp,8)/dmp
45101 dxn=taun*pyp(iwn,8)/dmn
45102 dx=dxp+dxn
45103 sigw=1.0d0/(1.0d0/parj(93)+real(mstj(56))*dx)
45104 ELSE
45105 sigw=parj(93)
45106 ENDIF
45107
45108 IF(mstj(57).EQ.1.AND.mstj(54).LT.0) THEN
45109 DO 210 ibe=1,min(9,mstj(52))
45110 DO 200 i1m=nbe(ibe-1)+1,nbe(ibe)-1
45111 q2min=pecm**2
45112 i1=k(i1m,1)
45113 DO 190 i2m=nbe(ibe-1)+1,nbe(ibe)-1
45114 IF(i2m.EQ.i1m) GOTO 190
45115 i2=k(i2m,1)
45116 q2=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-
45117 & (p(i1,2)+p(i2,2))**2-(p(i1,3)+p(i2,3))**2-
45118 & (p(i1,5)+p(i2,5))**2
45119 IF(q2.GT.0.0d0.AND.q2.LT.q2min) THEN
45120 q2min=q2
45121 ENDIF
45122 190 CONTINUE
45123 p(i1m,5)=q2min
45124 200 CONTINUE
45125 210 CONTINUE
45126 ENDIF
45127
45128C...Tabulate integral for subsequent momentum shift.
45129 DO 390 ibe=1,min(9,mstj(52))
45130 IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) GOTO 260
45131 IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
45132 & .LE.1) GOTO 260
45133 IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
45134 & nbe(7)-nbe(6)).LE.1) GOTO 260
45135 IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) GOTO 260
45136 IF(ibe.EQ.1) pmhq=2d0*pymass(211)
45137 IF(ibe.EQ.4) pmhq=2d0*pymass(321)
45138 IF(ibe.EQ.8) pmhq=2d0*pymass(221)
45139 IF(ibe.EQ.9) pmhq=2d0*pymass(331)
45140 qdel=0.1d0*min(pmhq,parj(93))
45141 qdel3=0.1d0*min(pmhq,parj(93)*3.0d0)
45142 qdelw=0.1d0*min(pmhq,sigw)
45143 qdel3w=0.1d0*min(pmhq,sigw*3.0d0)
45144 IF(mstj(51).EQ.1) THEN
45145 nbin=min(100,nint(9d0*parj(93)/qdel))
45146 nbin3=min(100,nint(27d0*parj(93)/qdel3))
45147 nbinw=min(100,nint(9d0*sigw/qdelw))
45148 nbin3w=min(100,nint(27d0*sigw/qdel3w))
45149 beex=exp(0.5d0*qdel/parj(93))
45150 beex3=exp(0.5d0*qdel3/(3.0d0*parj(93)))
45151 beexw=exp(0.5d0*qdelw/sigw)
45152 beex3w=exp(0.5d0*qdel3w/(3.0d0*sigw))
45153 bert=exp(-qdel/parj(93))
45154 bert3=exp(-qdel3/(3.0d0*parj(93)))
45155 bertw=exp(-qdelw/sigw)
45156 bert3w=exp(-qdel3w/(3.0d0*sigw))
45157 ELSE
45158 nbin=min(100,nint(3d0*parj(93)/qdel))
45159 nbin3=min(100,nint(9d0*parj(93)/qdel3))
45160 nbinw=min(100,nint(3d0*sigw/qdelw))
45161 nbin3w=min(100,nint(9d0*sigw/qdel3w))
45162 ENDIF
45163 DO 220 ibin=1,nbin
45164 qbin=qdel*(ibin-0.5d0)
45165 bei(ibin)=qdel*(qbin**2+qdel**2/12d0)/sqrt(qbin**2+pmhq**2)
45166 IF(mstj(51).EQ.1) THEN
45167 beex=beex*bert
45168 bei(ibin)=bei(ibin)*beex
45169 ELSE
45170 bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
45171 ENDIF
45172 IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
45173 220 CONTINUE
45174 DO 230 ibin=1,nbin3
45175 qbin=qdel3*(ibin-0.5d0)
45176 bei3(ibin)=qdel3*(qbin**2+qdel3**2/12d0)/sqrt(qbin**2+pmhq**2)
45177 IF(mstj(51).EQ.1) THEN
45178 beex3=beex3*bert3
45179 bei3(ibin)=bei3(ibin)*beex3
45180 ELSE
45181 bei3(ibin)=bei3(ibin)*exp(-(qbin/(3.0d0*parj(93)))**2)
45182 ENDIF
45183 IF(ibin.GE.2) bei3(ibin)=bei3(ibin)+bei3(ibin-1)
45184 230 CONTINUE
45185 DO 240 ibin=1,nbinw
45186 qbin=qdelw*(ibin-0.5d0)
45187 beiw(ibin)=qdelw*(qbin**2+qdelw**2/12d0)/sqrt(qbin**2+pmhq**2)
45188 IF(mstj(51).EQ.1) THEN
45189 beexw=beexw*bertw
45190 beiw(ibin)=beiw(ibin)*beexw
45191 ELSE
45192 beiw(ibin)=beiw(ibin)*exp(-(qbin/sigw)**2)
45193 ENDIF
45194 IF(ibin.GE.2) beiw(ibin)=beiw(ibin)+beiw(ibin-1)
45195 240 CONTINUE
45196 DO 250 ibin=1,nbin3w
45197 qbin=qdel3w*(ibin-0.5d0)
45198 bei3w(ibin)=qdel3w*(qbin**2+qdel3w**2/12d0)/
45199 & sqrt(qbin**2+pmhq**2)
45200 IF(mstj(51).EQ.1) THEN
45201 beex3w=beex3w*bert3w
45202 bei3w(ibin)=bei3w(ibin)*beex3w
45203 ELSE
45204 bei3w(ibin)=bei3w(ibin)*exp(-(qbin/(3.0d0*sigw))**2)
45205 ENDIF
45206 IF(ibin.GE.2) bei3w(ibin)=bei3w(ibin)+bei3w(ibin-1)
45207 250 CONTINUE
45208
45209C...Loop through particle pairs and find old relative momentum.
45210 260 DO 380 i1m=nbe(ibe-1)+1,nbe(ibe)-1
45211 i1=k(i1m,1)
45212 DO 370 i2m=i1m+1,nbe(ibe)
45213 IF(mstj(53).EQ.1.AND.k(i1m,5).NE.k(i2m,5)) GOTO 370
45214 IF(mstj(53).EQ.2.AND.k(i1m,5).EQ.k(i2m,5)) GOTO 370
45215 i2=k(i2m,1)
45216 q2old=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
45217 & p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2
45218 IF(q2old.LE.0.0d0) GOTO 370
45219 qold=sqrt(q2old)
45220
45221C...Calculate new relative momentum.
45222 qmov=0.0d0
45223 qmov3=0.0d0
45224 qmovw=0.0d0
45225 qmov3w=0.0d0
45226 IF(qold.LT.1d-3*qdel) THEN
45227 GOTO 270
45228 ELSEIF(qold.LE.qdel) THEN
45229 qmov=qold/3d0
45230 ELSEIF(qold.LT.(nbin-0.1d0)*qdel) THEN
45231 rbin=qold/qdel
45232 ibin=rbin
45233 rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
45234 qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
45235 & sqrt(q2old+pmhq**2)/q2old
45236 ELSE
45237 qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
45238 ENDIF
45239 270 q2new=q2old*(qold/(qold+3d0*parj(92)*qmov))**(2d0/3d0)
45240 IF(qold.LT.1d-3*qdel3) THEN
45241 GOTO 280
45242 ELSEIF(qold.LE.qdel3) THEN
45243 qmov3=qold/3d0
45244 ELSEIF(qold.LT.(nbin3-0.1d0)*qdel3) THEN
45245 rbin3=qold/qdel3
45246 ibin3=rbin3
45247 rinp3=(rbin3**3-ibin3**3)/(3*ibin3*(ibin3+1)+1)
45248 qmov3=(bei3(ibin3)+rinp3*(bei3(ibin3+1)-bei3(ibin3)))*
45249 & sqrt(q2old+pmhq**2)/q2old
45250 ELSE
45251 qmov3=bei3(nbin3)*sqrt(q2old+pmhq**2)/q2old
45252 ENDIF
45253 280 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3))**(2d0/3d0)
45254 rscale=1.0d0
45255 IF(mstj(54).EQ.2)
45256 & rscale=1.0d0-exp(-(qold/(2d0*parj(93)))**2)
45257 IF(mstj(56).LE.0.OR.iwp.EQ.0.OR.iwn.EQ.0.OR.
45258 & k(i1m,5).EQ.k(i2m,5)) GOTO 310
45259
45260 IF(qold.LT.1d-3*qdelw) THEN
45261 GOTO 290
45262 ELSEIF(qold.LE.qdelw) THEN
45263 qmovw=qold/3d0
45264 ELSEIF(qold.LT.(nbinw-0.1d0)*qdelw) THEN
45265 rbinw=qold/qdelw
45266 ibinw=rbinw
45267 rinpw=(rbinw**3-ibinw**3)/(3*ibinw*(ibinw+1)+1)
45268 qmovw=(beiw(ibinw)+rinpw*(beiw(ibinw+1)-beiw(ibinw)))*
45269 & sqrt(q2old+pmhq**2)/q2old
45270 ELSE
45271 qmovw=beiw(nbinw)*sqrt(q2old+pmhq**2)/q2old
45272 ENDIF
45273 290 q2new=q2old*(qold/(qold+3d0*parj(92)*qmovw))**(2d0/3d0)
45274 IF(qold.LT.1d-3*qdel3w) THEN
45275 GOTO 300
45276 ELSEIF(qold.LE.qdel3w) THEN
45277 qmov3w=qold/3d0
45278 ELSEIF(qold.LT.(nbin3w-0.1d0)*qdel3w) THEN
45279 rbin3w=qold/qdel3w
45280 ibin3w=rbin3w
45281 rinp3w=(rbin3w**3-ibin3w**3)/(3*ibin3w*(ibin3w+1)+1)
45282 qmov3w=(bei3w(ibin3w)+rinp3w*(bei3w(ibin3w+1)-
45283 & bei3w(ibin3w)))*sqrt(q2old+pmhq**2)/q2old
45284 ELSE
45285 qmov3w=bei3w(nbin3w)*sqrt(q2old+pmhq**2)/q2old
45286 ENDIF
45287 300 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3w))**(2d0/3d0)
45288 IF(mstj(54).EQ.2)
45289 & rscale=1.0d0-exp(-(qold/(2d0*sigw))**2)
45290
45291 310 CALL pybesq(i1,i2,nmax,q2old,q2new)
45292 DO 320 j=1,3
45293 p(i1m,j)=p(i1m,j)+p(nmax+1,j)
45294 p(i2m,j)=p(i2m,j)+p(nmax+2,j)
45295 320 CONTINUE
45296 IF(mstj(54).GE.1) THEN
45297 CALL pybesq(i1,i2,nmax,q2old,q2new3)
45298 DO 330 j=1,3
45299 v(i1m,j)=v(i1m,j)+p(nmax+1,j)*rscale
45300 v(i2m,j)=v(i2m,j)+p(nmax+2,j)*rscale
45301 330 CONTINUE
45302 ELSEIF(mstj(54).LE.-1) THEN
45303 edel=p(i1,4)+p(i2,4)-
45304 & sqrt(max(q2new-q2old+(p(i1,4)+p(i2,4))**2,0.0d0))
45305 a2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
45306 & (p(i1,3)-p(i2,3))**2
45307 wmax=-1.0d20
45308 mi3=0
45309 mi4=0
45310 s12=sdip(i1,i2)
45311 sm1=(p(i1,5)+smmin)**2
45312 DO 350 i3m=nbe(0)+1,nbe(min(10,mstj(52)+1))
45313 IF(i3m.EQ.i1m.OR.i3m.EQ.i2m) GOTO 350
45314 IF(mstj(53).EQ.1.AND.k(i3m,5).NE.k(i1m,5)) GOTO 350
45315 IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
45316 & k(i3m,5).NE.k(i1m,5)) GOTO 350
45317 i3=k(i3m,1)
45318 IF(k(i3,2).EQ.k(i1,2)) GOTO 350
45319 s13=sdip(i1,i3)
45320 s23=sdip(i2,i3)
45321 sm3=(p(i3,5)+smmin)**2
45322 IF(mstj(54).EQ.-2) THEN
45323 wi=(min(s12*sm3,s13*min(sm1,sm3),
45324 & s23*min(sm1,sm3))*sm1)
45325 ELSE
45326 wi=((p(i1,4)+p(i2,4)+p(i3,4))**2-
45327 & (p(i1,3)+p(i2,3)+p(i3,3))**2-
45328 & (p(i1,2)+p(i2,2)+p(i3,2))**2-
45329 & (p(i1,1)+p(i2,1)+p(i3,1))**2)
45330 ENDIF
45331 IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0) THEN
45332 IF (wmax*wi.GE.(1.0d0-exp(-p(i3m,5)/(parj(93)**2))))
45333 & GOTO 350
45334 ELSE
45335 IF(wmax*wi.GE.1.0) GOTO 350
45336 ENDIF
45337 DO 340 i4m=i3m+1,nbe(min(10,mstj(52)+1))
45338 IF(i4m.EQ.i1m.OR.i4m.EQ.i2m) GOTO 340
45339 IF(mstj(53).EQ.1.AND.k(i4m,5).NE.k(i1m,5)) GOTO 340
45340 IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
45341 & k(i4m,5).NE.k(i1m,5)) GOTO 340
45342 i4=k(i4m,1)
45343 IF(k(i3,2).EQ.k(i4,2).OR.k(i4,2).EQ.k(i1,2))
45344 & GOTO 340
45345 IF((p(i3,4)+p(i4,4)+edel)**2.LT.
45346 & (p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
45347 & (p(i3,3)+p(i4,3))**2+(p(i3,5)+p(i4,5))**2)
45348 & GOTO 340
45349 IF(mstj(54).EQ.-2) THEN
45350 s14=sdip(i1,i4)
45351 s24=sdip(i2,i4)
45352 s34=sdip(i3,i4)
45353 w=s12*min(min(s23,s24),min(s13,s14))*s34
45354 w=min(w,s13*min(min(s23,s34),s12)*s24)
45355 w=min(w,s14*min(min(s24,s34),s12)*s23)
45356 w=min(w,min(s23,s24)*s13*s14)
45357 w=1.0d0/w
45358 ELSE
45359C...weight=1-cos(theta)/mtot2
45360 s1234=(p(i1,4)+p(i2,4)+p(i3,4)+p(i4,4))**2-
45361 & (p(i1,3)+p(i2,3)+p(i3,3)+p(i4,3))**2-
45362 & (p(i1,2)+p(i2,2)+p(i3,2)+p(i4,2))**2-
45363 & (p(i1,1)+p(i2,1)+p(i3,1)+p(i4,1))**2
45364 w=1.0d0/s1234
45365 IF(w.LE.wmax) GOTO 340
45366 ENDIF
45367 IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0)
45368 & w=w*(1.0d0-exp(-p(i3m,5)/(parj(93)**2)))
45369 IF(mstj(57).EQ.1.AND.p(i4m,5).GT.0)
45370 & w=w*(1.0d0-exp(-p(i4m,5)/(parj(93)**2)))
45371 IF(w.LE.wmax) GOTO 340
45372 mi3=i3m
45373 mi4=i4m
45374 wmax=w
45375 340 CONTINUE
45376 350 CONTINUE
45377 IF(mi4.EQ.0) GOTO 370
45378 i3=k(mi3,1)
45379 i4=k(mi4,1)
45380 eold=p(i3,4)+p(i4,4)
45381 enew=eold+edel
45382 p2=(p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
45383 & (p(i3,3)+p(i4,3))**2
45384 q2newp=max(0.0d0,enew**2-p2-(p(i3,5)+p(i4,5))**2)
45385 q2oldp=max(0.0d0,eold**2-p2-(p(i3,5)+p(i4,5))**2)
45386 CALL pybesq(i3,i4,nmax,q2oldp,q2newp)
45387 DO 360 j=1,3
45388 v(mi3,j)=v(mi3,j)+p(nmax+1,j)
45389 v(mi4,j)=v(mi4,j)+p(nmax+2,j)
45390 360 CONTINUE
45391 ENDIF
45392 370 CONTINUE
45393 380 CONTINUE
45394 390 CONTINUE
45395
45396C...Shift momenta and recalculate energies.
45397 esump=0.0d0
45398 esum=0.0d0
45399 prod=0.0d0
45400 DO 420 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
45401 i=k(im,1)
45402 esump=esump+p(i,4)
45403 DO 400 j=1,3
45404 p(i,j)=p(i,j)+p(im,j)
45405 400 CONTINUE
45406 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
45407 esum=esum+p(i,4)
45408 DO 410 j=1,3
45409 prod=prod+v(im,j)*p(i,j)/p(i,4)
45410 410 CONTINUE
45411 420 CONTINUE
45412
45413 parj(96)=0.0d0
45414 IF(mstj(54).NE.0.AND.prod.NE.0.0d0) THEN
45415 430 alpha=(esump-esum)/prod
45416 parj(96)=parj(96)+alpha
45417 prod=0.0d0
45418 esum=0.0d0
45419 DO 460 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
45420 i=k(im,1)
45421 DO 440 j=1,3
45422 p(i,j)=p(i,j)+alpha*v(im,j)
45423 440 CONTINUE
45424 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
45425 esum=esum+p(i,4)
45426 DO 450 j=1,3
45427 prod=prod+v(im,j)*p(i,j)/p(i,4)
45428 450 CONTINUE
45429 460 CONTINUE
45430 IF(prod.NE.0.0d0.AND.abs(esump-esum)/pecm.GT.0.00001d0)
45431 & GOTO 430
45432 ENDIF
45433
45434C...Rescale all momenta for energy conservation.
45435 pes=0d0
45436 pqs=0d0
45437 DO 470 i=1,n
45438 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 470
45439 pes=pes+p(i,4)
45440 pqs=pqs+p(i,5)**2/p(i,4)
45441 470 CONTINUE
45442 parj(95)=pes-pecm
45443 fac=(pecm-pqs)/(pes-pqs)
45444 DO 490 i=1,n
45445 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 490
45446 DO 480 j=1,3
45447 p(i,j)=fac*p(i,j)
45448 480 CONTINUE
45449 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
45450 490 CONTINUE
45451
45452C...Boost back to correct reference frame.
45453 500 CALL pyrobo(0,0,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
45454 DO 510 i=1,n
45455 IF(k(i,1).LT.0) k(i,1)=-k(i,1)
45456 510 CONTINUE
45457
45458 RETURN
45459 END
45460
45461C*********************************************************************
45462
45463C...PYBESQ
45464C...Calculates the momentum shift in a system of two particles assuming
45465C...the relative momentum squared should be shifted to Q2NEW. NI is the
45466C...last position occupied in /PYJETS/.
45467
45468 SUBROUTINE pybesq(I1,I2,NI,Q2OLD,Q2NEW)
45469
45470C...Double precision and integer declarations.
45471 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45472 IMPLICIT INTEGER(I-N)
45473 INTEGER PYK,PYCHGE,PYCOMP
45474 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
45475C...Commonblocks.
45476 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
45477 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45478 SAVE /pyjets/,/pydat1/
45479C...Local arrays and data.
45480 dimension dp(5)
45481 SAVE hc1
45482
45483 IF(mstj(55).EQ.0) THEN
45484 dq2=q2new-q2old
45485 dp2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
45486 & (p(i1,3)-p(i2,3))**2
45487 dp12=p(i1,1)**2+p(i1,2)**2+p(i1,3)**2
45488 & -p(i2,1)**2-p(i2,2)**2-p(i2,3)**2
45489 se=p(i1,4)+p(i2,4)
45490 de=p(i1,4)-p(i2,4)
45491 dq2se=dq2+se**2
45492 da=se*de*dp12-dp2*dq2se
45493 db=dp2*dq2se-dp12**2
45494 ha=(da+sqrt(max(da**2+dq2*(dq2+se**2-de**2)*db,0d0)))/(2d0*db)
45495 DO 100 j=1,3
45496 pd=ha*(p(i1,j)-p(i2,j))
45497 p(ni+1,j)=pd
45498 p(ni+2,j)=-pd
45499 100 CONTINUE
45500 RETURN
45501 ENDIF
45502
45503 k(ni+1,1)=1
45504 k(ni+2,1)=1
45505 DO 110 j=1,5
45506 p(ni+1,j)=p(i1,j)
45507 p(ni+2,j)=p(i2,j)
45508 dp(j)=p(i1,j)+p(i2,j)
45509 110 CONTINUE
45510
45511C...Boost to cms and rotate first particle to z-axis
45512 CALL pyrobo(ni+1,ni+2,0.0d0,0.0d0,
45513 &-dp(1)/dp(4),-dp(2)/dp(4),-dp(3)/dp(4))
45514 phi=pyangl(p(ni+1,1),p(ni+1,2))
45515 the=pyangl(p(ni+1,3),sqrt(p(ni+1,1)**2+p(ni+1,2)**2))
45516 s=q2new+(p(i1,5)+p(i2,5))**2
45517 pz=0.5d0*sqrt(q2new*(s-(p(i1,5)-p(i2,5))**2)/s)
45518 p(ni+1,1)=0.0d0
45519 p(ni+1,2)=0.0d0
45520 p(ni+1,3)=pz
45521 p(ni+1,4)=sqrt(pz**2+p(i1,5)**2)
45522 p(ni+2,1)=0.0d0
45523 p(ni+2,2)=0.0d0
45524 p(ni+2,3)=-pz
45525 p(ni+2,4)=sqrt(pz**2+p(i2,5)**2)
45526 dp(4)=sqrt(dp(1)**2+dp(2)**2+dp(3)**2+s)
45527 CALL pyrobo(ni+1,ni+2,the,phi,
45528 &dp(1)/dp(4),dp(2)/dp(4),dp(3)/dp(4))
45529
45530 DO 120 j=1,3
45531 p(ni+1,j)=p(ni+1,j)-p(i1,j)
45532 p(ni+2,j)=p(ni+2,j)-p(i2,j)
45533 120 CONTINUE
45534
45535 RETURN
45536 END
45537
45538C*********************************************************************
45539
45540C...PYMASS
45541C...Gives the mass of a particle/parton.
45542
45543 FUNCTION pymass(KF)
45544
45545C...Double precision and integer declarations.
45546 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45547 IMPLICIT INTEGER(I-N)
45548 INTEGER PYK,PYCHGE,PYCOMP
45549C...Commonblocks.
45550 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45551 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45552 SAVE /pydat1/,/pydat2/
45553
45554C...Reset variables. Compressed code. Special case for popcorn diquarks.
45555 pymass=0d0
45556 kfa=iabs(kf)
45557 kc=pycomp(kf)
45558 IF(kc.EQ.0) THEN
45559 mstj(93)=0
45560 RETURN
45561 ENDIF
45562
45563C...Guarantee use of constituent masses for internal checks.
45564 IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.
45565 &(kfa.LE.10.OR.mod(kfa/10,10).EQ.0)) THEN
45566 parf(106)=pmas(6,1)
45567 parf(107)=pmas(7,1)
45568 parf(108)=pmas(8,1)
45569 IF(kfa.LE.10) THEN
45570 pymass=parf(100+kfa)
45571 IF(mstj(93).EQ.2) pymass=max(0d0,pymass-parf(121))
45572 ELSEIF(mstj(93).EQ.1) THEN
45573 pymass=parf(100+mod(kfa/1000,10))+parf(100+mod(kfa/100,10))
45574 ELSE
45575 pymass=max(0d0,pmas(kc,1)-parf(122)-2d0*parf(112)/3d0)
45576 ENDIF
45577
45578C...Other masses can be read directly off table.
45579 ELSE
45580 pymass=pmas(kc,1)
45581 ENDIF
45582
45583C...Optional mass broadening according to truncated Breit-Wigner
45584C...(either in m or in m^2).
45585 IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1d-4) THEN
45586 IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
45587 pymass=pymass+0.5d0*pmas(kc,2)*tan((2d0*pyr(0)-1d0)*
45588 & atan(2d0*pmas(kc,3)/pmas(kc,2)))
45589 ELSE
45590 pm0=pymass
45591 pmlow=atan((max(0d0,pm0-pmas(kc,3))**2-pm0**2)/
45592 & (pm0*pmas(kc,2)))
45593 pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
45594 pymass=sqrt(max(0d0,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
45595 & (pmupp-pmlow)*pyr(0))))
45596 ENDIF
45597 ENDIF
45598 mstj(93)=0
45599
45600 RETURN
45601 END
45602
45603C*********************************************************************
45604
45605C...PYMRUN
45606C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
45607C...for Higgs couplings. Everything else sent on to PYMASS.
45608
45609 FUNCTION pymrun(KF,Q2)
45610
45611C...Double precision and integer declarations.
45612 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45613 IMPLICIT INTEGER(I-N)
45614 INTEGER PYK,PYCHGE,PYCOMP
45615C...Commonblocks.
45616 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45617 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45618 common/pypars/mstp(200),parp(200),msti(200),pari(200)
45619 SAVE /pydat1/,/pydat2/,/pypars/
45620
45621C...Most masses not handled here.
45622 kfa=iabs(kf)
45623 IF(kfa.EQ.0.OR.kfa.GT.5) THEN
45624 pymrun=pymass(kf)
45625
45626C...Current-algebra masses, but no Q2 dependence.
45627 ELSEIF(mstp(37).NE.1.OR.mstp(2).LE.0) THEN
45628 pymrun=parf(90+kfa)
45629
45630C...Running current-algebra masses.
45631 ELSE
45632 as=pyalps(q2)
45633 pymrun=parf(90+kfa)*
45634 & (log(max(4d0,parp(37)**2*parf(90+kfa)**2/paru(117)**2))/
45635 & log(max(4d0,q2/paru(117)**2)))**(12d0/(33d0-2d0*mstu(118)))
45636 ENDIF
45637
45638 RETURN
45639 END
45640
45641C*********************************************************************
45642
45643C...PYNAME
45644C...Gives the particle/parton name as a character string.
45645
45646 SUBROUTINE pyname(KF,CHAU)
45647
45648C...Double precision and integer declarations.
45649 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45650 IMPLICIT INTEGER(I-N)
45651 INTEGER PYK,PYCHGE,PYCOMP
45652C...Commonblocks.
45653 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45654 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45655 common/pydat4/chaf(500,2)
45656 CHARACTER CHAF*16
45657 SAVE /pydat1/,/pydat2/,/pydat4/
45658C...Local character variable.
45659 CHARACTER CHAU*16
45660
45661C...Read out code with distinction particle/antiparticle.
45662 chau=' '
45663 kc=pycomp(kf)
45664 IF(kc.NE.0) chau=chaf(kc,(3-isign(1,kf))/2)
45665
45666
45667 RETURN
45668 END
45669
45670C*********************************************************************
45671
45672C...PYCHGE
45673C...Gives three times the charge for a particle/parton.
45674
45675 FUNCTION pychge(KF)
45676
45677C...Double precision and integer declarations.
45678 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45679 IMPLICIT INTEGER(I-N)
45680 INTEGER PYK,PYCHGE,PYCOMP
45681C...Commonblocks.
45682 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45683 SAVE /pydat2/
45684
45685C...Read out charge and change sign for antiparticle.
45686 pychge=0
45687 kc=pycomp(kf)
45688 IF(kc.NE.0) pychge=kchg(kc,1)*isign(1,kf)
45689
45690 RETURN
45691 END
45692
45693C*********************************************************************
45694
45695C...PYCOMP
45696C...Compress the standard KF codes for use in mass and decay arrays;
45697C...also checks whether a given code actually is defined.
45698
45699 FUNCTION pycomp(KF)
45700
45701C...Double precision and integer declarations.
45702 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45703 IMPLICIT INTEGER(I-N)
45704 INTEGER PYK,PYCHGE,PYCOMP
45705C...Commonblocks.
45706 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45707 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45708 SAVE /pydat1/,/pydat2/
45709C...Local arrays and saved data.
45710 dimension kford(100:500),kcord(101:500)
45711 SAVE kford,kcord,nford,kflast,kclast
45712
45713C...Whenever necessary reorder codes for faster search.
45714 IF(mstu(20).EQ.0) THEN
45715 nford=100
45716 kford(100)=0
45717 DO 120 i=101,500
45718 kfa=kchg(i,4)
45719 IF(kfa.LE.100) GOTO 120
45720 nford=nford+1
45721 DO 100 i1=nford-1,0,-1
45722 IF(kfa.GE.kford(i1)) GOTO 110
45723 kford(i1+1)=kford(i1)
45724 kcord(i1+1)=kcord(i1)
45725 100 CONTINUE
45726 110 kford(i1+1)=kfa
45727 kcord(i1+1)=i
45728 120 CONTINUE
45729 mstu(20)=1
45730 kflast=0
45731 kclast=0
45732 ENDIF
45733
45734C...Fast action if same code as in latest call.
45735 IF(kf.EQ.kflast) THEN
45736 pycomp=kclast
45737 RETURN
45738 ENDIF
45739
45740C...Starting values. Remove internal diquark flags.
45741 pycomp=0
45742 kfa=iabs(kf)
45743 IF(mod(kfa/10,10).EQ.0.AND.kfa.LT.100000
45744 & .AND.mod(kfa/1000,10).GT.0) kfa=mod(kfa,10000)
45745
45746C...Simple cases: direct translation.
45747 IF(kfa.GT.kford(nford)) THEN
45748 ELSEIF(kfa.LE.100) THEN
45749 pycomp=kfa
45750
45751C...Else binary search.
45752 ELSE
45753 imin=100
45754 imax=nford+1
45755 130 iavg=(imin+imax)/2
45756 IF(kford(iavg).GT.kfa) THEN
45757 imax=iavg
45758 IF(imax.GT.imin+1) GOTO 130
45759 ELSEIF(kford(iavg).LT.kfa) THEN
45760 imin=iavg
45761 IF(imax.GT.imin+1) GOTO 130
45762 ELSE
45763 pycomp=kcord(iavg)
45764 ENDIF
45765 ENDIF
45766
45767C...Check if antiparticle allowed.
45768 IF(pycomp.NE.0.AND.kf.LT.0) THEN
45769 IF(kchg(pycomp,3).EQ.0) pycomp=0
45770 ENDIF
45771
45772C...Save codes for possible future fast action.
45773 kflast=kf
45774 kclast=pycomp
45775
45776 RETURN
45777 END
45778
45779C*********************************************************************
45780
45781C...PYERRM
45782C...Informs user of errors in program execution.
45783
45784 SUBROUTINE pyerrm(MERR,CHMESS)
45785
45786C...Double precision and integer declarations.
45787 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45788 IMPLICIT INTEGER(I-N)
45789 INTEGER PYK,PYCHGE,PYCOMP
45790C...Commonblocks.
45791 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
45792 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45793 SAVE /pyjets/,/pydat1/
45794C...Local character variable.
45795 CHARACTER CHMESS*(*)
45796
45797C...Write first few warnings, then be silent.
45798 IF(merr.LE.10) THEN
45799 mstu(27)=mstu(27)+1
45800 mstu(28)=merr
45801 IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
45802 & merr,mstu(31),chmess
45803
45804C...Write first few errors, then be silent or stop program.
45805 ELSEIF(merr.LE.20) THEN
45806 mstu(23)=mstu(23)+1
45807 mstu(24)=merr-10
45808 IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
45809 & merr-10,mstu(31),chmess
45810 IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
45811 WRITE(mstu(11),5100) merr-10,mstu(31),chmess
45812 WRITE(mstu(11),5200)
45813 IF(merr.NE.17) CALL pylist(2)
45814 stop
45815 ENDIF
45816
45817C...Stop program in case of irreparable error.
45818 ELSE
45819 WRITE(mstu(11),5300) merr-20,mstu(31),chmess
45820 stop
45821 ENDIF
45822
45823C...Formats for output.
45824 5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i9,
45825 &' PYEXEC calls:'/5x,a)
45826 5100 FORMAT(/5x,'Error type',i2,' has occured after',i9,
45827 &' PYEXEC calls:'/5x,a)
45828 5200 FORMAT(5x,'Execution will be stopped after listing of last ',
45829 &'event!')
45830 5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i9,
45831 &' PYEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
45832
45833 RETURN
45834 END
45835
45836C*********************************************************************
45837
45838C...PYALEM
45839C...Calculates the running alpha_electromagnetic.
45840
45841 FUNCTION pyalem(Q2)
45842
45843C...Double precision and integer declarations.
45844 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45845 IMPLICIT INTEGER(I-N)
45846 INTEGER PYK,PYCHGE,PYCOMP
45847C...Commonblocks.
45848 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45849 SAVE /pydat1/
45850
45851C...Calculate real part of photon vacuum polarization.
45852C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
45853C...For hadrons use parametrization of H. Burkhardt et al.
45854C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
45855 aempi=paru(101)/(3d0*paru(1))
45856 IF(mstu(101).LE.0.OR.q2.LT.2d-6) THEN
45857 rpigg=0d0
45858 ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
45859 rpigg=0d0
45860 ELSEIF(mstu(101).EQ.2) THEN
45861 rpigg=1d0-paru(101)/paru(103)
45862 ELSEIF(q2.LT.0.09d0) THEN
45863 rpigg=aempi*(13.4916d0+log(q2))+0.00835d0*log(1d0+q2)
45864 ELSEIF(q2.LT.9d0) THEN
45865 rpigg=aempi*(16.3200d0+2d0*log(q2))+
45866 & 0.00238d0*log(1d0+3.927d0*q2)
45867 ELSEIF(q2.LT.1d4) THEN
45868 rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00165d0+
45869 & 0.00299d0*log(1d0+q2)
45870 ELSE
45871 rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00221d0+
45872 & 0.00293d0*log(1d0+q2)
45873 ENDIF
45874
45875C...Calculate running alpha_em.
45876 pyalem=paru(101)/(1d0-rpigg)
45877 paru(108)=pyalem
45878
45879 RETURN
45880 END
45881
45882C*********************************************************************
45883
45884C...PYALPS
45885C...Gives the value of alpha_strong.
45886
45887 FUNCTION pyalps(Q2)
45888
45889C...Double precision and integer declarations.
45890 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45891 IMPLICIT INTEGER(I-N)
45892 INTEGER PYK,PYCHGE,PYCOMP
45893C...Commonblocks.
45894 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45895 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45896 SAVE /pydat1/,/pydat2/
45897
45898C...Constant alpha_strong trivial. Pick artificial Lambda.
45899 IF(mstu(111).LE.0) THEN
45900 pyalps=paru(111)
45901 mstu(118)=mstu(112)
45902 paru(117)=0.2d0
45903 IF(q2.GT.0.04d0) paru(117)=sqrt(q2)*exp(-6d0*paru(1)/
45904 & ((33d0-2d0*mstu(112))*paru(111)))
45905 paru(118)=paru(111)
45906 RETURN
45907 ENDIF
45908
45909C...Find effective Q2, number of flavours and Lambda.
45910 q2eff=q2
45911 IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
45912 nf=mstu(112)
45913 alam2=paru(112)**2
45914 100 IF(nf.GT.max(2,mstu(113))) THEN
45915 q2thr=paru(113)*pmas(nf,1)**2
45916 IF(q2eff.LT.q2thr) THEN
45917 nf=nf-1
45918 alam2=alam2*(q2thr/alam2)**(2d0/(33d0-2d0*nf))
45919 GOTO 100
45920 ENDIF
45921 ENDIF
45922 110 IF(nf.LT.min(8,mstu(114))) THEN
45923 q2thr=paru(113)*pmas(nf+1,1)**2
45924 IF(q2eff.GT.q2thr) THEN
45925 nf=nf+1
45926 alam2=alam2*(alam2/q2thr)**(2d0/(33d0-2d0*nf))
45927 GOTO 110
45928 ENDIF
45929 ENDIF
45930 IF(mstu(115).EQ.1) q2eff=q2eff+alam2
45931 paru(117)=sqrt(alam2)
45932
45933C...Evaluate first or second order alpha_strong.
45934 b0=(33d0-2d0*nf)/6d0
45935 algq=log(max(1.0001d0,q2eff/alam2))
45936 IF(mstu(111).EQ.1) THEN
45937 pyalps=min(paru(115),paru(2)/(b0*algq))
45938 ELSE
45939 b1=(153d0-19d0*nf)/6d0
45940 pyalps=min(paru(115),paru(2)/(b0*algq)*(1d0-b1*log(algq)/
45941 & (b0**2*algq)))
45942 ENDIF
45943 mstu(118)=nf
45944 paru(118)=pyalps
45945
45946 RETURN
45947 END
45948
45949C*********************************************************************
45950
45951C...PYANGL
45952C...Reconstructs an angle from given x and y coordinates.
45953
45954 FUNCTION pyangl(X,Y)
45955
45956C...Double precision and integer declarations.
45957 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45958 IMPLICIT INTEGER(I-N)
45959 INTEGER PYK,PYCHGE,PYCOMP
45960C...Commonblocks.
45961 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45962 SAVE /pydat1/
45963
45964 pyangl=0d0
45965 r=sqrt(x**2+y**2)
45966 IF(r.LT.1d-20) RETURN
45967 IF(abs(x)/r.LT.0.8d0) THEN
45968 pyangl=sign(acos(x/r),y)
45969 ELSE
45970 pyangl=asin(y/r)
45971 IF(x.LT.0d0.AND.pyangl.GE.0d0) THEN
45972 pyangl=paru(1)-pyangl
45973 ELSEIF(x.LT.0d0) THEN
45974 pyangl=-paru(1)-pyangl
45975 ENDIF
45976 ENDIF
45977
45978 RETURN
45979 END
45980
45981C*********************************************************************
45982
45983C...PYR
45984C...Generates random numbers uniformly distributed between
45985C...0 and 1, excluding the endpoints.
45986
45987 FUNCTION pyr(IDUMMY)
45988
45989C...Double precision and integer declarations.
45990 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45991 IMPLICIT INTEGER(I-N)
45992 INTEGER PYK,PYCHGE,PYCOMP
45993C...Commonblocks.
45994 common/pydatr/mrpy(6),rrpy(100)
45995 SAVE /pydatr/
45996C...Equivalence between commonblock and local variables.
45997 equivalence(mrpy1,mrpy(1)),(mrpy2,mrpy(2)),(mrpy3,mrpy(3)),
45998 &(mrpy4,mrpy(4)),(mrpy5,mrpy(5)),(mrpy6,mrpy(6)),
45999 &(rrpy98,rrpy(98)),(rrpy99,rrpy(99)),(rrpy00,rrpy(100))
46000
46001C...Initialize generation from given seed.
46002 IF(mrpy2.EQ.0) THEN
46003 ij=mod(mrpy1/30082,31329)
46004 kl=mod(mrpy1,30082)
46005 i=mod(ij/177,177)+2
46006 j=mod(ij,177)+2
46007 k=mod(kl/169,178)+1
46008 l=mod(kl,169)
46009 DO 110 ii=1,97
46010 s=0d0
46011 t=0.5d0
46012 DO 100 jj=1,48
46013 m=mod(mod(i*j,179)*k,179)
46014 i=j
46015 j=k
46016 k=m
46017 l=mod(53*l+1,169)
46018 IF(mod(l*m,64).GE.32) s=s+t
46019 t=0.5d0*t
46020 100 CONTINUE
46021 rrpy(ii)=s
46022 110 CONTINUE
46023 twom24=1d0
46024 DO 120 i24=1,24
46025 twom24=0.5d0*twom24
46026 120 CONTINUE
46027 rrpy98=362436d0*twom24
46028 rrpy99=7654321d0*twom24
46029 rrpy00=16777213d0*twom24
46030 mrpy2=1
46031 mrpy3=0
46032 mrpy4=97
46033 mrpy5=33
46034 ENDIF
46035
46036C...Generate next random number.
46037 130 runi=rrpy(mrpy4)-rrpy(mrpy5)
46038 IF(runi.LT.0d0) runi=runi+1d0
46039 rrpy(mrpy4)=runi
46040 mrpy4=mrpy4-1
46041 IF(mrpy4.EQ.0) mrpy4=97
46042 mrpy5=mrpy5-1
46043 IF(mrpy5.EQ.0) mrpy5=97
46044 rrpy98=rrpy98-rrpy99
46045 IF(rrpy98.LT.0d0) rrpy98=rrpy98+rrpy00
46046 runi=runi-rrpy98
46047 IF(runi.LT.0d0) runi=runi+1d0
46048 IF(runi.LE.0d0.OR.runi.GE.1d0) GOTO 130
46049
46050C...Update counters. Random number to output.
46051 mrpy3=mrpy3+1
46052 IF(mrpy3.EQ.1000000000) THEN
46053 mrpy2=mrpy2+1
46054 mrpy3=0
46055 ENDIF
46056 pyr=runi
46057
46058 RETURN
46059 END
46060
46061C*********************************************************************
46062
46063C...PYRGET
46064C...Dumps the state of the random number generator on a file
46065C...for subsequent startup from this state onwards.
46066
46067 SUBROUTINE pyrget(LFN,MOVE)
46068
46069C...Double precision and integer declarations.
46070 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46071 IMPLICIT INTEGER(I-N)
46072 INTEGER PYK,PYCHGE,PYCOMP
46073C...Commonblocks.
46074 common/pydatr/mrpy(6),rrpy(100)
46075 SAVE /pydatr/
46076C...Local character variable.
46077 CHARACTER CHERR*8
46078
46079C...Backspace required number of records (or as many as there are).
46080 IF(move.LT.0) THEN
46081 nbck=min(mrpy(6),-move)
46082 DO 100 ibck=1,nbck
46083 backspace(lfn,err=110,iostat=ierr)
46084 100 CONTINUE
46085 mrpy(6)=mrpy(6)-nbck
46086 ENDIF
46087
46088C...Unformatted write on unit LFN.
46089 WRITE(lfn,err=110,iostat=ierr) (mrpy(i1),i1=1,5),
46090 &(rrpy(i2),i2=1,100)
46091 mrpy(6)=mrpy(6)+1
46092 RETURN
46093
46094C...Write error.
46095 110 WRITE(cherr,'(I8)') ierr
46096 CALL pyerrm(18,'(PYRGET:) error when accessing file, IOSTAT ='//
46097 &cherr)
46098
46099 RETURN
46100 END
46101
46102C*********************************************************************
46103
46104C...PYRSET
46105C...Reads a state of the random number generator from a file
46106C...for subsequent generation from this state onwards.
46107
46108 SUBROUTINE pyrset(LFN,MOVE)
46109
46110C...Double precision and integer declarations.
46111 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46112 IMPLICIT INTEGER(I-N)
46113 INTEGER PYK,PYCHGE,PYCOMP
46114C...Commonblocks.
46115 common/pydatr/mrpy(6),rrpy(100)
46116 SAVE /pydatr/
46117C...Local character variable.
46118 CHARACTER CHERR*8
46119
46120C...Backspace required number of records (or as many as there are).
46121 IF(move.LT.0) THEN
46122 nbck=min(mrpy(6),-move)
46123 DO 100 ibck=1,nbck
46124 backspace(lfn,err=120,iostat=ierr)
46125 100 CONTINUE
46126 mrpy(6)=mrpy(6)-nbck
46127 ENDIF
46128
46129C...Unformatted read from unit LFN.
46130 nfor=1+max(0,move)
46131 DO 110 ifor=1,nfor
46132 READ(lfn,err=120,iostat=ierr) (mrpy(i1),i1=1,5),
46133 & (rrpy(i2),i2=1,100)
46134 110 CONTINUE
46135 mrpy(6)=mrpy(6)+nfor
46136 RETURN
46137
46138C...Write error.
46139 120 WRITE(cherr,'(I8)') ierr
46140 CALL pyerrm(18,'(PYRSET:) error when accessing file, IOSTAT ='//
46141 &cherr)
46142
46143 RETURN
46144 END
46145
46146C*********************************************************************
46147
46148C...PYROBO
46149C...Performs rotations and boosts.
46150
46151 SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
46152
46153C...Double precision and integer declarations.
46154 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46155 IMPLICIT INTEGER(I-N)
46156 INTEGER PYK,PYCHGE,PYCOMP
46157C...Commonblocks.
46158 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
46159 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46160 SAVE /pyjets/,/pydat1/
46161C...Local arrays.
46162 dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
46163
46164C...Find and check range of rotation/boost.
46165 imin=imi
46166 IF(imin.LE.0) imin=1
46167 IF(mstu(1).GT.0) imin=mstu(1)
46168 imax=ima
46169 IF(imax.LE.0) imax=n
46170 IF(mstu(2).GT.0) imax=mstu(2)
46171 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
46172 CALL pyerrm(11,'(PYROBO:) range outside PYJETS memory')
46173 RETURN
46174 ENDIF
46175
46176C...Optional resetting of V (when not set before.)
46177 IF(mstu(33).NE.0) THEN
46178 DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
46179 DO 100 j=1,5
46180 v(i,j)=0d0
46181 100 CONTINUE
46182 110 CONTINUE
46183 mstu(33)=0
46184 ENDIF
46185
46186C...Rotate, typically from z axis to direction (theta,phi).
46187 IF(the**2+phi**2.GT.1d-20) THEN
46188 rot(1,1)=cos(the)*cos(phi)
46189 rot(1,2)=-sin(phi)
46190 rot(1,3)=sin(the)*cos(phi)
46191 rot(2,1)=cos(the)*sin(phi)
46192 rot(2,2)=cos(phi)
46193 rot(2,3)=sin(the)*sin(phi)
46194 rot(3,1)=-sin(the)
46195 rot(3,2)=0d0
46196 rot(3,3)=cos(the)
46197 DO 140 i=imin,imax
46198 IF(k(i,1).LE.0) GOTO 140
46199 DO 120 j=1,3
46200 pr(j)=p(i,j)
46201 vr(j)=v(i,j)
46202 120 CONTINUE
46203 DO 130 j=1,3
46204 p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
46205 v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
46206 130 CONTINUE
46207 140 CONTINUE
46208 ENDIF
46209
46210C...Boost, typically from rest to momentum/energy=beta.
46211 IF(bex**2+bey**2+bez**2.GT.1d-20) THEN
46212 dbx=bex
46213 dby=bey
46214 dbz=bez
46215 db=sqrt(dbx**2+dby**2+dbz**2)
46216 eps1=1d0-1d-12
46217 IF(db.GT.eps1) THEN
46218C...Rescale boost vector if too close to unity.
46219 CALL pyerrm(3,'(PYROBO:) boost vector too large')
46220 dbx=dbx*(eps1/db)
46221 dby=dby*(eps1/db)
46222 dbz=dbz*(eps1/db)
46223 db=eps1
46224 ENDIF
46225 dga=1d0/sqrt(1d0-db**2)
46226 DO 160 i=imin,imax
46227 IF(k(i,1).LE.0) GOTO 160
46228 DO 150 j=1,4
46229 dp(j)=p(i,j)
46230 dv(j)=v(i,j)
46231 150 CONTINUE
46232 dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
46233 dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
46234 p(i,1)=dp(1)+dgabp*dbx
46235 p(i,2)=dp(2)+dgabp*dby
46236 p(i,3)=dp(3)+dgabp*dbz
46237 p(i,4)=dga*(dp(4)+dbp)
46238 dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
46239 dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
46240 v(i,1)=dv(1)+dgabv*dbx
46241 v(i,2)=dv(2)+dgabv*dby
46242 v(i,3)=dv(3)+dgabv*dbz
46243 v(i,4)=dga*(dv(4)+dbv)
46244 160 CONTINUE
46245 ENDIF
46246
46247 RETURN
46248 END
46249
46250C*********************************************************************
46251
46252C...PYEDIT
46253C...Performs global manipulations on the event record, in particular
46254C...to exclude unstable or undetectable partons/particles.
46255
46256 SUBROUTINE pyedit(MEDIT)
46257
46258C...Double precision and integer declarations.
46259 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46260 IMPLICIT INTEGER(I-N)
46261 INTEGER PYK,PYCHGE,PYCOMP
46262C...Commonblocks.
46263 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
46264 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46265 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46266 SAVE /pyjets/,/pydat1/,/pydat2/
46267C...Local arrays.
46268 dimension ns(2),pts(2),pls(2)
46269
46270C...Remove unwanted partons/particles.
46271 IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
46272 imax=n
46273 IF(mstu(2).GT.0) imax=mstu(2)
46274 i1=max(1,mstu(1))-1
46275 DO 110 i=max(1,mstu(1)),imax
46276 IF(k(i,1).EQ.0.OR.k(i,1).GT.20) GOTO 110
46277 IF(medit.EQ.1) THEN
46278 IF(k(i,1).GT.10) GOTO 110
46279 ELSEIF(medit.EQ.2) THEN
46280 IF(k(i,1).GT.10) GOTO 110
46281 kc=pycomp(k(i,2))
46282 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
46283 & GOTO 110
46284 ELSEIF(medit.EQ.3) THEN
46285 IF(k(i,1).GT.10) GOTO 110
46286 kc=pycomp(k(i,2))
46287 IF(kc.EQ.0) GOTO 110
46288 IF(kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0) GOTO 110
46289 ELSEIF(medit.EQ.5) THEN
46290 IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) GOTO 110
46291 kc=pycomp(k(i,2))
46292 IF(kc.EQ.0) GOTO 110
46293 IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) GOTO 110
46294 ENDIF
46295
46296C...Pack remaining partons/particles. Origin no longer known.
46297 i1=i1+1
46298 DO 100 j=1,5
46299 k(i1,j)=k(i,j)
46300 p(i1,j)=p(i,j)
46301 v(i1,j)=v(i,j)
46302 100 CONTINUE
46303 k(i1,3)=0
46304 110 CONTINUE
46305 IF(i1.LT.n) mstu(3)=0
46306 IF(i1.LT.n) mstu(70)=0
46307 n=i1
46308
46309C...Selective removal of class of entries. New position of retained.
46310 ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
46311 i1=0
46312 DO 120 i=1,n
46313 k(i,3)=mod(k(i,3),mstu(5))
46314 IF(medit.EQ.11.AND.k(i,1).LT.0) GOTO 120
46315 IF(medit.EQ.12.AND.k(i,1).EQ.0) GOTO 120
46316 IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
46317 & k(i,1).EQ.15).AND.k(i,2).NE.94) GOTO 120
46318 IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
46319 & k(i,2).EQ.94)) GOTO 120
46320 IF(medit.EQ.15.AND.k(i,1).GE.21) GOTO 120
46321 i1=i1+1
46322 k(i,3)=k(i,3)+mstu(5)*i1
46323 120 CONTINUE
46324
46325C...Find new event history information and replace old.
46326 DO 140 i=1,n
46327 IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0)
46328 & GOTO 140
46329 id=i
46330 130 im=mod(k(id,3),mstu(5))
46331 IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
46332 IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
46333 & k(im,2).NE.94) THEN
46334 id=im
46335 GOTO 130
46336 ENDIF
46337 ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
46338 IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
46339 id=im
46340 GOTO 130
46341 ENDIF
46342 ENDIF
46343 k(i,3)=mstu(5)*(k(i,3)/mstu(5))
46344 IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
46345 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
46346 IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
46347 & k(k(i,4),3)/mstu(5)
46348 IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
46349 & k(k(i,5),3)/mstu(5)
46350 ELSE
46351 kcm=mod(k(i,4)/mstu(5),mstu(5))
46352 IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
46353 kcd=mod(k(i,4),mstu(5))
46354 IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
46355 k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
46356 kcm=mod(k(i,5)/mstu(5),mstu(5))
46357 IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
46358 kcd=mod(k(i,5),mstu(5))
46359 IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
46360 k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
46361 ENDIF
46362 140 CONTINUE
46363
46364C...Pack remaining entries.
46365 i1=0
46366 mstu90=mstu(90)
46367 mstu(90)=0
46368 DO 170 i=1,n
46369 IF(k(i,3)/mstu(5).EQ.0) GOTO 170
46370 i1=i1+1
46371 DO 150 j=1,5
46372 k(i1,j)=k(i,j)
46373 p(i1,j)=p(i,j)
46374 v(i1,j)=v(i,j)
46375 150 CONTINUE
46376 k(i1,3)=mod(k(i1,3),mstu(5))
46377 DO 160 iz=1,mstu90
46378 IF(i.EQ.mstu(90+iz)) THEN
46379 mstu(90)=mstu(90)+1
46380 mstu(90+mstu(90))=i1
46381 paru(90+mstu(90))=paru(90+iz)
46382 ENDIF
46383 160 CONTINUE
46384 170 CONTINUE
46385 IF(i1.LT.n) mstu(3)=0
46386 IF(i1.LT.n) mstu(70)=0
46387 n=i1
46388
46389C...Fill in some missing daughter pointers (lost in colour flow).
46390 ELSEIF(medit.EQ.16) THEN
46391 DO 220 i=1,n
46392 IF(k(i,1).LE.10.OR.k(i,1).GT.20) GOTO 220
46393 IF(k(i,4).NE.0.OR.k(i,5).NE.0) GOTO 220
46394C...Find daughters who point to mother.
46395 DO 180 i1=i+1,n
46396 IF(k(i1,3).NE.i) THEN
46397 ELSEIF(k(i,4).EQ.0) THEN
46398 k(i,4)=i1
46399 ELSE
46400 k(i,5)=i1
46401 ENDIF
46402 180 CONTINUE
46403 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
46404 IF(k(i,4).NE.0) GOTO 220
46405C...Find daughters who point to documentation version of mother.
46406 im=k(i,3)
46407 IF(im.LE.0.OR.im.GE.i) GOTO 220
46408 IF(k(im,1).LE.20.OR.k(im,1).GT.30) GOTO 220
46409 IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1d-2) GOTO 220
46410 DO 190 i1=i+1,n
46411 IF(k(i1,3).NE.im) THEN
46412 ELSEIF(k(i,4).EQ.0) THEN
46413 k(i,4)=i1
46414 ELSE
46415 k(i,5)=i1
46416 ENDIF
46417 190 CONTINUE
46418 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
46419 IF(k(i,4).NE.0) GOTO 220
46420C...Find daughters who point to documentation daughters who,
46421C...in their turn, point to documentation mother.
46422 id1=im
46423 id2=im
46424 DO 200 i1=im+1,i-1
46425 IF(k(i1,3).EQ.im.AND.k(i1,1).GT.20.AND.k(i1,1).LE.30) THEN
46426 id2=i1
46427 IF(id1.EQ.im) id1=i1
46428 ENDIF
46429 200 CONTINUE
46430 DO 210 i1=i+1,n
46431 IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
46432 ELSEIF(k(i,4).EQ.0) THEN
46433 k(i,4)=i1
46434 ELSE
46435 k(i,5)=i1
46436 ENDIF
46437 210 CONTINUE
46438 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
46439 220 CONTINUE
46440
46441C...Save top entries at bottom of PYJETS commonblock.
46442 ELSEIF(medit.EQ.21) THEN
46443 IF(2*n.GE.mstu(4)) THEN
46444 CALL pyerrm(11,'(PYEDIT:) no more memory left in PYJETS')
46445 RETURN
46446 ENDIF
46447 DO 240 i=1,n
46448 DO 230 j=1,5
46449 k(mstu(4)-i,j)=k(i,j)
46450 p(mstu(4)-i,j)=p(i,j)
46451 v(mstu(4)-i,j)=v(i,j)
46452 230 CONTINUE
46453 240 CONTINUE
46454 mstu(32)=n
46455
46456C...Restore bottom entries of commonblock PYJETS to top.
46457 ELSEIF(medit.EQ.22) THEN
46458 DO 260 i=1,mstu(32)
46459 DO 250 j=1,5
46460 k(i,j)=k(mstu(4)-i,j)
46461 p(i,j)=p(mstu(4)-i,j)
46462 v(i,j)=v(mstu(4)-i,j)
46463 250 CONTINUE
46464 260 CONTINUE
46465 n=mstu(32)
46466
46467C...Mark primary entries at top of commonblock PYJETS as untreated.
46468 ELSEIF(medit.EQ.23) THEN
46469 i1=0
46470 DO 270 i=1,n
46471 kh=k(i,3)
46472 IF(kh.GE.1) THEN
46473 IF(k(kh,1).GT.20) kh=0
46474 ENDIF
46475 IF(kh.NE.0) GOTO 280
46476 i1=i1+1
46477 IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
46478 270 CONTINUE
46479 280 n=i1
46480
46481C...Place largest axis along z axis and second largest in xy plane.
46482 ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
46483 CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61),1),
46484 & p(mstu(61),2)),0d0,0d0,0d0)
46485 CALL pyrobo(1,n+mstu(3),-pyangl(p(mstu(61),3),
46486 & p(mstu(61),1)),0d0,0d0,0d0,0d0)
46487 CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61)+1,1),
46488 & p(mstu(61)+1,2)),0d0,0d0,0d0)
46489 IF(medit.EQ.31) RETURN
46490
46491C...Rotate to put slim jet along +z axis.
46492 DO 290 is=1,2
46493 ns(is)=0
46494 pts(is)=0d0
46495 pls(is)=0d0
46496 290 CONTINUE
46497 DO 300 i=1,n
46498 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 300
46499 IF(mstu(41).GE.2) THEN
46500 kc=pycomp(k(i,2))
46501 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
46502 & kc.EQ.18) GOTO 300
46503 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
46504 & .EQ.0) GOTO 300
46505 ENDIF
46506 is=2d0-sign(0.5d0,p(i,3))
46507 ns(is)=ns(is)+1
46508 pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
46509 300 CONTINUE
46510 IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
46511 & CALL pyrobo(1,n+mstu(3),paru(1),0d0,0d0,0d0,0d0)
46512
46513C...Rotate to put second largest jet into -z,+x quadrant.
46514 DO 310 i=1,n
46515 IF(p(i,3).GE.0d0) GOTO 310
46516 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 310
46517 IF(mstu(41).GE.2) THEN
46518 kc=pycomp(k(i,2))
46519 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
46520 & kc.EQ.18) GOTO 310
46521 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
46522 & .EQ.0) GOTO 310
46523 ENDIF
46524 is=2d0-sign(0.5d0,p(i,1))
46525 pls(is)=pls(is)-p(i,3)
46526 310 CONTINUE
46527 IF(pls(2).GT.pls(1)) CALL pyrobo(1,n+mstu(3),0d0,paru(1),
46528 & 0d0,0d0,0d0)
46529 ENDIF
46530
46531 RETURN
46532 END
46533
46534C*********************************************************************
46535
46536C...PYLIST
46537C...Gives program heading, or lists an event, or particle
46538C...data, or current parameter values.
46539
46540 SUBROUTINE pylist(MLIST)
46541
46542C...Double precision and integer declarations.
46543 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46544 IMPLICIT INTEGER(I-N)
46545 INTEGER PYK,PYCHGE,PYCOMP
46546C...Parameter statement to help give large particle numbers.
46547 parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
46548C...Commonblocks.
46549 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
46550 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46551 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46552 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
46553 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
46554C...Local arrays, character variables and data.
46555 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
46556 dimension ps(6)
46557 DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
46558
46559C...Initialization printout: version number and date of last change.
46560 IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
46561 CALL pylogo
46562 mstu(12)=0
46563 IF(mlist.EQ.0) RETURN
46564 ENDIF
46565
46566C...List event data, including additional lines after N.
46567 IF(mlist.GE.1.AND.mlist.LE.3) THEN
46568 IF(mlist.EQ.1) WRITE(mstu(11),5100)
46569 IF(mlist.EQ.2) WRITE(mstu(11),5200)
46570 IF(mlist.EQ.3) WRITE(mstu(11),5300)
46571 lmx=12
46572 IF(mlist.GE.2) lmx=16
46573 istr=0
46574 imax=n
46575 IF(mstu(2).GT.0) imax=mstu(2)
46576 DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
46577 IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) GOTO 120
46578
46579C...Get particle name, pad it and check it is not too long.
46580 CALL pyname(k(i,2),chap)
46581 len=0
46582 DO 100 lem=1,16
46583 IF(chap(lem:lem).NE.' ') len=lem
46584 100 CONTINUE
46585 mdl=(k(i,1)+19)/10
46586 ldl=0
46587 IF(mdl.EQ.2.OR.mdl.GE.8) THEN
46588 chac=chap
46589 IF(len.GT.lmx) chac(lmx:lmx)='?'
46590 ELSE
46591 ldl=1
46592 IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
46593 IF(len.EQ.0) THEN
46594 chac=chdl(mdl)(1:2*ldl)//' '
46595 ELSE
46596 chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
46597 & chdl(mdl)(ldl+1:2*ldl)//' '
46598 IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
46599 ENDIF
46600 ENDIF
46601
46602C...Add information on string connection.
46603 IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
46604 & THEN
46605 kc=pycomp(k(i,2))
46606 kcc=0
46607 IF(kc.NE.0) kcc=kchg(kc,2)
46608 IF(iabs(k(i,2)).EQ.39) THEN
46609 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
46610 ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
46611 istr=1
46612 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
46613 ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
46614 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
46615 ELSEIF(kcc.NE.0) THEN
46616 istr=0
46617 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
46618 ENDIF
46619 ENDIF
46620
46621C...Write data for particle/jet.
46622 IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999d0) THEN
46623 WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),
46624 & (p(i,j2),j2=1,5)
46625 ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999d0) THEN
46626 WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
46627 & (p(i,j2),j2=1,5)
46628 ELSEIF(mlist.EQ.1) THEN
46629 WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
46630 & (p(i,j2),j2=1,5)
46631 ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
46632 & k(i,1).EQ.14)) THEN
46633 WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),
46634 & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
46635 & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
46636 & (p(i,j2),j2=1,5)
46637 ELSE
46638 WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),
46639 & (p(i,j2),j2=1,5)
46640 ENDIF
46641 IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)
46642
46643C...Insert extra separator lines specified by user.
46644 IF(mstu(70).GE.1) THEN
46645 isep=0
46646 DO 110 j=1,min(10,mstu(70))
46647 IF(i.EQ.mstu(70+j)) isep=1
46648 110 CONTINUE
46649 IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)
46650 IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)
46651 ENDIF
46652 120 CONTINUE
46653
46654C...Sum of charges and momenta.
46655 DO 130 j=1,6
46656 ps(j)=pyp(0,j)
46657 130 CONTINUE
46658 IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999d0) THEN
46659 WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)
46660 ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999d0) THEN
46661 WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)
46662 ELSEIF(mlist.EQ.1) THEN
46663 WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)
46664 ELSE
46665 WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)
46666 ENDIF
46667
46668C...Give simple list of KF codes defined in program.
46669 ELSEIF(mlist.EQ.11) THEN
46670 WRITE(mstu(11),6600)
46671 DO 140 kf=1,80
46672 CALL pyname(kf,chap)
46673 CALL pyname(-kf,chan)
46674 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
46675 IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
46676 140 CONTINUE
46677 DO 170 kfls=1,3,2
46678 DO 160 kfla=1,5
46679 DO 150 kflb=1,kfla-(3-kfls)/2
46680 kf=1000*kfla+100*kflb+kfls
46681 CALL pyname(kf,chap)
46682 CALL pyname(-kf,chan)
46683 WRITE(mstu(11),6700) kf,chap,-kf,chan
46684 150 CONTINUE
46685 160 CONTINUE
46686 170 CONTINUE
46687 kf=130
46688 CALL pyname(kf,chap)
46689 WRITE(mstu(11),6700) kf,chap
46690 kf=310
46691 CALL pyname(kf,chap)
46692 WRITE(mstu(11),6700) kf,chap
46693 DO 200 kmul=0,5
46694 kfls=3
46695 IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
46696 IF(kmul.EQ.5) kfls=5
46697 kflr=0
46698 IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
46699 IF(kmul.EQ.4) kflr=2
46700 DO 190 kflb=1,5
46701 DO 180 kflc=1,kflb-1
46702 kf=10000*kflr+100*kflb+10*kflc+kfls
46703 CALL pyname(kf,chap)
46704 CALL pyname(-kf,chan)
46705 WRITE(mstu(11),6700) kf,chap,-kf,chan
46706 180 CONTINUE
46707 kf=10000*kflr+110*kflb+kfls
46708 CALL pyname(kf,chap)
46709 WRITE(mstu(11),6700) kf,chap
46710 190 CONTINUE
46711 200 CONTINUE
46712 kf=100443
46713 CALL pyname(kf,chap)
46714 WRITE(mstu(11),6700) kf,chap
46715 kf=100553
46716 CALL pyname(kf,chap)
46717 WRITE(mstu(11),6700) kf,chap
46718 DO 240 kflsp=1,3
46719 kfls=2+2*(kflsp/3)
46720 DO 230 kfla=1,5
46721 DO 220 kflb=1,kfla
46722 DO 210 kflc=1,kflb
46723 IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc))
46724 & GOTO 210
46725 IF(kflsp.EQ.2.AND.kfla.EQ.kflc) GOTO 210
46726 IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
46727 IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
46728 CALL pyname(kf,chap)
46729 CALL pyname(-kf,chan)
46730 WRITE(mstu(11),6700) kf,chap,-kf,chan
46731 210 CONTINUE
46732 220 CONTINUE
46733 230 CONTINUE
46734 240 CONTINUE
46735 DO 250 kf=ksusy1+1,ksusy1+40
46736 CALL pyname(kf,chap)
46737 CALL pyname(-kf,chan)
46738 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
46739 IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
46740 250 CONTINUE
46741 DO 260 kf=ksusy2+1,ksusy2+40
46742 CALL pyname(kf,chap)
46743 CALL pyname(-kf,chan)
46744 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
46745 IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
46746 260 CONTINUE
46747 DO 270 kf=kexcit+1,kexcit+40
46748 CALL pyname(kf,chap)
46749 CALL pyname(-kf,chan)
46750 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
46751 IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
46752 270 CONTINUE
46753
46754C...List parton/particle data table. Check whether to be listed.
46755 ELSEIF(mlist.EQ.12) THEN
46756 WRITE(mstu(11),6800)
46757 DO 300 kc=1,mstu(6)
46758 kf=kchg(kc,4)
46759 IF(kf.EQ.0) GOTO 300
46760 IF(kf.LT.mstu(1).OR.(mstu(2).GT.0.AND.kf.GT.mstu(2)))
46761 & GOTO 300
46762
46763C...Find particle name and mass. Print information.
46764 CALL pyname(kf,chap)
46765 IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) GOTO 300
46766 CALL pyname(-kf,chan)
46767 WRITE(mstu(11),6900) kf,kc,chap,chan,(kchg(kc,j1),j1=1,3),
46768 & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
46769
46770C...Particle decay: channel number, branching ratios, matrix element,
46771C...decay products.
46772 DO 290 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46773 DO 280 j=1,5
46774 CALL pyname(kfdp(idc,j),chad(j))
46775 280 CONTINUE
46776 WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
46777 & (chad(j),j=1,5)
46778 290 CONTINUE
46779 300 CONTINUE
46780
46781C...List parameter value table.
46782 ELSEIF(mlist.EQ.13) THEN
46783 WRITE(mstu(11),7100)
46784 DO 310 i=1,200
46785 WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
46786 310 CONTINUE
46787 ENDIF
46788
46789C...Format statements for output on unit MSTU(11) (by default 6).
46790 5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
46791 &5x,'KF orig p_x p_y p_z E m'/)
46792 5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
46793 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
46794 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
46795 5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
46796 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
46797 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
46798 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
46799 5400 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.3)
46800 5500 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.2)
46801 5600 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.1)
46802 5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),5f13.5)
46803 5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),5f13.5)
46804 5900 FORMAT(66x,5(1x,f12.3))
46805 6000 FORMAT(1x,78('='))
46806 6100 FORMAT(1x,130('='))
46807 6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
46808 6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
46809 6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
46810 6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
46811 &5f13.5)
46812 6600 FORMAT(///20x,'List of KF codes in program'/)
46813 6700 FORMAT(4x,i9,4x,a16,6x,i9,4x,a16)
46814 6800 FORMAT(///30x,'Particle/parton data table'//8x,'KF',5x,'KC',4x,
46815 &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
46816 &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
46817 &1x,'ME',3x,'Br.rat.',4x,'decay products')
46818 6900 FORMAT(/1x,i9,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
46819 &1x,1p,e13.5,3x,i2)
46820 7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f10.6,4x,5a16)
46821 7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
46822 &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
46823 7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
46824
46825 RETURN
46826 END
46827
46828C*********************************************************************
46829
46830C...PYLOGO
46831C...Writes a logo for the program.
46832
46833 SUBROUTINE pylogo
46834
46835C...Double precision and integer declarations.
46836 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46837 IMPLICIT INTEGER(I-N)
46838 INTEGER PYK,PYCHGE,PYCOMP
46839C...Parameter for length of information block.
46840 parameter(irefer=17)
46841C...Commonblocks.
46842 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46843 common/pypars/mstp(200),parp(200),msti(200),pari(200)
46844 SAVE /pydat1/,/pypars/
46845C...Local arrays and character variables.
46846 INTEGER IDATI(6)
46847 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
46848 &vers*1, subv*3, date*2, year*4, hour*2, minu*2, seco*2
46849
46850C...Data on months, logo, titles, and references.
46851 DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
46852 &'Oct','Nov','Dec'/
46853 DATA (logo(j),j=1,19)/
46854 &' *......* ',
46855 &' *:::!!:::::::::::* ',
46856 &' *::::::!!::::::::::::::* ',
46857 &' *::::::::!!::::::::::::::::* ',
46858 &' *:::::::::!!:::::::::::::::::* ',
46859 &' *:::::::::!!:::::::::::::::::* ',
46860 &' *::::::::!!::::::::::::::::*! ',
46861 &' *::::::!!::::::::::::::* !! ',
46862 &' !! *:::!!:::::::::::* !! ',
46863 &' !! !* -><- * !! ',
46864 &' !! !! !! ',
46865 &' !! !! !! ',
46866 &' !! !! ',
46867 &' !! ep !! ',
46868 &' !! !! ',
46869 &' !! pp !! ',
46870 &' !! e+e- !! ',
46871 &' !! !! ',
46872 &' !! '/
46873 DATA (logo(j),j=20,38)/
46874 &'Welcome to the Lund Monte Carlo!',
46875 &' ',
46876 &'PPP Y Y TTTTT H H III A ',
46877 &'P P Y Y T H H I A A ',
46878 &'PPP Y T HHHHH I AAAAA',
46879 &'P Y T H H I A A',
46880 &'P Y T H H III A A',
46881 &' ',
46882 &'This is PYTHIA version x.xxx ',
46883 &'Last date of change: xx xxx 199x',
46884 &' ',
46885 &'Now is xx xxx 199x at xx:xx:xx ',
46886 &' ',
46887 &'Disclaimer: this program comes ',
46888 &'without any guarantees. Beware ',
46889 &'of errors and use common sense ',
46890 &'when interpreting results. ',
46891 &' ',
46892 &'Copyright T. Sjostrand (2000) '/
46893 DATA (refer(j),j=1,18)/
46894 &'An archive of program versions and d',
46895 &'ocumentation is found on the web: ',
46896 &'http://www.thep.lu.se/~torbjorn/Pyth',
46897 &'ia.html ',
46898 &' ',
46899 &' ',
46900 &'When you cite this program, currentl',
46901 &'y the official reference is ',
46902 &'T. Sjostrand, Computer Physics Commu',
46903 &'n. 82 (1994) 74. ',
46904 &'The supersymmetry extensions are des',
46905 &'cribed in ',
46906 &'S. Mrenna, Computer Physics Commun. ',
46907 &'101 (1997) 232 ',
46908 &'Also remember that the program, to a',
46909 &' large extent, represents original ',
46910 &'physics research. Other publications',
46911 &' of special relevance to your '/
46912 DATA (refer(j),j=19,2*irefer)/
46913 &'studies may therefore deserve separa',
46914 &'te mention. ',
46915 &' ',
46916 &' ',
46917 &'Main author: Torbjorn Sjostrand; Dep',
46918 &'artment of Theoretical Physics 2, ',
46919 &' Lund University, Solvegatan 14A, S',
46920 &'-223 62 Lund, Sweden; ',
46921 &' phone: + 46 - 46 - 222 48 16; e-ma',
46922 &'il: torbjorn@thep.lu.se ',
46923 &'SUSY author: Stephen Mrenna, Physics',
46924 &' Department, UC Davis, ',
46925 &' One Shields Avenue, Davis, CA 9561',
46926 &'6, USA; ',
46927 &' phone: + 1 - 530 - 752 - 2661; e-m',
46928 &'ail: mrenna@physics.ucdavis.edu '/
46929
46930C...Check that PYDATA linked.
46931 IF(mstp(183)/10.NE.199.AND.mstp(183)/10.NE.200) THEN
46932 WRITE(*,'(1X,A)')
46933 & 'Error: PYDATA has not been linked.'
46934 WRITE(*,'(1X,A)') 'Execution stopped!'
46935 stop
46936
46937C...Write current version number and current date+time.
46938 ELSE
46939 WRITE(vers,'(I1)') mstp(181)
46940 logo(28)(24:24)=vers
46941 WRITE(subv,'(I3)') mstp(182)
46942 logo(28)(26:28)=subv
46943 IF(mstp(182).LT.100) logo(28)(26:26)='0'
46944 WRITE(date,'(I2)') mstp(185)
46945 logo(29)(22:23)=date
46946 logo(29)(25:27)=month(mstp(184))
46947 WRITE(year,'(I4)') mstp(183)
46948 logo(29)(29:32)=year
46949 CALL pytime(idati)
46950 IF(idati(1).LE.0) THEN
46951 logo(31)=' '
46952 ELSE
46953 WRITE(date,'(I2)') idati(3)
46954 logo(31)(8:9)=date
46955 logo(31)(11:13)=month(max(1,min(12,idati(2))))
46956 WRITE(year,'(I4)') idati(1)
46957 logo(31)(15:18)=year
46958 WRITE(hour,'(I2)') idati(4)
46959 logo(31)(23:24)=hour
46960 WRITE(minu,'(I2)') idati(5)
46961 logo(31)(26:27)=minu
46962 IF(idati(5).LT.10) logo(31)(26:26)='0'
46963 WRITE(seco,'(I2)') idati(6)
46964 logo(31)(29:30)=seco
46965 IF(idati(6).LT.10) logo(31)(29:29)='0'
46966 ENDIF
46967 ENDIF
46968
46969C...Loop over lines in header. Define page feed and side borders.
46970 DO 100 ilin=1,29+irefer
46971 line=' '
46972 IF(ilin.EQ.1) THEN
46973 line(1:1)='1'
46974 ELSE
46975 line(2:3)='**'
46976 line(78:79)='**'
46977 ENDIF
46978
46979C...Separator lines and logos.
46980 IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.GE.28+irefer) THEN
46981 line(4:77)='***********************************************'//
46982 & '***************************'
46983 ELSEIF(ilin.GE.6.AND.ilin.LE.24) THEN
46984 line(6:37)=logo(ilin-5)
46985 line(44:75)=logo(ilin+14)
46986 ELSEIF(ilin.GE.26.AND.ilin.LE.25+irefer) THEN
46987 line(5:40)=refer(2*ilin-51)
46988 line(41:76)=refer(2*ilin-50)
46989 ENDIF
46990
46991C...Write lines to appropriate unit.
46992 WRITE(mstu(11),'(A79)') line
46993 100 CONTINUE
46994
46995 RETURN
46996 END
46997
46998C*********************************************************************
46999
47000C...PYUPDA
47001C...Facilitates the updating of particle and decay data
47002C...by allowing it to be done in an external file.
47003
47004 SUBROUTINE pyupda(MUPDA,LFN)
47005
47006C...Double precision and integer declarations.
47007 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47008 IMPLICIT INTEGER(I-N)
47009 INTEGER PYK,PYCHGE,PYCOMP
47010C...Commonblocks.
47011 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47012 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47013 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
47014 common/pydat4/chaf(500,2)
47015 CHARACTER CHAF*16
47016 COMMON/PYINT4/MWID(500),WIDS(500,5)
47017 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pyint4/
47018C...Local arrays, character variables and data.
47019 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
47020 &chblk(20)*72,chold*16,chtmp*16,chnew*16,chcom*24
47021 DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
47022 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
47023 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
47024 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
47025 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
47026
47027C...Write header if not yet done.
47028 IF(mstu(12).GE.1) CALL pylist(0)
47029
47030C...Write information on file for editing.
47031 IF(mupda.EQ.1) THEN
47032 DO 110 kc=1,500
47033 WRITE(lfn,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
47034 & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
47035 & mwid(kc),mdcy(kc,1)
47036 DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
47037 WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
47038 & (kfdp(idc,j),j=1,5)
47039 100 CONTINUE
47040 110 CONTINUE
47041
47042C...Read complete set of information from edited file or
47043C...read partial set of new or updated information from edited file.
47044 ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN
47045
47046C...Reset counters.
47047 kcc=100
47048 ndc=0
47049 chkf=' '
47050 IF(mupda.EQ.2) THEN
47051 DO 120 i=1,mstu(6)
47052 kchg(i,4)=0
47053 120 CONTINUE
47054 ELSE
47055 DO 130 kc=1,mstu(6)
47056 IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
47057 ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
47058 130 CONTINUE
47059 ENDIF
47060
47061C...Begin of loop: read new line; unknown whether particle or
47062C...decay data.
47063 140 READ(lfn,5200,END=190) chinl
47064
47065C...Identify particle code and whether already defined (for MUPDA=3).
47066 IF(chinl(2:10).NE.' ') THEN
47067 chkf=chinl(2:10)
47068 READ(chkf,5300) kf
47069 IF(mupda.EQ.2) THEN
47070 IF(kf.LE.100) THEN
47071 kc=kf
47072 ELSE
47073 kcc=kcc+1
47074 kc=kcc
47075 ENDIF
47076 ELSE
47077 kcrep=0
47078 IF(kf.LE.100) THEN
47079 kcrep=kf
47080 ELSE
47081 DO 150 kcr=101,kcc
47082 IF(kchg(kcr,4).EQ.kf) kcrep=kcr
47083 150 CONTINUE
47084 ENDIF
47085C...Remove duplicate old decay data.
47086 IF(kcrep.NE.0.AND.mdcy(kcrep,3).GT.0) THEN
47087 idcrep=mdcy(kcrep,2)
47088 ndcrep=mdcy(kcrep,3)
47089 DO 160 i=1,kcc
47090 IF(mdcy(i,2).GT.idcrep) mdcy(i,2)=mdcy(i,2)-ndcrep
47091 160 CONTINUE
47092 DO 180 i=idcrep,ndc-ndcrep
47093 mdme(i,1)=mdme(i+ndcrep,1)
47094 mdme(i,2)=mdme(i+ndcrep,2)
47095 brat(i)=brat(i+ndcrep)
47096 DO 170 j=1,5
47097 kfdp(i,j)=kfdp(i+ndcrep,j)
47098 170 CONTINUE
47099 180 CONTINUE
47100 ndc=ndc-ndcrep
47101 kc=kcrep
47102 ELSEIF(kcrep.NE.0) THEN
47103 kc=kcrep
47104 ELSE
47105 kcc=kcc+1
47106 kc=kcc
47107 ENDIF
47108 ENDIF
47109
47110C...Study line with particle data.
47111 IF(kc.GT.mstu(6)) CALL pyerrm(27,
47112 & '(PYUPDA:) Particle arrays full by KF ='//chkf)
47113 READ(chinl,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
47114 & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
47115 & mwid(kc),mdcy(kc,1)
47116 mdcy(kc,2)=0
47117 mdcy(kc,3)=0
47118
47119C...Study line with decay data.
47120 ELSE
47121 ndc=ndc+1
47122 IF(ndc.GT.mstu(7)) CALL pyerrm(27,
47123 & '(PYUPDA:) Decay data arrays full by KF ='//chkf)
47124 IF(mdcy(kc,2).EQ.0) mdcy(kc,2)=ndc
47125 mdcy(kc,3)=mdcy(kc,3)+1
47126 READ(chinl,5100) mdme(ndc,1),mdme(ndc,2),brat(ndc),
47127 & (kfdp(ndc,j),j=1,5)
47128 ENDIF
47129
47130C...End of loop; ensure that PYCOMP tables are updated.
47131 GOTO 140
47132 190 CONTINUE
47133 mstu(20)=0
47134
47135C...Perform possible tests that new information is consistent.
47136 DO 220 kc=1,mstu(6)
47137 kf=kchg(kc,4)
47138 IF(kf.EQ.0) GOTO 220
47139 WRITE(chkf,5300) kf
47140 IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
47141 & pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0) CALL pyerrm(17,
47142 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//chkf)
47143 brsum=0d0
47144 DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
47145 IF(mdme(idc,2).GT.80) GOTO 210
47146 kq=kchg(kc,1)
47147 pms=pmas(kc,1)-pmas(kc,3)-parj(64)
47148 merr=0
47149 DO 200 j=1,5
47150 kp=kfdp(idc,j)
47151 IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
47152 IF(kp.EQ.81) kq=0
47153 ELSEIF(pycomp(kp).EQ.0) THEN
47154 merr=3
47155 ELSE
47156 kq=kq-pychge(kp)
47157 kpc=pycomp(kp)
47158 pms=pms-pmas(kpc,1)
47159 IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
47160 & pmas(kpc,3))
47161 ENDIF
47162 200 CONTINUE
47163 IF(kq.NE.0) merr=max(2,merr)
47164 IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
47165 & merr=max(1,merr)
47166 IF(merr.EQ.3) CALL pyerrm(17,
47167 & '(PYUPDA:) Unknown particle code in decay of KF ='//chkf)
47168 IF(merr.EQ.2) CALL pyerrm(17,
47169 & '(PYUPDA:) Charge not conserved in decay of KF ='//chkf)
47170 IF(merr.EQ.1) CALL pyerrm(7,
47171 & '(PYUPDA:) Kinematically unallowed decay of KF ='//chkf)
47172 brsum=brsum+brat(idc)
47173 210 CONTINUE
47174 WRITE(chtmp,5500) brsum
47175 IF(abs(brsum).GT.0.0005d0.AND.abs(brsum-1d0).GT.0.0005d0)
47176 & CALL pyerrm(7,'(PYUPDA:) Sum of branching ratios is '//
47177 & chtmp(9:16)//' for KF ='//chkf)
47178 220 CONTINUE
47179
47180C...Write DATA statements for inclusion in program.
47181 ELSEIF(mupda.EQ.4) THEN
47182
47183C...Find out how many codes and decay channels are actually used.
47184 kcc=0
47185 ndc=0
47186 DO 230 i=1,mstu(6)
47187 IF(kchg(i,4).NE.0) THEN
47188 kcc=i
47189 ndc=max(ndc,mdcy(i,2)+mdcy(i,3)-1)
47190 ENDIF
47191 230 CONTINUE
47192
47193C...Initialize writing of DATA statements for inclusion in program.
47194 DO 300 ivar=1,22
47195 ndim=mstu(6)
47196 IF(ivar.GE.12.AND.ivar.LE.19) ndim=mstu(7)
47197 nlin=1
47198 chlin=' '
47199 chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
47200 llin=35
47201 chold='START'
47202
47203C...Loop through variables for conversion to characters.
47204 DO 280 idim=1,ndim
47205 IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
47206 IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
47207 IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
47208 IF(ivar.EQ.4) WRITE(chtmp,5400) kchg(idim,4)
47209 IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,1)
47210 IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,2)
47211 IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,3)
47212 IF(ivar.EQ.8) WRITE(chtmp,5500) pmas(idim,4)
47213 IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,1)
47214 IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,2)
47215 IF(ivar.EQ.11) WRITE(chtmp,5400) mdcy(idim,3)
47216 IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,1)
47217 IF(ivar.EQ.13) WRITE(chtmp,5400) mdme(idim,2)
47218 IF(ivar.EQ.14) WRITE(chtmp,5600) brat(idim)
47219 IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,1)
47220 IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,2)
47221 IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,3)
47222 IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,4)
47223 IF(ivar.EQ.19) WRITE(chtmp,5400) kfdp(idim,5)
47224 IF(ivar.EQ.20) chtmp=chaf(idim,1)
47225 IF(ivar.EQ.21) chtmp=chaf(idim,2)
47226 IF(ivar.EQ.22) WRITE(chtmp,5400) mwid(idim)
47227
47228C...Replace variables beyond what is properly defined.
47229 IF(ivar.LE.4) THEN
47230 IF(idim.GT.kcc) chtmp=' 0'
47231 ELSEIF(ivar.LE.8) THEN
47232 IF(idim.GT.kcc) chtmp=' 0.0'
47233 ELSEIF(ivar.LE.11) THEN
47234 IF(idim.GT.kcc) chtmp=' 0'
47235 ELSEIF(ivar.LE.13) THEN
47236 IF(idim.GT.ndc) chtmp=' 0'
47237 ELSEIF(ivar.LE.14) THEN
47238 IF(idim.GT.ndc) chtmp=' 0.0'
47239 ELSEIF(ivar.LE.19) THEN
47240 IF(idim.GT.ndc) chtmp=' 0'
47241 ELSEIF(ivar.LE.21) THEN
47242 IF(idim.GT.kcc) chtmp=' '
47243 ELSE
47244 IF(idim.GT.kcc) chtmp=' 0'
47245 ENDIF
47246
47247C...Length of variable, trailing decimal zeros, quotation marks.
47248 llow=1
47249 lhig=1
47250 DO 240 ll=1,16
47251 IF(chtmp(17-ll:17-ll).NE.' ') llow=17-ll
47252 IF(chtmp(ll:ll).NE.' ') lhig=ll
47253 240 CONTINUE
47254 chnew=chtmp(llow:lhig)//' '
47255 lnew=1+lhig-llow
47256 IF((ivar.GE.5.AND.ivar.LE.8).OR.ivar.EQ.14) THEN
47257 lnew=lnew+1
47258 250 lnew=lnew-1
47259 IF(lnew.GE.2.AND.chnew(lnew:lnew).EQ.'0') GOTO 250
47260 IF(chnew(lnew:lnew).EQ.'.') lnew=lnew-1
47261 IF(lnew.EQ.0) THEN
47262 chnew(1:3)='0D0'
47263 lnew=3
47264 ELSE
47265 chnew(lnew+1:lnew+2)='D0'
47266 lnew=lnew+2
47267 ENDIF
47268 ELSEIF(ivar.EQ.20.OR.ivar.EQ.21) THEN
47269 DO 260 ll=lnew,1,-1
47270 IF(chnew(ll:ll).EQ.'''') THEN
47271 chtmp=chnew
47272 chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
47273 lnew=lnew+1
47274 ENDIF
47275 260 CONTINUE
47276 lnew=min(14,lnew)
47277 chtmp=chnew
47278 chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
47279 lnew=lnew+2
47280 ENDIF
47281
47282C...Form composite character string, often including repetition counter.
47283 IF(chnew.NE.chold) THEN
47284 nrpt=1
47285 chold=chnew
47286 chcom=chnew
47287 lcom=lnew
47288 ELSE
47289 lrpt=lnew+1
47290 IF(nrpt.GE.2) lrpt=lnew+3
47291 IF(nrpt.GE.10) lrpt=lnew+4
47292 IF(nrpt.GE.100) lrpt=lnew+5
47293 IF(nrpt.GE.1000) lrpt=lnew+6
47294 llin=llin-lrpt
47295 nrpt=nrpt+1
47296 WRITE(chtmp,5400) nrpt
47297 lrpt=1
47298 IF(nrpt.GE.10) lrpt=2
47299 IF(nrpt.GE.100) lrpt=3
47300 IF(nrpt.GE.1000) lrpt=4
47301 chcom(1:lrpt+1+lnew)=chtmp(17-lrpt:16)//'*'//chnew(1:lnew)
47302 lcom=lrpt+1+lnew
47303 ENDIF
47304
47305C...Add characters to end of line, to new line (after storing old line),
47306C...or to new block of lines (after writing old block).
47307 IF(llin+lcom.LE.70) THEN
47308 chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
47309 llin=llin+lcom+1
47310 ELSEIF(nlin.LE.19) THEN
47311 chlin(llin+1:72)=' '
47312 chblk(nlin)=chlin
47313 nlin=nlin+1
47314 chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
47315 llin=6+lcom+1
47316 ELSE
47317 chlin(llin:72)='/'//' '
47318 chblk(nlin)=chlin
47319 WRITE(chtmp,5400) idim-nrpt
47320 chblk(1)(30:33)=chtmp(13:16)
47321 DO 270 ilin=1,nlin
47322 WRITE(lfn,5700) chblk(ilin)
47323 270 CONTINUE
47324 nlin=1
47325 chlin=' '
47326 chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//
47327 & ',I= , )/'//chcom(1:lcom)//','
47328 WRITE(chtmp,5400) idim-nrpt+1
47329 chlin(25:28)=chtmp(13:16)
47330 llin=35+lcom+1
47331 ENDIF
47332 280 CONTINUE
47333
47334C...Write final block of lines.
47335 chlin(llin:72)='/'//' '
47336 chblk(nlin)=chlin
47337 WRITE(chtmp,5400) ndim
47338 chblk(1)(30:33)=chtmp(13:16)
47339 DO 290 ilin=1,nlin
47340 WRITE(lfn,5700) chblk(ilin)
47341 290 CONTINUE
47342 300 CONTINUE
47343 ENDIF
47344
47345C...Formats for reading and writing particle data.
47346 5000 FORMAT(1x,i9,2x,a16,2x,a16,3i3,3f12.5,1p,e13.5,2i3)
47347 5100 FORMAT(10x,2i5,f12.6,5i10)
47348 5200 FORMAT(a120)
47349 5300 FORMAT(i9)
47350 5400 FORMAT(i16)
47351 5500 FORMAT(f16.5)
47352 5600 FORMAT(f16.6)
47353 5700 FORMAT(a72)
47354
47355 RETURN
47356 END
47357
47358C*********************************************************************
47359
47360C...PYK
47361C...Provides various integer-valued event related data.
47362
47363 FUNCTION pyk(I,J)
47364
47365C...Double precision and integer declarations.
47366 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47367 IMPLICIT INTEGER(I-N)
47368 INTEGER PYK,PYCHGE,PYCOMP
47369C...Commonblocks.
47370 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
47371 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47372 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47373 SAVE /pyjets/,/pydat1/,/pydat2/
47374
47375C...Default value. For I=0 number of entries, number of stable entries
47376C...or 3 times total charge.
47377 pyk=0
47378 IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
47379 ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
47380 pyk=n
47381 ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
47382 DO 100 i1=1,n
47383 IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+1
47384 IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+
47385 & pychge(k(i1,2))
47386 100 CONTINUE
47387 ELSEIF(i.EQ.0) THEN
47388
47389C...For I > 0 direct readout of K matrix or charge.
47390 ELSEIF(j.LE.5) THEN
47391 pyk=k(i,j)
47392 ELSEIF(j.EQ.6) THEN
47393 pyk=pychge(k(i,2))
47394
47395C...Status (existing/fragmented/decayed), parton/hadron separation.
47396 ELSEIF(j.LE.8) THEN
47397 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pyk=1
47398 IF(j.EQ.8) pyk=pyk*k(i,2)
47399 ELSEIF(j.LE.12) THEN
47400 kfa=iabs(k(i,2))
47401 kc=pycomp(kfa)
47402 kq=0
47403 IF(kc.NE.0) kq=kchg(kc,2)
47404 IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) pyk=k(i,2)
47405 IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) pyk=k(i,2)
47406 IF(j.EQ.11) pyk=kc
47407 IF(j.EQ.12) pyk=kq*isign(1,k(i,2))
47408
47409C...Heaviest flavour in hadron/diquark.
47410 ELSEIF(j.EQ.13) THEN
47411 kfa=iabs(k(i,2))
47412 pyk=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
47413 IF(kfa.LT.10) pyk=kfa
47414 IF(mod(kfa/1000,10).NE.0) pyk=mod(kfa/1000,10)
47415 pyk=pyk*isign(1,k(i,2))
47416
47417C...Particle history: generation, ancestor, rank.
47418 ELSEIF(j.LE.15) THEN
47419 i2=i
47420 i1=i
47421 110 pyk=pyk+1
47422 i2=i1
47423 i1=k(i1,3)
47424 IF(i1.GT.0) THEN
47425 IF(k(i1,1).GT.0.AND.k(i1,1).LE.20) GOTO 110
47426 ENDIF
47427 IF(j.EQ.15) pyk=i2
47428 ELSEIF(j.EQ.16) THEN
47429 kfa=iabs(k(i,2))
47430 IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
47431 & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
47432 i1=i
47433 120 i2=i1
47434 i1=k(i1,3)
47435 IF(i1.GT.0) THEN
47436 kfam=iabs(k(i1,2))
47437 ilp=1
47438 IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
47439 IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
47440 & ilp=0
47441 IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
47442 IF(ilp.EQ.1) GOTO 120
47443 ENDIF
47444 IF(k(i1,1).EQ.12) THEN
47445 DO 130 i3=i1+1,i2
47446 IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
47447 & .AND.k(i3,2).NE.93) pyk=pyk+1
47448 130 CONTINUE
47449 ELSE
47450 i3=i2
47451 140 pyk=pyk+1
47452 i3=i3+1
47453 IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) GOTO 140
47454 ENDIF
47455 ENDIF
47456
47457C...Particle coming from collapsing jet system or not.
47458 ELSEIF(j.EQ.17) THEN
47459 i1=i
47460 150 pyk=pyk+1
47461 i3=i1
47462 i1=k(i1,3)
47463 i0=max(1,i1)
47464 kc=pycomp(k(i0,2))
47465 IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
47466 IF(pyk.EQ.1) pyk=-1
47467 IF(pyk.GT.1) pyk=0
47468 RETURN
47469 ENDIF
47470 IF(kchg(kc,2).EQ.0) GOTO 150
47471 IF(k(i1,1).NE.12) pyk=0
47472 IF(k(i1,1).NE.12) RETURN
47473 i2=i1
47474 160 i2=i2+1
47475 IF(i2.LT.n.AND.k(i2,1).NE.11) GOTO 160
47476 k3m=k(i3-1,3)
47477 IF(k3m.GE.i1.AND.k3m.LE.i2) pyk=0
47478 k3p=k(i3+1,3)
47479 IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) pyk=0
47480
47481C...Number of decay products. Colour flow.
47482 ELSEIF(j.EQ.18) THEN
47483 IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) pyk=max(0,k(i,5)-k(i,4)+1)
47484 IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) pyk=0
47485 ELSEIF(j.LE.22) THEN
47486 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
47487 IF(j.EQ.19) pyk=mod(k(i,4)/mstu(5),mstu(5))
47488 IF(j.EQ.20) pyk=mod(k(i,5)/mstu(5),mstu(5))
47489 IF(j.EQ.21) pyk=mod(k(i,4),mstu(5))
47490 IF(j.EQ.22) pyk=mod(k(i,5),mstu(5))
47491 ELSE
47492 ENDIF
47493
47494 RETURN
47495 END
47496
47497C*********************************************************************
47498
47499C...PYP
47500C...Provides various real-valued event related data.
47501
47502 FUNCTION pyp(I,J)
47503
47504C...Double precision and integer declarations.
47505 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47506 IMPLICIT INTEGER(I-N)
47507 INTEGER PYK,PYCHGE,PYCOMP
47508C...Commonblocks.
47509 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
47510 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47511 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47512 SAVE /pyjets/,/pydat1/,/pydat2/
47513C...Local array.
47514 dimension psum(4)
47515
47516C...Set default value. For I = 0 sum of momenta or charges,
47517C...or invariant mass of system.
47518 pyp=0d0
47519 IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
47520 ELSEIF(i.EQ.0.AND.j.LE.4) THEN
47521 DO 100 i1=1,n
47522 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+p(i1,j)
47523 100 CONTINUE
47524 ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
47525 DO 120 j1=1,4
47526 psum(j1)=0d0
47527 DO 110 i1=1,n
47528 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+
47529 & p(i1,j1)
47530 110 CONTINUE
47531 120 CONTINUE
47532 pyp=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
47533 ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
47534 DO 130 i1=1,n
47535 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+pychge(k(i1,2))/3d0
47536 130 CONTINUE
47537 ELSEIF(i.EQ.0) THEN
47538
47539C...Direct readout of P matrix.
47540 ELSEIF(j.LE.5) THEN
47541 pyp=p(i,j)
47542
47543C...Charge, total momentum, transverse momentum, transverse mass.
47544 ELSEIF(j.LE.12) THEN
47545 IF(j.EQ.6) pyp=pychge(k(i,2))/3d0
47546 IF(j.EQ.7.OR.j.EQ.8) pyp=p(i,1)**2+p(i,2)**2+p(i,3)**2
47547 IF(j.EQ.9.OR.j.EQ.10) pyp=p(i,1)**2+p(i,2)**2
47548 IF(j.EQ.11.OR.j.EQ.12) pyp=p(i,5)**2+p(i,1)**2+p(i,2)**2
47549 IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) pyp=sqrt(pyp)
47550
47551C...Theta and phi angle in radians or degrees.
47552 ELSEIF(j.LE.16) THEN
47553 IF(j.LE.14) pyp=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
47554 IF(j.GE.15) pyp=pyangl(p(i,1),p(i,2))
47555 IF(j.EQ.14.OR.j.EQ.16) pyp=pyp*180d0/paru(1)
47556
47557C...True rapidity, rapidity with pion mass, pseudorapidity.
47558 ELSEIF(j.LE.19) THEN
47559 pmr=0d0
47560 IF(j.EQ.17) pmr=p(i,5)
47561 IF(j.EQ.18) pmr=pymass(211)
47562 pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
47563 pyp=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
47564 & 1d20)),p(i,3))
47565
47566C...Energy and momentum fractions (only to be used in CM frame).
47567 ELSEIF(j.LE.25) THEN
47568 IF(j.EQ.20) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
47569 IF(j.EQ.21) pyp=2d0*p(i,3)/paru(21)
47570 IF(j.EQ.22) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
47571 IF(j.EQ.23) pyp=2d0*p(i,4)/paru(21)
47572 IF(j.EQ.24) pyp=(p(i,4)+p(i,3))/paru(21)
47573 IF(j.EQ.25) pyp=(p(i,4)-p(i,3))/paru(21)
47574 ENDIF
47575
47576 RETURN
47577 END
47578
47579C*********************************************************************
47580
47581C...PYSPHE
47582C...Performs sphericity tensor analysis to give sphericity,
47583C...aplanarity and the related event axes.
47584
47585 SUBROUTINE pysphe(SPH,APL)
47586
47587C...Double precision and integer declarations.
47588 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47589 IMPLICIT INTEGER(I-N)
47590 INTEGER PYK,PYCHGE,PYCOMP
47591C...Commonblocks.
47592 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
47593 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47594 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47595 SAVE /pyjets/,/pydat1/,/pydat2/
47596C...Local arrays.
47597 dimension sm(3,3),sv(3,3)
47598
47599C...Calculate matrix to be diagonalized.
47600 np=0
47601 DO 110 j1=1,3
47602 DO 100 j2=j1,3
47603 sm(j1,j2)=0d0
47604 100 CONTINUE
47605 110 CONTINUE
47606 ps=0d0
47607 DO 140 i=1,n
47608 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
47609 IF(mstu(41).GE.2) THEN
47610 kc=pycomp(k(i,2))
47611 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
47612 & kc.EQ.18) GOTO 140
47613 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
47614 & GOTO 140
47615 ENDIF
47616 np=np+1
47617 pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
47618 pwt=1d0
47619 IF(abs(paru(41)-2d0).GT.0.001d0) pwt=
47620 & max(1d-10,pa)**(paru(41)-2d0)
47621 DO 130 j1=1,3
47622 DO 120 j2=j1,3
47623 sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
47624 120 CONTINUE
47625 130 CONTINUE
47626 ps=ps+pwt*pa**2
47627 140 CONTINUE
47628
47629C...Very low multiplicities (0 or 1) not considered.
47630 IF(np.LE.1) THEN
47631 CALL pyerrm(8,'(PYSPHE:) too few particles for analysis')
47632 sph=-1d0
47633 apl=-1d0
47634 RETURN
47635 ENDIF
47636 DO 160 j1=1,3
47637 DO 150 j2=j1,3
47638 sm(j1,j2)=sm(j1,j2)/ps
47639 150 CONTINUE
47640 160 CONTINUE
47641
47642C...Find eigenvalues to matrix (third degree equation).
47643 sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
47644 &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
47645 sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
47646 &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
47647 &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
47648 sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
47649 p(n+1,4)=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
47650 p(n+3,4)=1d0/3d0+sqrt(-sq)*min(2d0*sp,-sqrt(3d0*(1d0-sp**2))-sp)
47651 p(n+2,4)=1d0-p(n+1,4)-p(n+3,4)
47652 IF(p(n+2,4).LT.1d-5) THEN
47653 CALL pyerrm(8,'(PYSPHE:) all particles back-to-back')
47654 sph=-1d0
47655 apl=-1d0
47656 RETURN
47657 ENDIF
47658
47659C...Find first and last eigenvector by solving equation system.
47660 DO 240 i=1,3,2
47661 DO 180 j1=1,3
47662 sv(j1,j1)=sm(j1,j1)-p(n+i,4)
47663 DO 170 j2=j1+1,3
47664 sv(j1,j2)=sm(j1,j2)
47665 sv(j2,j1)=sm(j1,j2)
47666 170 CONTINUE
47667 180 CONTINUE
47668 smax=0d0
47669 DO 200 j1=1,3
47670 DO 190 j2=1,3
47671 IF(abs(sv(j1,j2)).LE.smax) GOTO 190
47672 ja=j1
47673 jb=j2
47674 smax=abs(sv(j1,j2))
47675 190 CONTINUE
47676 200 CONTINUE
47677 smax=0d0
47678 DO 220 j3=ja+1,ja+2
47679 j1=j3-3*((j3-1)/3)
47680 rl=sv(j1,jb)/sv(ja,jb)
47681 DO 210 j2=1,3
47682 sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
47683 IF(abs(sv(j1,j2)).LE.smax) GOTO 210
47684 jc=j1
47685 smax=abs(sv(j1,j2))
47686 210 CONTINUE
47687 220 CONTINUE
47688 jb1=jb+1-3*(jb/3)
47689 jb2=jb+2-3*((jb+1)/3)
47690 p(n+i,jb1)=-sv(jc,jb2)
47691 p(n+i,jb2)=sv(jc,jb1)
47692 p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
47693 & sv(ja,jb)
47694 pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
47695 sgn=(-1d0)**int(pyr(0)+0.5d0)
47696 DO 230 j=1,3
47697 p(n+i,j)=sgn*p(n+i,j)/pa
47698 230 CONTINUE
47699 240 CONTINUE
47700
47701C...Middle axis orthogonal to other two. Fill other codes.
47702 sgn=(-1d0)**int(pyr(0)+0.5d0)
47703 p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
47704 p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
47705 p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
47706 DO 260 i=1,3
47707 k(n+i,1)=31
47708 k(n+i,2)=95
47709 k(n+i,3)=i
47710 k(n+i,4)=0
47711 k(n+i,5)=0
47712 p(n+i,5)=0d0
47713 DO 250 j=1,5
47714 v(i,j)=0d0
47715 250 CONTINUE
47716 260 CONTINUE
47717
47718C...Calculate sphericity and aplanarity. Select storing option.
47719 sph=1.5d0*(p(n+2,4)+p(n+3,4))
47720 apl=1.5d0*p(n+3,4)
47721 mstu(61)=n+1
47722 mstu(62)=np
47723 IF(mstu(43).LE.1) mstu(3)=3
47724 IF(mstu(43).GE.2) n=n+3
47725
47726 RETURN
47727 END
47728
47729C*********************************************************************
47730
47731C...PYTHRU
47732C...Performs thrust analysis to give thrust, oblateness
47733C...and the related event axes.
47734
47735 SUBROUTINE pythru(THR,OBL)
47736
47737C...Double precision and integer declarations.
47738 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47739 IMPLICIT INTEGER(I-N)
47740 INTEGER PYK,PYCHGE,PYCOMP
47741C...Commonblocks.
47742 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
47743 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47744 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47745 SAVE /pyjets/,/pydat1/,/pydat2/
47746C...Local arrays.
47747 dimension tdi(3),tpr(3)
47748
47749C...Take copy of particles that are to be considered in thrust analysis.
47750 np=0
47751 ps=0d0
47752 DO 100 i=1,n
47753 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
47754 IF(mstu(41).GE.2) THEN
47755 kc=pycomp(k(i,2))
47756 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
47757 & kc.EQ.18) GOTO 100
47758 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
47759 & GOTO 100
47760 ENDIF
47761 IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
47762 CALL pyerrm(11,'(PYTHRU:) no more memory left in PYJETS')
47763 thr=-2d0
47764 obl=-2d0
47765 RETURN
47766 ENDIF
47767 np=np+1
47768 k(n+np,1)=23
47769 p(n+np,1)=p(i,1)
47770 p(n+np,2)=p(i,2)
47771 p(n+np,3)=p(i,3)
47772 p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
47773 p(n+np,5)=1d0
47774 IF(abs(paru(42)-1d0).GT.0.001d0) p(n+np,5)=
47775 & p(n+np,4)**(paru(42)-1d0)
47776 ps=ps+p(n+np,4)*p(n+np,5)
47777 100 CONTINUE
47778
47779C...Very low multiplicities (0 or 1) not considered.
47780 IF(np.LE.1) THEN
47781 CALL pyerrm(8,'(PYTHRU:) too few particles for analysis')
47782 thr=-1d0
47783 obl=-1d0
47784 RETURN
47785 ENDIF
47786
47787C...Loop over thrust and major. T axis along z direction in latter case.
47788 DO 320 ild=1,2
47789 IF(ild.EQ.2) THEN
47790 k(n+np+1,1)=31
47791 phi=pyangl(p(n+np+1,1),p(n+np+1,2))
47792 mstu(33)=1
47793 CALL pyrobo(n+1,n+np+1,0d0,-phi,0d0,0d0,0d0)
47794 the=pyangl(p(n+np+1,3),p(n+np+1,1))
47795 CALL pyrobo(n+1,n+np+1,-the,0d0,0d0,0d0,0d0)
47796 ENDIF
47797
47798C...Find and order particles with highest p (pT for major).
47799 DO 110 ilf=n+np+4,n+np+mstu(44)+4
47800 p(ilf,4)=0d0
47801 110 CONTINUE
47802 DO 160 i=n+1,n+np
47803 IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
47804 DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
47805 IF(p(i,4).LE.p(ilf,4)) GOTO 140
47806 DO 120 j=1,5
47807 p(ilf+1,j)=p(ilf,j)
47808 120 CONTINUE
47809 130 CONTINUE
47810 ilf=n+np+3
47811 140 DO 150 j=1,5
47812 p(ilf+1,j)=p(i,j)
47813 150 CONTINUE
47814 160 CONTINUE
47815
47816C...Find and order initial axes with highest thrust (major).
47817 DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
47818 p(ilg,4)=0d0
47819 170 CONTINUE
47820 nc=2**(min(mstu(44),np)-1)
47821 DO 250 ilc=1,nc
47822 DO 180 j=1,3
47823 tdi(j)=0d0
47824 180 CONTINUE
47825 DO 200 ilf=1,min(mstu(44),np)
47826 sgn=p(n+np+ilf+3,5)
47827 IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
47828 DO 190 j=1,4-ild
47829 tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
47830 190 CONTINUE
47831 200 CONTINUE
47832 tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
47833 DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
47834 IF(tds.LE.p(ilg,4)) GOTO 230
47835 DO 210 j=1,4
47836 p(ilg+1,j)=p(ilg,j)
47837 210 CONTINUE
47838 220 CONTINUE
47839 ilg=n+np+mstu(44)+4
47840 230 DO 240 j=1,3
47841 p(ilg+1,j)=tdi(j)
47842 240 CONTINUE
47843 p(ilg+1,4)=tds
47844 250 CONTINUE
47845
47846C...Iterate direction of axis until stable maximum.
47847 p(n+np+ild,4)=0d0
47848 ilg=0
47849 260 ilg=ilg+1
47850 thp=0d0
47851 270 thps=thp
47852 DO 280 j=1,3
47853 IF(thp.LE.1d-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
47854 IF(thp.GT.1d-10) tdi(j)=tpr(j)
47855 tpr(j)=0d0
47856 280 CONTINUE
47857 DO 300 i=n+1,n+np
47858 sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
47859 DO 290 j=1,4-ild
47860 tpr(j)=tpr(j)+sgn*p(i,j)
47861 290 CONTINUE
47862 300 CONTINUE
47863 thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
47864 IF(thp.GE.thps+paru(48)) GOTO 270
47865
47866C...Save good axis. Try new initial axis until a number of tries agree.
47867 IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) GOTO 260
47868 IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
47869 iagr=0
47870 sgn=(-1d0)**int(pyr(0)+0.5d0)
47871 DO 310 j=1,3
47872 p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
47873 310 CONTINUE
47874 p(n+np+ild,4)=thp
47875 p(n+np+ild,5)=0d0
47876 ENDIF
47877 iagr=iagr+1
47878 IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) GOTO 260
47879 320 CONTINUE
47880
47881C...Find minor axis and value by orthogonality.
47882 sgn=(-1d0)**int(pyr(0)+0.5d0)
47883 p(n+np+3,1)=-sgn*p(n+np+2,2)
47884 p(n+np+3,2)=sgn*p(n+np+2,1)
47885 p(n+np+3,3)=0d0
47886 thp=0d0
47887 DO 330 i=n+1,n+np
47888 thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
47889 330 CONTINUE
47890 p(n+np+3,4)=thp/ps
47891 p(n+np+3,5)=0d0
47892
47893C...Fill axis information. Rotate back to original coordinate system.
47894 DO 350 ild=1,3
47895 k(n+ild,1)=31
47896 k(n+ild,2)=96
47897 k(n+ild,3)=ild
47898 k(n+ild,4)=0
47899 k(n+ild,5)=0
47900 DO 340 j=1,5
47901 p(n+ild,j)=p(n+np+ild,j)
47902 v(n+ild,j)=0d0
47903 340 CONTINUE
47904 350 CONTINUE
47905 CALL pyrobo(n+1,n+3,the,phi,0d0,0d0,0d0)
47906
47907C...Calculate thrust and oblateness. Select storing option.
47908 thr=p(n+1,4)
47909 obl=p(n+2,4)-p(n+3,4)
47910 mstu(61)=n+1
47911 mstu(62)=np
47912 IF(mstu(43).LE.1) mstu(3)=3
47913 IF(mstu(43).GE.2) n=n+3
47914
47915 RETURN
47916 END
47917
47918C*********************************************************************
47919
47920C...PYCLUS
47921C...Subdivides the particle content of an event into jets/clusters.
47922
47923 SUBROUTINE pyclus(NJET)
47924
47925C...Double precision and integer declarations.
47926 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47927 IMPLICIT INTEGER(I-N)
47928 INTEGER PYK,PYCHGE,PYCOMP
47929C...Commonblocks.
47930 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
47931 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47932 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47933 SAVE /pyjets/,/pydat1/,/pydat2/
47934C...Local arrays and saved variables.
47935 dimension ps(5)
47936 SAVE nsav,np,ps,pss,rinit,npre,nrem
47937
47938C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
47939 r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
47940 &p(i1,3)*p(i2,3))*2d0*p(i1,5)*p(i2,5)/(0.0001d0+p(i1,5)+p(i2,5))**2
47941 r2m(i1,i2)=2d0*p(i1,4)*p(i2,4)*(1d0-(p(i1,1)*p(i2,1)+p(i1,2)*
47942 &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
47943 r2d(i1,i2)=2d0*min(p(i1,4),p(i2,4))**2*(1d0-(p(i1,1)*p(i2,1)+
47944 &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
47945
47946C...If first time, reset. If reentering, skip preliminaries.
47947 IF(mstu(48).LE.0) THEN
47948 np=0
47949 DO 100 j=1,5
47950 ps(j)=0d0
47951 100 CONTINUE
47952 pss=0d0
47953 pimass=pmas(pycomp(211),1)
47954 ELSE
47955 njet=nsav
47956 IF(mstu(43).GE.2) n=n-njet
47957 DO 110 i=n+1,n+njet
47958 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
47959 110 CONTINUE
47960 IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
47961 r2acc=paru(44)**2
47962 ELSE
47963 r2acc=paru(45)*ps(5)**2
47964 ENDIF
47965 nloop=0
47966 GOTO 300
47967 ENDIF
47968
47969C...Find which particles are to be considered in cluster search.
47970 DO 140 i=1,n
47971 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
47972 IF(mstu(41).GE.2) THEN
47973 kc=pycomp(k(i,2))
47974 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
47975 & kc.EQ.18) GOTO 140
47976 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
47977 & GOTO 140
47978 ENDIF
47979 IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
47980 CALL pyerrm(11,'(PYCLUS:) no more memory left in PYJETS')
47981 njet=-1
47982 RETURN
47983 ENDIF
47984
47985C...Take copy of these particles, with space left for jets later on.
47986 np=np+1
47987 k(n+np,3)=i
47988 DO 120 j=1,5
47989 p(n+np,j)=p(i,j)
47990 120 CONTINUE
47991 IF(mstu(42).EQ.0) p(n+np,5)=0d0
47992 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
47993 p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
47994 p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
47995 DO 130 j=1,4
47996 ps(j)=ps(j)+p(n+np,j)
47997 130 CONTINUE
47998 pss=pss+p(n+np,5)
47999 140 CONTINUE
48000 DO 160 i=n+1,n+np
48001 k(i+np,3)=k(i,3)
48002 DO 150 j=1,5
48003 p(i+np,j)=p(i,j)
48004 150 CONTINUE
48005 160 CONTINUE
48006 ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
48007
48008C...Very low multiplicities not considered.
48009 IF(np.LT.mstu(47)) THEN
48010 CALL pyerrm(8,'(PYCLUS:) too few particles for analysis')
48011 njet=-1
48012 RETURN
48013 ENDIF
48014
48015C...Find precluster configuration. If too few jets, make harder cuts.
48016 nloop=0
48017 IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
48018 r2acc=paru(44)**2
48019 ELSE
48020 r2acc=paru(45)*ps(5)**2
48021 ENDIF
48022 rinit=1.25d0*paru(43)
48023 IF(np.LE.mstu(47)+2) rinit=0d0
48024 170 rinit=0.8d0*rinit
48025 npre=0
48026 nrem=np
48027 DO 180 i=n+np+1,n+2*np
48028 k(i,4)=0
48029 180 CONTINUE
48030
48031C...Sum up small momentum region. Jet if enough absolute momentum.
48032 IF(mstu(46).LE.2) THEN
48033 DO 190 j=1,4
48034 p(n+1,j)=0d0
48035 190 CONTINUE
48036 DO 210 i=n+np+1,n+2*np
48037 IF(p(i,5).GT.2d0*rinit) GOTO 210
48038 nrem=nrem-1
48039 k(i,4)=1
48040 DO 200 j=1,4
48041 p(n+1,j)=p(n+1,j)+p(i,j)
48042 200 CONTINUE
48043 210 CONTINUE
48044 p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
48045 IF(p(n+1,5).GT.2d0*rinit) npre=1
48046 IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
48047 IF(nrem.EQ.0) GOTO 170
48048 ENDIF
48049
48050C...Find fastest remaining particle.
48051 220 npre=npre+1
48052 pmax=0d0
48053 DO 230 i=n+np+1,n+2*np
48054 IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) GOTO 230
48055 imax=i
48056 pmax=p(i,5)
48057 230 CONTINUE
48058 DO 240 j=1,5
48059 p(n+npre,j)=p(imax,j)
48060 240 CONTINUE
48061 nrem=nrem-1
48062 k(imax,4)=npre
48063
48064C...Sum up precluster around it according to pT separation.
48065 IF(mstu(46).LE.2) THEN
48066 DO 260 i=n+np+1,n+2*np
48067 IF(k(i,4).NE.0) GOTO 260
48068 r2=r2t(i,imax)
48069 IF(r2.GT.rinit**2) GOTO 260
48070 nrem=nrem-1
48071 k(i,4)=npre
48072 DO 250 j=1,4
48073 p(n+npre,j)=p(n+npre,j)+p(i,j)
48074 250 CONTINUE
48075 260 CONTINUE
48076 p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
48077
48078C...Sum up precluster around it according to mass or
48079C...Durham pT separation.
48080 ELSE
48081 270 imin=0
48082 r2min=rinit**2
48083 DO 280 i=n+np+1,n+2*np
48084 IF(k(i,4).NE.0) GOTO 280
48085 IF(mstu(46).LE.4) THEN
48086 r2=r2m(i,n+npre)
48087 ELSE
48088 r2=r2d(i,n+npre)
48089 ENDIF
48090 IF(r2.GE.r2min) GOTO 280
48091 imin=i
48092 r2min=r2
48093 280 CONTINUE
48094 IF(imin.NE.0) THEN
48095 DO 290 j=1,4
48096 p(n+npre,j)=p(n+npre,j)+p(imin,j)
48097 290 CONTINUE
48098 p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
48099 nrem=nrem-1
48100 k(imin,4)=npre
48101 GOTO 270
48102 ENDIF
48103 ENDIF
48104
48105C...Check if more preclusters to be found. Start over if too few.
48106 IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
48107 IF(nrem.GT.0) GOTO 220
48108 njet=npre
48109
48110C...Reassign all particles to nearest jet. Sum up new jet momenta.
48111 300 tsav=0d0
48112 psjt=0d0
48113 310 IF(mstu(46).LE.1) THEN
48114 DO 330 i=n+1,n+njet
48115 DO 320 j=1,4
48116 v(i,j)=0d0
48117 320 CONTINUE
48118 330 CONTINUE
48119 DO 360 i=n+np+1,n+2*np
48120 r2min=pss**2
48121 DO 340 ijet=n+1,n+njet
48122 IF(p(ijet,5).LT.rinit) GOTO 340
48123 r2=r2t(i,ijet)
48124 IF(r2.GE.r2min) GOTO 340
48125 imin=ijet
48126 r2min=r2
48127 340 CONTINUE
48128 k(i,4)=imin-n
48129 DO 350 j=1,4
48130 v(imin,j)=v(imin,j)+p(i,j)
48131 350 CONTINUE
48132 360 CONTINUE
48133 psjt=0d0
48134 DO 380 i=n+1,n+njet
48135 DO 370 j=1,4
48136 p(i,j)=v(i,j)
48137 370 CONTINUE
48138 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
48139 psjt=psjt+p(i,5)
48140 380 CONTINUE
48141 ENDIF
48142
48143C...Find two closest jets.
48144 r2min=2d0*max(r2acc,ps(5)**2)
48145 DO 400 itry1=n+1,n+njet-1
48146 DO 390 itry2=itry1+1,n+njet
48147 IF(mstu(46).LE.2) THEN
48148 r2=r2t(itry1,itry2)
48149 ELSEIF(mstu(46).LE.4) THEN
48150 r2=r2m(itry1,itry2)
48151 ELSE
48152 r2=r2d(itry1,itry2)
48153 ENDIF
48154 IF(r2.GE.r2min) GOTO 390
48155 imin1=itry1
48156 imin2=itry2
48157 r2min=r2
48158 390 CONTINUE
48159 400 CONTINUE
48160
48161C...If allowed, join two closest jets and start over.
48162 IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
48163 irec=min(imin1,imin2)
48164 idel=max(imin1,imin2)
48165 DO 410 j=1,4
48166 p(irec,j)=p(imin1,j)+p(imin2,j)
48167 410 CONTINUE
48168 p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
48169 DO 430 i=idel+1,n+njet
48170 DO 420 j=1,5
48171 p(i-1,j)=p(i,j)
48172 420 CONTINUE
48173 430 CONTINUE
48174 IF(mstu(46).GE.2) THEN
48175 DO 440 i=n+np+1,n+2*np
48176 iori=n+k(i,4)
48177 IF(iori.EQ.idel) k(i,4)=irec-n
48178 IF(iori.GT.idel) k(i,4)=k(i,4)-1
48179 440 CONTINUE
48180 ENDIF
48181 njet=njet-1
48182 GOTO 300
48183
48184C...Divide up broad jet if empty cluster in list of final ones.
48185 ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
48186 DO 450 i=n+1,n+njet
48187 k(i,5)=0
48188 450 CONTINUE
48189 DO 460 i=n+np+1,n+2*np
48190 k(n+k(i,4),5)=k(n+k(i,4),5)+1
48191 460 CONTINUE
48192 iemp=0
48193 DO 470 i=n+1,n+njet
48194 IF(k(i,5).EQ.0) iemp=i
48195 470 CONTINUE
48196 IF(iemp.NE.0) THEN
48197 nloop=nloop+1
48198 ispl=0
48199 r2max=0d0
48200 DO 480 i=n+np+1,n+2*np
48201 IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) GOTO 480
48202 ijet=n+k(i,4)
48203 r2=r2t(i,ijet)
48204 IF(r2.LE.r2max) GOTO 480
48205 ispl=i
48206 r2max=r2
48207 480 CONTINUE
48208 IF(ispl.NE.0) THEN
48209 ijet=n+k(ispl,4)
48210 DO 490 j=1,4
48211 p(iemp,j)=p(ispl,j)
48212 p(ijet,j)=p(ijet,j)-p(ispl,j)
48213 490 CONTINUE
48214 p(iemp,5)=p(ispl,5)
48215 p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
48216 IF(nloop.LE.2) GOTO 300
48217 ENDIF
48218 ENDIF
48219 ENDIF
48220
48221C...If generalized thrust has not yet converged, continue iteration.
48222 IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
48223 &THEN
48224 tsav=psjt/pss
48225 GOTO 310
48226 ENDIF
48227
48228C...Reorder jets according to energy.
48229 DO 510 i=n+1,n+njet
48230 DO 500 j=1,5
48231 v(i,j)=p(i,j)
48232 500 CONTINUE
48233 510 CONTINUE
48234 DO 540 inew=n+1,n+njet
48235 pemax=0d0
48236 DO 520 itry=n+1,n+njet
48237 IF(v(itry,4).LE.pemax) GOTO 520
48238 imax=itry
48239 pemax=v(itry,4)
48240 520 CONTINUE
48241 k(inew,1)=31
48242 k(inew,2)=97
48243 k(inew,3)=inew-n
48244 k(inew,4)=0
48245 DO 530 j=1,5
48246 p(inew,j)=v(imax,j)
48247 530 CONTINUE
48248 v(imax,4)=-1d0
48249 k(imax,5)=inew
48250 540 CONTINUE
48251
48252C...Clean up particle-jet assignments and jet information.
48253 DO 550 i=n+np+1,n+2*np
48254 iori=k(n+k(i,4),5)
48255 k(i,4)=iori-n
48256 IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
48257 k(iori,4)=k(iori,4)+1
48258 550 CONTINUE
48259 iemp=0
48260 psjt=0d0
48261 DO 570 i=n+1,n+njet
48262 k(i,5)=0
48263 psjt=psjt+p(i,5)
48264 p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0d0))
48265 DO 560 j=1,5
48266 v(i,j)=0d0
48267 560 CONTINUE
48268 IF(k(i,4).EQ.0) iemp=i
48269 570 CONTINUE
48270
48271C...Select storing option. Output variables. Check for failure.
48272 mstu(61)=n+1
48273 mstu(62)=np
48274 mstu(63)=npre
48275 paru(61)=ps(5)
48276 paru(62)=psjt/pss
48277 paru(63)=sqrt(r2min)
48278 IF(njet.LE.1) paru(63)=0d0
48279 IF(iemp.NE.0) THEN
48280 CALL pyerrm(8,'(PYCLUS:) failed to reconstruct as requested')
48281 njet=-1
48282 RETURN
48283 ENDIF
48284 IF(mstu(43).LE.1) mstu(3)=max(0,njet)
48285 IF(mstu(43).GE.2) n=n+max(0,njet)
48286 nsav=njet
48287
48288 RETURN
48289 END
48290
48291C*********************************************************************
48292
48293C...PYCELL
48294C...Provides a simple way of jet finding in eta-phi-ET coordinates,
48295C...as used for calorimeters at hadron colliders.
48296
48297 SUBROUTINE pycell(NJET)
48298
48299C...Double precision and integer declarations.
48300 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48301 IMPLICIT INTEGER(I-N)
48302 INTEGER PYK,PYCHGE,PYCOMP
48303C...Commonblocks.
48304 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
48305 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48306 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48307 SAVE /pyjets/,/pydat1/,/pydat2/
48308
48309C...Loop over all particles. Find cell that was hit by given particle.
48310 ptlrat=1d0/sinh(paru(51))**2
48311 np=0
48312 nc=n
48313 DO 110 i=1,n
48314 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
48315 IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) GOTO 110
48316 IF(mstu(41).GE.2) THEN
48317 kc=pycomp(k(i,2))
48318 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
48319 & kc.EQ.18) GOTO 110
48320 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
48321 & GOTO 110
48322 ENDIF
48323 np=np+1
48324 pt=sqrt(p(i,1)**2+p(i,2)**2)
48325 eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
48326 ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5d0*
48327 & (eta/paru(51)+1d0))))
48328 phi=pyangl(p(i,1),p(i,2))
48329 iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5d0*
48330 & (phi/paru(1)+1d0))))
48331 ietph=mstu(52)*ieta+iphi
48332
48333C...Add to cell already hit, or book new cell.
48334 DO 100 ic=n+1,nc
48335 IF(ietph.EQ.k(ic,3)) THEN
48336 k(ic,4)=k(ic,4)+1
48337 p(ic,5)=p(ic,5)+pt
48338 GOTO 110
48339 ENDIF
48340 100 CONTINUE
48341 IF(nc.GE.mstu(4)-mstu(32)-5) THEN
48342 CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
48343 njet=-2
48344 RETURN
48345 ENDIF
48346 nc=nc+1
48347 k(nc,3)=ietph
48348 k(nc,4)=1
48349 k(nc,5)=2
48350 p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
48351 p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
48352 p(nc,5)=pt
48353 110 CONTINUE
48354
48355C...Smear true bin content by calorimeter resolution.
48356 IF(mstu(53).GE.1) THEN
48357 DO 130 ic=n+1,nc
48358 pei=p(ic,5)
48359 IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
48360 120 pef=pei+paru(55)*sqrt(-2d0*log(max(1d-10,pyr(0)))*pei)*
48361 & cos(paru(2)*pyr(0))
48362 IF(pef.LT.0d0.OR.pef.GT.paru(56)*pei) GOTO 120
48363 p(ic,5)=pef
48364 IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
48365 130 CONTINUE
48366 ENDIF
48367
48368C...Remove cells below threshold.
48369 IF(paru(58).GT.0d0) THEN
48370 ncc=nc
48371 nc=n
48372 DO 140 ic=n+1,ncc
48373 IF(p(ic,5).GT.paru(58)) THEN
48374 nc=nc+1
48375 k(nc,3)=k(ic,3)
48376 k(nc,4)=k(ic,4)
48377 k(nc,5)=k(ic,5)
48378 p(nc,1)=p(ic,1)
48379 p(nc,2)=p(ic,2)
48380 p(nc,5)=p(ic,5)
48381 ENDIF
48382 140 CONTINUE
48383 ENDIF
48384
48385C...Find initiator cell: the one with highest pT of not yet used ones.
48386 nj=nc
48387 150 etmax=0d0
48388 DO 160 ic=n+1,nc
48389 IF(k(ic,5).NE.2) GOTO 160
48390 IF(p(ic,5).LE.etmax) GOTO 160
48391 icmax=ic
48392 eta=p(ic,1)
48393 phi=p(ic,2)
48394 etmax=p(ic,5)
48395 160 CONTINUE
48396 IF(etmax.LT.paru(52)) GOTO 220
48397 IF(nj.GE.mstu(4)-mstu(32)-5) THEN
48398 CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
48399 njet=-2
48400 RETURN
48401 ENDIF
48402 k(icmax,5)=1
48403 nj=nj+1
48404 k(nj,4)=0
48405 k(nj,5)=1
48406 p(nj,1)=eta
48407 p(nj,2)=phi
48408 p(nj,3)=0d0
48409 p(nj,4)=0d0
48410 p(nj,5)=0d0
48411
48412C...Sum up unused cells within required distance of initiator.
48413 DO 170 ic=n+1,nc
48414 IF(k(ic,5).EQ.0) GOTO 170
48415 IF(abs(p(ic,1)-eta).GT.paru(54)) GOTO 170
48416 dphia=abs(p(ic,2)-phi)
48417 IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) GOTO 170
48418 phic=p(ic,2)
48419 IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
48420 IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) GOTO 170
48421 k(ic,5)=-k(ic,5)
48422 k(nj,4)=k(nj,4)+k(ic,4)
48423 p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
48424 p(nj,4)=p(nj,4)+p(ic,5)*phic
48425 p(nj,5)=p(nj,5)+p(ic,5)
48426 170 CONTINUE
48427
48428C...Reject cluster below minimum ET, else accept.
48429 IF(p(nj,5).LT.paru(53)) THEN
48430 nj=nj-1
48431 DO 180 ic=n+1,nc
48432 IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
48433 180 CONTINUE
48434 ELSEIF(mstu(54).LE.2) THEN
48435 p(nj,3)=p(nj,3)/p(nj,5)
48436 p(nj,4)=p(nj,4)/p(nj,5)
48437 IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
48438 & p(nj,4))
48439 DO 190 ic=n+1,nc
48440 IF(k(ic,5).LT.0) k(ic,5)=0
48441 190 CONTINUE
48442 ELSE
48443 DO 200 j=1,4
48444 p(nj,j)=0d0
48445 200 CONTINUE
48446 DO 210 ic=n+1,nc
48447 IF(k(ic,5).GE.0) GOTO 210
48448 p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
48449 p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
48450 p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
48451 p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
48452 k(ic,5)=0
48453 210 CONTINUE
48454 ENDIF
48455 GOTO 150
48456
48457C...Arrange clusters in falling ET sequence.
48458 220 DO 250 i=1,nj-nc
48459 etmax=0d0
48460 DO 230 ij=nc+1,nj
48461 IF(k(ij,5).EQ.0) GOTO 230
48462 IF(p(ij,5).LT.etmax) GOTO 230
48463 ijmax=ij
48464 etmax=p(ij,5)
48465 230 CONTINUE
48466 k(ijmax,5)=0
48467 k(n+i,1)=31
48468 k(n+i,2)=98
48469 k(n+i,3)=i
48470 k(n+i,4)=k(ijmax,4)
48471 k(n+i,5)=0
48472 DO 240 j=1,5
48473 p(n+i,j)=p(ijmax,j)
48474 v(n+i,j)=0d0
48475 240 CONTINUE
48476 250 CONTINUE
48477 njet=nj-nc
48478
48479C...Convert to massless or massive four-vectors.
48480 IF(mstu(54).EQ.2) THEN
48481 DO 260 i=n+1,n+njet
48482 eta=p(i,3)
48483 p(i,1)=p(i,5)*cos(p(i,4))
48484 p(i,2)=p(i,5)*sin(p(i,4))
48485 p(i,3)=p(i,5)*sinh(eta)
48486 p(i,4)=p(i,5)*cosh(eta)
48487 p(i,5)=0d0
48488 260 CONTINUE
48489 ELSEIF(mstu(54).GE.3) THEN
48490 DO 270 i=n+1,n+njet
48491 p(i,5)=sqrt(max(0d0,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
48492 270 CONTINUE
48493 ENDIF
48494
48495C...Information about storage.
48496 mstu(61)=n+1
48497 mstu(62)=np
48498 mstu(63)=nc-n
48499 IF(mstu(43).LE.1) mstu(3)=max(0,njet)
48500 IF(mstu(43).GE.2) n=n+max(0,njet)
48501
48502 RETURN
48503 END
48504
48505C*********************************************************************
48506
48507C...PYJMAS
48508C...Determines, approximately, the two jet masses that minimize
48509C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
48510
48511 SUBROUTINE pyjmas(PMH,PML)
48512
48513C...Double precision and integer declarations.
48514 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48515 IMPLICIT INTEGER(I-N)
48516 INTEGER PYK,PYCHGE,PYCOMP
48517C...Commonblocks.
48518 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
48519 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48520 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48521 SAVE /pyjets/,/pydat1/,/pydat2/
48522C...Local arrays.
48523 dimension sm(3,3),sax(3),ps(3,5)
48524
48525C...Reset.
48526 np=0
48527 DO 120 j1=1,3
48528 DO 100 j2=j1,3
48529 sm(j1,j2)=0d0
48530 100 CONTINUE
48531 DO 110 j2=1,4
48532 ps(j1,j2)=0d0
48533 110 CONTINUE
48534 120 CONTINUE
48535 pss=0d0
48536 pimass=pmas(pycomp(211),1)
48537
48538C...Take copy of particles that are to be considered in mass analysis.
48539 DO 170 i=1,n
48540 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 170
48541 IF(mstu(41).GE.2) THEN
48542 kc=pycomp(k(i,2))
48543 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
48544 & kc.EQ.18) GOTO 170
48545 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
48546 & GOTO 170
48547 ENDIF
48548 IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
48549 CALL pyerrm(11,'(PYJMAS:) no more memory left in PYJETS')
48550 pmh=-2d0
48551 pml=-2d0
48552 RETURN
48553 ENDIF
48554 np=np+1
48555 DO 130 j=1,5
48556 p(n+np,j)=p(i,j)
48557 130 CONTINUE
48558 IF(mstu(42).EQ.0) p(n+np,5)=0d0
48559 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
48560 p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
48561
48562C...Fill information in sphericity tensor and total momentum vector.
48563 DO 150 j1=1,3
48564 DO 140 j2=j1,3
48565 sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
48566 140 CONTINUE
48567 150 CONTINUE
48568 pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
48569 DO 160 j=1,4
48570 ps(3,j)=ps(3,j)+p(n+np,j)
48571 160 CONTINUE
48572 170 CONTINUE
48573
48574C...Very low multiplicities (0 or 1) not considered.
48575 IF(np.LE.1) THEN
48576 CALL pyerrm(8,'(PYJMAS:) too few particles for analysis')
48577 pmh=-1d0
48578 pml=-1d0
48579 RETURN
48580 ENDIF
48581 paru(61)=sqrt(max(0d0,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-
48582 &ps(3,3)**2))
48583
48584C...Find largest eigenvalue to matrix (third degree equation).
48585 DO 190 j1=1,3
48586 DO 180 j2=j1,3
48587 sm(j1,j2)=sm(j1,j2)/pss
48588 180 CONTINUE
48589 190 CONTINUE
48590 sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
48591 &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
48592 sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
48593 &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
48594 &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
48595 sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
48596 sma=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
48597
48598C...Find largest eigenvector by solving equation system.
48599 DO 210 j1=1,3
48600 sm(j1,j1)=sm(j1,j1)-sma
48601 DO 200 j2=j1+1,3
48602 sm(j2,j1)=sm(j1,j2)
48603 200 CONTINUE
48604 210 CONTINUE
48605 smax=0d0
48606 DO 230 j1=1,3
48607 DO 220 j2=1,3
48608 IF(abs(sm(j1,j2)).LE.smax) GOTO 220
48609 ja=j1
48610 jb=j2
48611 smax=abs(sm(j1,j2))
48612 220 CONTINUE
48613 230 CONTINUE
48614 smax=0d0
48615 DO 250 j3=ja+1,ja+2
48616 j1=j3-3*((j3-1)/3)
48617 rl=sm(j1,jb)/sm(ja,jb)
48618 DO 240 j2=1,3
48619 sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
48620 IF(abs(sm(j1,j2)).LE.smax) GOTO 240
48621 jc=j1
48622 smax=abs(sm(j1,j2))
48623 240 CONTINUE
48624 250 CONTINUE
48625 jb1=jb+1-3*(jb/3)
48626 jb2=jb+2-3*((jb+1)/3)
48627 sax(jb1)=-sm(jc,jb2)
48628 sax(jb2)=sm(jc,jb1)
48629 sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
48630
48631C...Divide particles into two initial clusters by hemisphere.
48632 DO 270 i=n+1,n+np
48633 psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
48634 is=1
48635 IF(psax.LT.0d0) is=2
48636 k(i,3)=is
48637 DO 260 j=1,4
48638 ps(is,j)=ps(is,j)+p(i,j)
48639 260 CONTINUE
48640 270 CONTINUE
48641 pms=max(1d-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
48642 &max(1d-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
48643
48644C...Reassign one particle at a time; find maximum decrease of m^2 sum.
48645 280 pmd=0d0
48646 im=0
48647 DO 290 j=1,4
48648 ps(3,j)=ps(1,j)-ps(2,j)
48649 290 CONTINUE
48650 DO 300 i=n+1,n+np
48651 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)
48652 IF(k(i,3).EQ.1) pmdi=2d0*(p(i,5)**2-pps)
48653 IF(k(i,3).EQ.2) pmdi=2d0*(p(i,5)**2+pps)
48654 IF(pmdi.LT.pmd) THEN
48655 pmd=pmdi
48656 im=i
48657 ENDIF
48658 300 CONTINUE
48659
48660C...Loop back if significant reduction in sum of m^2.
48661 IF(pmd.LT.-paru(48)*pms) THEN
48662 pms=pms+pmd
48663 is=k(im,3)
48664 DO 310 j=1,4
48665 ps(is,j)=ps(is,j)-p(im,j)
48666 ps(3-is,j)=ps(3-is,j)+p(im,j)
48667 310 CONTINUE
48668 k(im,3)=3-is
48669 GOTO 280
48670 ENDIF
48671
48672C...Final masses and output.
48673 mstu(61)=n+1
48674 mstu(62)=np
48675 ps(1,5)=sqrt(max(0d0,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
48676 ps(2,5)=sqrt(max(0d0,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
48677 pmh=max(ps(1,5),ps(2,5))
48678 pml=min(ps(1,5),ps(2,5))
48679
48680 RETURN
48681 END
48682
48683C*********************************************************************
48684
48685C...PYFOWO
48686C...Calculates the first few Fox-Wolfram moments.
48687
48688 SUBROUTINE pyfowo(H10,H20,H30,H40)
48689
48690C...Double precision and integer declarations.
48691 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48692 IMPLICIT INTEGER(I-N)
48693 INTEGER PYK,PYCHGE,PYCOMP
48694C...Commonblocks.
48695 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
48696 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48697 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48698 SAVE /pyjets/,/pydat1/,/pydat2/
48699
48700C...Copy momenta for particles and calculate H0.
48701 np=0
48702 h0=0d0
48703 hd=0d0
48704 DO 110 i=1,n
48705 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
48706 IF(mstu(41).GE.2) THEN
48707 kc=pycomp(k(i,2))
48708 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
48709 & kc.EQ.18) GOTO 110
48710 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
48711 & GOTO 110
48712 ENDIF
48713 IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
48714 CALL pyerrm(11,'(PYFOWO:) no more memory left in PYJETS')
48715 h10=-1d0
48716 h20=-1d0
48717 h30=-1d0
48718 h40=-1d0
48719 RETURN
48720 ENDIF
48721 np=np+1
48722 DO 100 j=1,3
48723 p(n+np,j)=p(i,j)
48724 100 CONTINUE
48725 p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
48726 h0=h0+p(n+np,4)
48727 hd=hd+p(n+np,4)**2
48728 110 CONTINUE
48729 h0=h0**2
48730
48731C...Very low multiplicities (0 or 1) not considered.
48732 IF(np.LE.1) THEN
48733 CALL pyerrm(8,'(PYFOWO:) too few particles for analysis')
48734 h10=-1d0
48735 h20=-1d0
48736 h30=-1d0
48737 h40=-1d0
48738 RETURN
48739 ENDIF
48740
48741C...Calculate H1 - H4.
48742 h10=0d0
48743 h20=0d0
48744 h30=0d0
48745 h40=0d0
48746 DO 130 i1=n+1,n+np
48747 DO 120 i2=i1+1,n+np
48748 cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
48749 & (p(i1,4)*p(i2,4))
48750 h10=h10+p(i1,4)*p(i2,4)*cthe
48751 h20=h20+p(i1,4)*p(i2,4)*(1.5d0*cthe**2-0.5d0)
48752 h30=h30+p(i1,4)*p(i2,4)*(2.5d0*cthe**3-1.5d0*cthe)
48753 h40=h40+p(i1,4)*p(i2,4)*(4.375d0*cthe**4-3.75d0*cthe**2+
48754 & 0.375d0)
48755 120 CONTINUE
48756 130 CONTINUE
48757
48758C...Calculate H1/H0 - H4/H0. Output.
48759 mstu(61)=n+1
48760 mstu(62)=np
48761 h10=(hd+2d0*h10)/h0
48762 h20=(hd+2d0*h20)/h0
48763 h30=(hd+2d0*h30)/h0
48764 h40=(hd+2d0*h40)/h0
48765
48766 RETURN
48767 END
48768
48769C*********************************************************************
48770
48771C...PYTABU
48772C...Evaluates various properties of an event, with statistics
48773C...accumulated during the course of the run and
48774C...printed at the end.
48775
48776 SUBROUTINE pytabu(MTABU)
48777
48778C...Double precision and integer declarations.
48779 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48780 IMPLICIT INTEGER(I-N)
48781 INTEGER PYK,PYCHGE,PYCOMP
48782C...Commonblocks.
48783 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
48784 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48785 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48786 common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
48787 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
48788C...Local arrays, character variables, saved variables and data.
48789 dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
48790 &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
48791 &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
48792 &kfdm(8),kfdc(200,0:8),npdc(200)
48793 SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
48794 &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
48795 &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
48796 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
48797 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
48798 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
48799 &nevee/0/,fe1ec/50*0d0/,fe2ec/50*0d0/,fe1ea/25*0d0/,fe2ea/25*0d0/,
48800 &nevdc/0/,nkfdc/0/,nredc/0/
48801
48802C...Reset statistics on initial parton state.
48803 IF(mtabu.EQ.10) THEN
48804 nevis=0
48805 nkfis=0
48806
48807C...Identify and order flavour content of initial state.
48808 ELSEIF(mtabu.EQ.11) THEN
48809 nevis=nevis+1
48810 kfm1=2*iabs(mstu(161))
48811 IF(mstu(161).GT.0) kfm1=kfm1-1
48812 kfm2=2*iabs(mstu(162))
48813 IF(mstu(162).GT.0) kfm2=kfm2-1
48814 kfmn=min(kfm1,kfm2)
48815 kfmx=max(kfm1,kfm2)
48816 DO 100 i=1,nkfis
48817 IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
48818 ikfis=-i
48819 GOTO 110
48820 ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
48821 & kfmx.LT.kfis(i,2))) THEN
48822 ikfis=i
48823 GOTO 110
48824 ENDIF
48825 100 CONTINUE
48826 ikfis=nkfis+1
48827 110 IF(ikfis.LT.0) THEN
48828 ikfis=-ikfis
48829 ELSE
48830 IF(nkfis.GE.100) RETURN
48831 DO 130 i=nkfis,ikfis,-1
48832 kfis(i+1,1)=kfis(i,1)
48833 kfis(i+1,2)=kfis(i,2)
48834 DO 120 j=0,10
48835 npis(i+1,j)=npis(i,j)
48836 120 CONTINUE
48837 130 CONTINUE
48838 nkfis=nkfis+1
48839 kfis(ikfis,1)=kfmn
48840 kfis(ikfis,2)=kfmx
48841 DO 140 j=0,10
48842 npis(ikfis,j)=0
48843 140 CONTINUE
48844 ENDIF
48845 npis(ikfis,0)=npis(ikfis,0)+1
48846
48847C...Count number of partons in initial state.
48848 np=0
48849 DO 160 i=1,n
48850 IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
48851 ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
48852 ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
48853 & THEN
48854 ELSE
48855 im=i
48856 150 im=k(im,3)
48857 IF(im.LE.0.OR.im.GT.n) THEN
48858 np=np+1
48859 ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
48860 np=np+1
48861 ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
48862 ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10)
48863 & .NE.0) THEN
48864 ELSE
48865 GOTO 150
48866 ENDIF
48867 ENDIF
48868 160 CONTINUE
48869 npco=max(np,1)
48870 IF(np.GE.6) npco=6
48871 IF(np.GE.8) npco=7
48872 IF(np.GE.11) npco=8
48873 IF(np.GE.16) npco=9
48874 IF(np.GE.26) npco=10
48875 npis(ikfis,npco)=npis(ikfis,npco)+1
48876 mstu(62)=np
48877
48878C...Write statistics on initial parton state.
48879 ELSEIF(mtabu.EQ.12) THEN
48880 fac=1d0/max(1,nevis)
48881 WRITE(mstu(11),5000) nevis
48882 DO 170 i=1,nkfis
48883 kfmn=kfis(i,1)
48884 IF(kfmn.EQ.0) kfmn=kfis(i,2)
48885 kfm1=(kfmn+1)/2
48886 IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
48887 CALL pyname(kfm1,chau)
48888 chis(1)=chau(1:12)
48889 IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
48890 kfmx=kfis(i,2)
48891 IF(kfis(i,1).EQ.0) kfmx=0
48892 kfm2=(kfmx+1)/2
48893 IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
48894 CALL pyname(kfm2,chau)
48895 chis(2)=chau(1:12)
48896 IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
48897 WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
48898 & (npis(i,j)/dble(npis(i,0)),j=1,10)
48899 170 CONTINUE
48900
48901C...Copy statistics on initial parton state into /PYJETS/.
48902 ELSEIF(mtabu.EQ.13) THEN
48903 fac=1d0/max(1,nevis)
48904 DO 190 i=1,nkfis
48905 kfmn=kfis(i,1)
48906 IF(kfmn.EQ.0) kfmn=kfis(i,2)
48907 kfm1=(kfmn+1)/2
48908 IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
48909 kfmx=kfis(i,2)
48910 IF(kfis(i,1).EQ.0) kfmx=0
48911 kfm2=(kfmx+1)/2
48912 IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
48913 k(i,1)=32
48914 k(i,2)=99
48915 k(i,3)=kfm1
48916 k(i,4)=kfm2
48917 k(i,5)=npis(i,0)
48918 DO 180 j=1,5
48919 p(i,j)=fac*npis(i,j)
48920 v(i,j)=fac*npis(i,j+5)
48921 180 CONTINUE
48922 190 CONTINUE
48923 n=nkfis
48924 DO 200 j=1,5
48925 k(n+1,j)=0
48926 p(n+1,j)=0d0
48927 v(n+1,j)=0d0
48928 200 CONTINUE
48929 k(n+1,1)=32
48930 k(n+1,2)=99
48931 k(n+1,5)=nevis
48932 mstu(3)=1
48933
48934C...Reset statistics on number of particles/partons.
48935 ELSEIF(mtabu.EQ.20) THEN
48936 nevfs=0
48937 nprfs=0
48938 nfifs=0
48939 nchfs=0
48940 nkffs=0
48941
48942C...Identify whether particle/parton is primary or not.
48943 ELSEIF(mtabu.EQ.21) THEN
48944 nevfs=nevfs+1
48945 mstu(62)=0
48946 DO 260 i=1,n
48947 IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) GOTO 260
48948 mstu(62)=mstu(62)+1
48949 kc=pycomp(k(i,2))
48950 mpri=0
48951 IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
48952 mpri=1
48953 ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
48954 mpri=1
48955 ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
48956 mpri=1
48957 ELSEIF(kc.EQ.0) THEN
48958 ELSEIF(k(k(i,3),1).EQ.13) THEN
48959 im=k(k(i,3),3)
48960 IF(im.LE.0.OR.im.GT.n) THEN
48961 mpri=1
48962 ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
48963 mpri=1
48964 ENDIF
48965 ELSEIF(kchg(kc,2).EQ.0) THEN
48966 kcm=pycomp(k(k(i,3),2))
48967 IF(kcm.NE.0) THEN
48968 IF(kchg(kcm,2).NE.0) mpri=1
48969 ENDIF
48970 ENDIF
48971 IF(kc.NE.0.AND.mpri.EQ.1) THEN
48972 IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
48973 ENDIF
48974 IF(k(i,1).LE.10) THEN
48975 nfifs=nfifs+1
48976 IF(pychge(k(i,2)).NE.0) nchfs=nchfs+1
48977 ENDIF
48978
48979C...Fill statistics on number of particles/partons in event.
48980 kfa=iabs(k(i,2))
48981 kfs=3-isign(1,k(i,2))-mpri
48982 DO 210 ip=1,nkffs
48983 IF(kfa.EQ.kffs(ip)) THEN
48984 ikffs=-ip
48985 GOTO 220
48986 ELSEIF(kfa.LT.kffs(ip)) THEN
48987 ikffs=ip
48988 GOTO 220
48989 ENDIF
48990 210 CONTINUE
48991 ikffs=nkffs+1
48992 220 IF(ikffs.LT.0) THEN
48993 ikffs=-ikffs
48994 ELSE
48995 IF(nkffs.GE.400) RETURN
48996 DO 240 ip=nkffs,ikffs,-1
48997 kffs(ip+1)=kffs(ip)
48998 DO 230 j=1,4
48999 npfs(ip+1,j)=npfs(ip,j)
49000 230 CONTINUE
49001 240 CONTINUE
49002 nkffs=nkffs+1
49003 kffs(ikffs)=kfa
49004 DO 250 j=1,4
49005 npfs(ikffs,j)=0
49006 250 CONTINUE
49007 ENDIF
49008 npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
49009 260 CONTINUE
49010
49011C...Write statistics on particle/parton composition of events.
49012 ELSEIF(mtabu.EQ.22) THEN
49013 fac=1d0/max(1,nevfs)
49014 WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
49015 DO 270 i=1,nkffs
49016 CALL pyname(kffs(i),chau)
49017 kc=pycomp(kffs(i))
49018 mdcyf=0
49019 IF(kc.NE.0) mdcyf=mdcy(kc,1)
49020 WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
49021 & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
49022 270 CONTINUE
49023
49024C...Copy particle/parton composition information into /PYJETS/.
49025 ELSEIF(mtabu.EQ.23) THEN
49026 fac=1d0/max(1,nevfs)
49027 DO 290 i=1,nkffs
49028 k(i,1)=32
49029 k(i,2)=99
49030 k(i,3)=kffs(i)
49031 k(i,4)=0
49032 k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
49033 DO 280 j=1,4
49034 p(i,j)=fac*npfs(i,j)
49035 v(i,j)=0d0
49036 280 CONTINUE
49037 p(i,5)=fac*k(i,5)
49038 v(i,5)=0d0
49039 290 CONTINUE
49040 n=nkffs
49041 DO 300 j=1,5
49042 k(n+1,j)=0
49043 p(n+1,j)=0d0
49044 v(n+1,j)=0d0
49045 300 CONTINUE
49046 k(n+1,1)=32
49047 k(n+1,2)=99
49048 k(n+1,5)=nevfs
49049 p(n+1,1)=fac*nprfs
49050 p(n+1,2)=fac*nfifs
49051 p(n+1,3)=fac*nchfs
49052 mstu(3)=1
49053
49054C...Reset factorial moments statistics.
49055 ELSEIF(mtabu.EQ.30) THEN
49056 nevfm=0
49057 nmufm=0
49058 DO 330 im=1,3
49059 DO 320 ib=1,10
49060 DO 310 ip=1,4
49061 fm1fm(im,ib,ip)=0d0
49062 fm2fm(im,ib,ip)=0d0
49063 310 CONTINUE
49064 320 CONTINUE
49065 330 CONTINUE
49066
49067C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
49068 ELSEIF(mtabu.EQ.31) THEN
49069 nevfm=nevfm+1
49070 nlow=n+mstu(3)
49071 nupp=nlow
49072 DO 410 i=1,n
49073 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 410
49074 IF(mstu(41).GE.2) THEN
49075 kc=pycomp(k(i,2))
49076 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
49077 & kc.EQ.18) GOTO 410
49078 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
49079 & pychge(k(i,2)).EQ.0) GOTO 410
49080 ENDIF
49081 pmr=0d0
49082 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
49083 IF(mstu(42).GE.2) pmr=p(i,5)
49084 pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
49085 yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
49086 & 1d20)),p(i,3))
49087 IF(abs(yeta).GT.paru(57)) GOTO 410
49088 phi=pyangl(p(i,1),p(i,2))
49089 iyeta=512d0*(yeta+paru(57))/(2d0*paru(57))
49090 iyeta=max(0,min(511,iyeta))
49091 iphi=512d0*(phi+paru(1))/paru(2)
49092 iphi=max(0,min(511,iphi))
49093 iyep=0
49094 DO 340 ib=0,9
49095 iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
49096 340 CONTINUE
49097
49098C...Order particles in (pseudo)rapidity and/or azimuth.
49099 IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
49100 CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
49101 RETURN
49102 ENDIF
49103 nupp=nupp+1
49104 IF(nupp.EQ.nlow+1) THEN
49105 k(nupp,1)=iyeta
49106 k(nupp,2)=iphi
49107 k(nupp,3)=iyep
49108 ELSE
49109 DO 350 i1=nupp-1,nlow+1,-1
49110 IF(iyeta.GE.k(i1,1)) GOTO 360
49111 k(i1+1,1)=k(i1,1)
49112 350 CONTINUE
49113 360 k(i1+1,1)=iyeta
49114 DO 370 i1=nupp-1,nlow+1,-1
49115 IF(iphi.GE.k(i1,2)) GOTO 380
49116 k(i1+1,2)=k(i1,2)
49117 370 CONTINUE
49118 380 k(i1+1,2)=iphi
49119 DO 390 i1=nupp-1,nlow+1,-1
49120 IF(iyep.GE.k(i1,3)) GOTO 400
49121 k(i1+1,3)=k(i1,3)
49122 390 CONTINUE
49123 400 k(i1+1,3)=iyep
49124 ENDIF
49125 410 CONTINUE
49126 k(nupp+1,1)=2**10
49127 k(nupp+1,2)=2**10
49128 k(nupp+1,3)=4**10
49129
49130C...Calculate sum of factorial moments in event.
49131 DO 480 im=1,3
49132 DO 430 ib=1,10
49133 DO 420 ip=1,4
49134 fevfm(ib,ip)=0d0
49135 420 CONTINUE
49136 430 CONTINUE
49137 DO 450 ib=1,10
49138 IF(im.LE.2) ibin=2**(10-ib)
49139 IF(im.EQ.3) ibin=4**(10-ib)
49140 iagr=k(nlow+1,im)/ibin
49141 nagr=1
49142 DO 440 i=nlow+2,nupp+1
49143 icut=k(i,im)/ibin
49144 IF(icut.EQ.iagr) THEN
49145 nagr=nagr+1
49146 ELSE
49147 IF(nagr.EQ.1) THEN
49148 ELSEIF(nagr.EQ.2) THEN
49149 fevfm(ib,1)=fevfm(ib,1)+2d0
49150 ELSEIF(nagr.EQ.3) THEN
49151 fevfm(ib,1)=fevfm(ib,1)+6d0
49152 fevfm(ib,2)=fevfm(ib,2)+6d0
49153 ELSEIF(nagr.EQ.4) THEN
49154 fevfm(ib,1)=fevfm(ib,1)+12d0
49155 fevfm(ib,2)=fevfm(ib,2)+24d0
49156 fevfm(ib,3)=fevfm(ib,3)+24d0
49157 ELSE
49158 fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1d0)
49159 fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1d0)*(nagr-2d0)
49160 fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1d0)*(nagr-2d0)*
49161 & (nagr-3d0)
49162 fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1d0)*(nagr-2d0)*
49163 & (nagr-3d0)*(nagr-4d0)
49164 ENDIF
49165 iagr=icut
49166 nagr=1
49167 ENDIF
49168 440 CONTINUE
49169 450 CONTINUE
49170
49171C...Add results to total statistics.
49172 DO 470 ib=10,1,-1
49173 DO 460 ip=1,4
49174 IF(fevfm(1,ip).LT.0.5d0) THEN
49175 fevfm(ib,ip)=0d0
49176 ELSEIF(im.LE.2) THEN
49177 fevfm(ib,ip)=2d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
49178 ELSE
49179 fevfm(ib,ip)=4d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
49180 ENDIF
49181 fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
49182 fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
49183 460 CONTINUE
49184 470 CONTINUE
49185 480 CONTINUE
49186 nmufm=nmufm+(nupp-nlow)
49187 mstu(62)=nupp-nlow
49188
49189C...Write accumulated statistics on factorial moments.
49190 ELSEIF(mtabu.EQ.32) THEN
49191 fac=1d0/max(1,nevfm)
49192 IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
49193 IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
49194 IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
49195 DO 510 im=1,3
49196 WRITE(mstu(11),5500)
49197 DO 500 ib=1,10
49198 byeta=2d0*paru(57)
49199 IF(im.NE.2) byeta=byeta/2**(ib-1)
49200 bphi=paru(2)
49201 IF(im.NE.1) bphi=bphi/2**(ib-1)
49202 IF(im.LE.2) bnave=fac*nmufm/dble(2**(ib-1))
49203 IF(im.EQ.3) bnave=fac*nmufm/dble(4**(ib-1))
49204 DO 490 ip=1,4
49205 fmoma(ip)=fac*fm1fm(im,ib,ip)
49206 fmoms(ip)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
49207 & fmoma(ip)**2)))
49208 490 CONTINUE
49209 WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
49210 & ip=1,4)
49211 500 CONTINUE
49212 510 CONTINUE
49213
49214C...Copy statistics on factorial moments into /PYJETS/.
49215 ELSEIF(mtabu.EQ.33) THEN
49216 fac=1d0/max(1,nevfm)
49217 DO 540 im=1,3
49218 DO 530 ib=1,10
49219 i=10*(im-1)+ib
49220 k(i,1)=32
49221 k(i,2)=99
49222 k(i,3)=1
49223 IF(im.NE.2) k(i,3)=2**(ib-1)
49224 k(i,4)=1
49225 IF(im.NE.1) k(i,4)=2**(ib-1)
49226 k(i,5)=0
49227 p(i,1)=2d0*paru(57)/k(i,3)
49228 v(i,1)=paru(2)/k(i,4)
49229 DO 520 ip=1,4
49230 p(i,ip+1)=fac*fm1fm(im,ib,ip)
49231 v(i,ip+1)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
49232 & p(i,ip+1)**2)))
49233 520 CONTINUE
49234 530 CONTINUE
49235 540 CONTINUE
49236 n=30
49237 DO 550 j=1,5
49238 k(n+1,j)=0
49239 p(n+1,j)=0d0
49240 v(n+1,j)=0d0
49241 550 CONTINUE
49242 k(n+1,1)=32
49243 k(n+1,2)=99
49244 k(n+1,5)=nevfm
49245 mstu(3)=1
49246
49247C...Reset statistics on Energy-Energy Correlation.
49248 ELSEIF(mtabu.EQ.40) THEN
49249 nevee=0
49250 DO 560 j=1,25
49251 fe1ec(j)=0d0
49252 fe2ec(j)=0d0
49253 fe1ec(51-j)=0d0
49254 fe2ec(51-j)=0d0
49255 fe1ea(j)=0d0
49256 fe2ea(j)=0d0
49257 560 CONTINUE
49258
49259C...Find particles to include, with proper assumed mass.
49260 ELSEIF(mtabu.EQ.41) THEN
49261 nevee=nevee+1
49262 nlow=n+mstu(3)
49263 nupp=nlow
49264 ecm=0d0
49265 DO 570 i=1,n
49266 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 570
49267 IF(mstu(41).GE.2) THEN
49268 kc=pycomp(k(i,2))
49269 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
49270 & kc.EQ.18) GOTO 570
49271 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
49272 & pychge(k(i,2)).EQ.0) GOTO 570
49273 ENDIF
49274 pmr=0d0
49275 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
49276 IF(mstu(42).GE.2) pmr=p(i,5)
49277 IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
49278 CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
49279 RETURN
49280 ENDIF
49281 nupp=nupp+1
49282 p(nupp,1)=p(i,1)
49283 p(nupp,2)=p(i,2)
49284 p(nupp,3)=p(i,3)
49285 p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
49286 p(nupp,5)=max(1d-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
49287 ecm=ecm+p(nupp,4)
49288 570 CONTINUE
49289 IF(nupp.EQ.nlow) RETURN
49290
49291C...Analyze Energy-Energy Correlation in event.
49292 fac=(2d0/ecm**2)*50d0/paru(1)
49293 DO 580 j=1,50
49294 fevee(j)=0d0
49295 580 CONTINUE
49296 DO 600 i1=nlow+2,nupp
49297 DO 590 i2=nlow+1,i1-1
49298 cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
49299 & (p(i1,5)*p(i2,5))
49300 the=acos(max(-1d0,min(1d0,cthe)))
49301 ithe=max(1,min(50,1+int(50d0*the/paru(1))))
49302 fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
49303 590 CONTINUE
49304 600 CONTINUE
49305 DO 610 j=1,25
49306 fe1ec(j)=fe1ec(j)+fevee(j)
49307 fe2ec(j)=fe2ec(j)+fevee(j)**2
49308 fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
49309 fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
49310 fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
49311 fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
49312 610 CONTINUE
49313 mstu(62)=nupp-nlow
49314
49315C...Write statistics on Energy-Energy Correlation.
49316 ELSEIF(mtabu.EQ.42) THEN
49317 fac=1d0/max(1,nevee)
49318 WRITE(mstu(11),5700) nevee
49319 DO 620 j=1,25
49320 feec1=fac*fe1ec(j)
49321 fees1=sqrt(max(0d0,fac*(fac*fe2ec(j)-feec1**2)))
49322 feec2=fac*fe1ec(51-j)
49323 fees2=sqrt(max(0d0,fac*(fac*fe2ec(51-j)-feec2**2)))
49324 feeca=fac*fe1ea(j)
49325 feesa=sqrt(max(0d0,fac*(fac*fe2ea(j)-feeca**2)))
49326 WRITE(mstu(11),5800) 3.6d0*(j-1),3.6d0*j,feec1,fees1,
49327 & feec2,fees2,feeca,feesa
49328 620 CONTINUE
49329
49330C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
49331 ELSEIF(mtabu.EQ.43) THEN
49332 fac=1d0/max(1,nevee)
49333 DO 630 i=1,25
49334 k(i,1)=32
49335 k(i,2)=99
49336 k(i,3)=0
49337 k(i,4)=0
49338 k(i,5)=0
49339 p(i,1)=fac*fe1ec(i)
49340 v(i,1)=sqrt(max(0d0,fac*(fac*fe2ec(i)-p(i,1)**2)))
49341 p(i,2)=fac*fe1ec(51-i)
49342 v(i,2)=sqrt(max(0d0,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
49343 p(i,3)=fac*fe1ea(i)
49344 v(i,3)=sqrt(max(0d0,fac*(fac*fe2ea(i)-p(i,3)**2)))
49345 p(i,4)=paru(1)*(i-1)/50d0
49346 p(i,5)=paru(1)*i/50d0
49347 v(i,4)=3.6d0*(i-1)
49348 v(i,5)=3.6d0*i
49349 630 CONTINUE
49350 n=25
49351 DO 640 j=1,5
49352 k(n+1,j)=0
49353 p(n+1,j)=0d0
49354 v(n+1,j)=0d0
49355 640 CONTINUE
49356 k(n+1,1)=32
49357 k(n+1,2)=99
49358 k(n+1,5)=nevee
49359 mstu(3)=1
49360
49361C...Reset statistics on decay channels.
49362 ELSEIF(mtabu.EQ.50) THEN
49363 nevdc=0
49364 nkfdc=0
49365 nredc=0
49366
49367C...Identify and order flavour content of final state.
49368 ELSEIF(mtabu.EQ.51) THEN
49369 nevdc=nevdc+1
49370 nds=0
49371 DO 670 i=1,n
49372 IF(k(i,1).LE.0.OR.k(i,1).GE.6) GOTO 670
49373 nds=nds+1
49374 IF(nds.GT.8) THEN
49375 nredc=nredc+1
49376 RETURN
49377 ENDIF
49378 kfm=2*iabs(k(i,2))
49379 IF(k(i,2).LT.0) kfm=kfm-1
49380 DO 650 ids=nds-1,1,-1
49381 iin=ids+1
49382 IF(kfm.LT.kfdm(ids)) GOTO 660
49383 kfdm(ids+1)=kfdm(ids)
49384 650 CONTINUE
49385 iin=1
49386 660 kfdm(iin)=kfm
49387 670 CONTINUE
49388
49389C...Find whether old or new final state.
49390 DO 690 idc=1,nkfdc
49391 IF(nds.LT.kfdc(idc,0)) THEN
49392 ikfdc=idc
49393 GOTO 700
49394 ELSEIF(nds.EQ.kfdc(idc,0)) THEN
49395 DO 680 i=1,nds
49396 IF(kfdm(i).LT.kfdc(idc,i)) THEN
49397 ikfdc=idc
49398 GOTO 700
49399 ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
49400 GOTO 690
49401 ENDIF
49402 680 CONTINUE
49403 ikfdc=-idc
49404 GOTO 700
49405 ENDIF
49406 690 CONTINUE
49407 ikfdc=nkfdc+1
49408 700 IF(ikfdc.LT.0) THEN
49409 ikfdc=-ikfdc
49410 ELSEIF(nkfdc.GE.200) THEN
49411 nredc=nredc+1
49412 RETURN
49413 ELSE
49414 DO 720 idc=nkfdc,ikfdc,-1
49415 npdc(idc+1)=npdc(idc)
49416 DO 710 i=0,8
49417 kfdc(idc+1,i)=kfdc(idc,i)
49418 710 CONTINUE
49419 720 CONTINUE
49420 nkfdc=nkfdc+1
49421 kfdc(ikfdc,0)=nds
49422 DO 730 i=1,nds
49423 kfdc(ikfdc,i)=kfdm(i)
49424 730 CONTINUE
49425 npdc(ikfdc)=0
49426 ENDIF
49427 npdc(ikfdc)=npdc(ikfdc)+1
49428
49429C...Write statistics on decay channels.
49430 ELSEIF(mtabu.EQ.52) THEN
49431 fac=1d0/max(1,nevdc)
49432 WRITE(mstu(11),5900) nevdc
49433 DO 750 idc=1,nkfdc
49434 DO 740 i=1,kfdc(idc,0)
49435 kfm=kfdc(idc,i)
49436 kf=(kfm+1)/2
49437 IF(2*kf.NE.kfm) kf=-kf
49438 CALL pyname(kf,chau)
49439 chdc(i)=chau(1:12)
49440 IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
49441 740 CONTINUE
49442 WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
49443 750 CONTINUE
49444 IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
49445
49446C...Copy statistics on decay channels into /PYJETS/.
49447 ELSEIF(mtabu.EQ.53) THEN
49448 fac=1d0/max(1,nevdc)
49449 DO 780 idc=1,nkfdc
49450 k(idc,1)=32
49451 k(idc,2)=99
49452 k(idc,3)=0
49453 k(idc,4)=0
49454 k(idc,5)=kfdc(idc,0)
49455 DO 760 j=1,5
49456 p(idc,j)=0d0
49457 v(idc,j)=0d0
49458 760 CONTINUE
49459 DO 770 i=1,kfdc(idc,0)
49460 kfm=kfdc(idc,i)
49461 kf=(kfm+1)/2
49462 IF(2*kf.NE.kfm) kf=-kf
49463 IF(i.LE.5) p(idc,i)=kf
49464 IF(i.GE.6) v(idc,i-5)=kf
49465 770 CONTINUE
49466 v(idc,5)=fac*npdc(idc)
49467 780 CONTINUE
49468 n=nkfdc
49469 DO 790 j=1,5
49470 k(n+1,j)=0
49471 p(n+1,j)=0d0
49472 v(n+1,j)=0d0
49473 790 CONTINUE
49474 k(n+1,1)=32
49475 k(n+1,2)=99
49476 k(n+1,5)=nevdc
49477 v(n+1,5)=fac*nredc
49478 mstu(3)=1
49479 ENDIF
49480
49481C...Format statements for output on unit MSTU(11) (default 6).
49482 5000 FORMAT(///20x,'Event statistics - initial state'/
49483 &20x,'based on an analysis of ',i6,' events'//
49484 &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
49485 &'according to fragmenting system multiplicity'/
49486 &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
49487 &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
49488 5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
49489 5200 FORMAT(///20x,'Event statistics - final state'/
49490 &20x,'based on an analysis of ',i7,' events'//
49491 &5x,'Mean primary multiplicity =',f10.4/
49492 &5x,'Mean final multiplicity =',f10.4/
49493 &5x,'Mean charged multiplicity =',f10.4//
49494 &5x,'Number of particles produced per event (directly and via ',
49495 &'decays/branchings)'/
49496 &8x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
49497 &8x,'Total'/35x,'prim seco prim seco'/)
49498 5300 FORMAT(1x,i9,4x,a16,i2,5(1x,f11.6))
49499 5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
49500 &20x,'based on an analysis of ',i6,' events'//
49501 &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
49502 &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
49503 5500 FORMAT(10x)
49504 5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
49505 5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
49506 &20x,'based on an analysis of ',i6,' events'//
49507 &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
49508 &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
49509 5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
49510 5900 FORMAT(///20x,'Decay channel analysis - final state'/
49511 &20x,'based on an analysis of ',i6,' events'//
49512 &2x,'Probability',10x,'Complete final state'/)
49513 6000 FORMAT(2x,f9.5,5x,8(a12,1x))
49514 6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
49515 &'or table overflow)')
49516
49517 RETURN
49518 END
49519
49520C*********************************************************************
49521
49522C...PYEEVT
49523C...Handles the generation of an e+e- annihilation jet event.
49524
49525 SUBROUTINE pyeevt(KFL,ECM)
49526
49527C...Double precision and integer declarations.
49528 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49529 IMPLICIT INTEGER(I-N)
49530 INTEGER PYK,PYCHGE,PYCOMP
49531C...Commonblocks.
49532 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
49533 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49534 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49535 SAVE /pyjets/,/pydat1/,/pydat2/
49536
49537C...Check input parameters.
49538 IF(mstu(12).GE.1) CALL pylist(0)
49539 IF(kfl.LT.0.OR.kfl.GT.8) THEN
49540 CALL pyerrm(16,'(PYEEVT:) called with unknown flavour code')
49541 IF(mstu(21).GE.1) RETURN
49542 ENDIF
49543 IF(kfl.LE.5) ecmmin=parj(127)+2.02d0*parf(100+max(1,kfl))
49544 IF(kfl.GE.6) ecmmin=parj(127)+2.02d0*pmas(kfl,1)
49545 IF(ecm.LT.ecmmin) THEN
49546 CALL pyerrm(16,'(PYEEVT:) called with too small CM energy')
49547 IF(mstu(21).GE.1) RETURN
49548 ENDIF
49549
49550C...Check consistency of MSTJ options set.
49551 IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
49552 CALL pyerrm(6,
49553 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
49554 mstj(110)=1
49555 ENDIF
49556 IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
49557 CALL pyerrm(6,
49558 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
49559 mstj(111)=0
49560 ENDIF
49561
49562C...Initialize alpha_strong and total cross-section.
49563 mstu(111)=mstj(108)
49564 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
49565 &mstu(111)=1
49566 paru(112)=parj(121)
49567 IF(mstu(111).EQ.2) paru(112)=parj(122)
49568 IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
49569 &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL pyxtee(kfl,ecm,
49570 &xtot)
49571 IF(mstj(116).GE.3) mstj(116)=1
49572 parj(171)=0d0
49573
49574C...Add initial e+e- to event record (documentation only).
49575 ntry=0
49576 100 ntry=ntry+1
49577 IF(ntry.GT.100) THEN
49578 CALL pyerrm(14,'(PYEEVT:) caught in an infinite loop')
49579 RETURN
49580 ENDIF
49581 mstu(24)=0
49582 nc=0
49583 IF(mstj(115).GE.2) THEN
49584 nc=nc+2
49585 CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
49586 k(nc-1,1)=21
49587 CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
49588 k(nc,1)=21
49589 ENDIF
49590
49591C...Radiative photon (in initial state).
49592 mk=0
49593 ecmc=ecm
49594 IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL pyradk(ecm,mk,pak,
49595 &thek,phik,alpk)
49596 IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2d0*pak))
49597 IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
49598 nc=nc+1
49599 CALL py1ent(nc,22,pak,thek,phik)
49600 k(nc,3)=min(mstj(115)/2,1)
49601 ENDIF
49602
49603C...Virtual exchange boson (gamma or Z0).
49604 IF(mstj(115).GE.3) THEN
49605 nc=nc+1
49606 kf=22
49607 IF(mstj(102).EQ.2) kf=23
49608 mstu10=mstu(10)
49609 mstu(10)=1
49610 p(nc,5)=ecmc
49611 CALL py1ent(nc,kf,ecmc,0d0,0d0)
49612 k(nc,1)=21
49613 k(nc,3)=1
49614 mstu(10)=mstu10
49615 ENDIF
49616
49617C...Choice of flavour and jet configuration.
49618 CALL pyxkfl(kfl,ecm,ecmc,kflc)
49619 IF(kflc.EQ.0) GOTO 100
49620 CALL pyxjet(ecmc,njet,cut)
49621 kfln=21
49622 IF(njet.EQ.4) CALL pyx4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
49623 &x12,x14)
49624 IF(njet.EQ.3) CALL pyx3jt(njet,cut,kflc,ecmc,x1,x3)
49625 IF(njet.EQ.2) mstj(120)=1
49626
49627C...Fill jet configuration and origin.
49628 IF(njet.EQ.2.AND.mstj(101).NE.5) CALL py2ent(nc+1,kflc,-kflc,ecmc)
49629 IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL py2ent(-(nc+1),kflc,-kflc,
49630 &ecmc)
49631 IF(njet.EQ.3) CALL py3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
49632 IF(njet.EQ.4.AND.kfln.EQ.21) CALL py4ent(nc+1,kflc,kfln,kfln,
49633 &-kflc,ecmc,x1,x2,x4,x12,x14)
49634 IF(njet.EQ.4.AND.kfln.NE.21) CALL py4ent(nc+1,kflc,-kfln,kfln,
49635 &-kflc,ecmc,x1,x2,x4,x12,x14)
49636 IF(mstu(24).NE.0) GOTO 100
49637 DO 110 ip=nc+1,n
49638 k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
49639 110 CONTINUE
49640
49641C...Angular orientation according to matrix element.
49642 IF(mstj(106).EQ.1) THEN
49643 CALL pyxdif(nc,njet,kflc,ecmc,chi,the,phi)
49644 CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
49645 CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
49646 ENDIF
49647
49648C...Rotation and boost from radiative photon.
49649 IF(mk.EQ.1) THEN
49650 dbek=-pak/(ecm-pak)
49651 nmin=nc+1-mstj(115)/3
49652 CALL pyrobo(nmin,n,0d0,-phik,0d0,0d0,0d0)
49653 CALL pyrobo(nmin,n,alpk,0d0,dbek*sin(thek),0d0,dbek*cos(thek))
49654 CALL pyrobo(nmin,n,0d0,phik,0d0,0d0,0d0)
49655 ENDIF
49656
49657C...Generate parton shower. Rearrange along strings and check.
49658 IF(mstj(101).EQ.5) THEN
49659 CALL pyshow(n-1,n,ecmc)
49660 mstj14=mstj(14)
49661 IF(mstj(105).EQ.-1) mstj(14)=-1
49662 IF(mstj(105).GE.0) mstu(28)=0
49663 CALL pyprep(0)
49664 mstj(14)=mstj14
49665 IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
49666 ENDIF
49667
49668C...Fragmentation/decay generation. Information for PYTABU.
49669 IF(mstj(105).EQ.1) CALL pyexec
49670 mstu(161)=kflc
49671 mstu(162)=-kflc
49672
49673 RETURN
49674 END
49675
49676C*********************************************************************
49677
49678C...PYXTEE
49679C...Calculates total cross-section, including initial state
49680C...radiation effects.
49681
49682 SUBROUTINE pyxtee(KFL,ECM,XTOT)
49683
49684C...Double precision and integer declarations.
49685 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49686 IMPLICIT INTEGER(I-N)
49687 INTEGER PYK,PYCHGE,PYCOMP
49688C...Commonblocks.
49689 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49690 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49691 SAVE /pydat1/,/pydat2/
49692
49693C...Status, (optimized) Q^2 scale, alpha_strong.
49694 parj(151)=ecm
49695 mstj(119)=10*mstj(102)+kfl
49696 IF(mstj(111).EQ.0) THEN
49697 q2r=ecm**2
49698 ELSEIF(mstu(111).EQ.0) THEN
49699 parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
49700 & ((33d0-2d0*mstu(112))*paru(111)))))
49701 q2r=parj(168)*ecm**2
49702 ELSE
49703 parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
49704 & (2d0*paru(112)/ecm)**2))
49705 q2r=parj(168)*ecm**2
49706 ENDIF
49707 alspi=pyalps(q2r)/paru(1)
49708
49709C...QCD corrections factor in R.
49710 IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
49711 rqcd=1d0
49712 ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
49713 rqcd=1d0+alspi
49714 ELSEIF(mstj(109).EQ.0) THEN
49715 rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
49716 IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+(33d0-2d0*mstu(112))/12d0*
49717 & log(parj(168))*alspi**2)
49718 ELSEIF(iabs(mstj(101)).EQ.1) THEN
49719 rqcd=1d0+(3d0/4d0)*alspi
49720 ELSE
49721 rqcd=1d0+(3d0/4d0)*alspi-(3d0/32d0+0.519d0*mstu(118))*alspi**2
49722 ENDIF
49723
49724C...Calculate Z0 width if default value not acceptable.
49725 IF(mstj(102).GE.3) THEN
49726 rva=3d0*(3d0+(4d0*paru(102)-1d0)**2)+6d0*rqcd*(2d0+
49727 & (1d0-8d0*paru(102)/3d0)**2+(4d0*paru(102)/3d0-1d0)**2)
49728 DO 100 kflc=5,6
49729 vq=1d0
49730 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-
49731 & (2d0*pymass(kflc)/ ecm)**2))
49732 IF(kflc.EQ.5) vf=4d0*paru(102)/3d0-1d0
49733 IF(kflc.EQ.6) vf=1d0-8d0*paru(102)/3d0
49734 rva=rva+3d0*rqcd*(0.5d0*vq*(3d0-vq**2)*vf**2+vq**3)
49735 100 CONTINUE
49736 parj(124)=paru(101)*parj(123)*rva/(48d0*paru(102)*
49737 & (1d0-paru(102)))
49738 ENDIF
49739
49740C...Calculate propagator and related constants for QFD case.
49741 poll=1d0-parj(131)*parj(132)
49742 IF(mstj(102).GE.2) THEN
49743 sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
49744 sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
49745 sfi=sfw*(1d0-(parj(123)/ecm)**2)
49746 ve=4d0*paru(102)-1d0
49747 sf1i=sff*(ve*poll+parj(132)-parj(131))
49748 sf1w=sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
49749 hf1i=sfi*sf1i
49750 hf1w=sfw*sf1w
49751 ENDIF
49752
49753C...Loop over different flavours: charge, velocity.
49754 rtot=0d0
49755 rqq=0d0
49756 rqv=0d0
49757 rva=0d0
49758 DO 110 kflc=1,max(mstj(104),kfl)
49759 IF(kfl.GT.0.AND.kflc.NE.kfl) GOTO 110
49760 mstj(93)=1
49761 pmq=pymass(kflc)
49762 IF(ecm.LT.2d0*pmq+parj(127)) GOTO 110
49763 qf=kchg(kflc,1)/3d0
49764 vq=1d0
49765 IF(mod(mstj(103),2).EQ.1) vq=sqrt(1d0-(2d0*pmq/ecm)**2)
49766
49767C...Calculate R and sum of charges for QED or QFD case.
49768 rqq=rqq+3d0*qf**2*poll
49769 IF(mstj(102).LE.1) THEN
49770 rtot=rtot+3d0*0.5d0*vq*(3d0-vq**2)*qf**2*poll
49771 ELSE
49772 vf=sign(1d0,qf)-4d0*qf*paru(102)
49773 rqv=rqv-6d0*qf*vf*sf1i
49774 rva=rva+3d0*(vf**2+1d0)*sf1w
49775 rtot=rtot+3d0*(0.5d0*vq*(3d0-vq**2)*(qf**2*poll-
49776 & 2d0*qf*vf*hf1i+vf**2*hf1w)+vq**3*hf1w)
49777 ENDIF
49778 110 CONTINUE
49779 rsum=rqq
49780 IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
49781
49782C...Calculate cross-section, including QCD corrections.
49783 parj(141)=rqq
49784 parj(142)=rtot
49785 parj(143)=rtot*rqcd
49786 parj(144)=parj(143)
49787 parj(145)=parj(141)*86.8d0/ecm**2
49788 parj(146)=parj(142)*86.8d0/ecm**2
49789 parj(147)=parj(143)*86.8d0/ecm**2
49790 parj(148)=parj(147)
49791 parj(157)=rsum*rqcd
49792 parj(158)=0d0
49793 parj(159)=0d0
49794 xtot=parj(147)
49795 IF(mstj(107).LE.0) RETURN
49796
49797C...Virtual cross-section.
49798 xkl=parj(135)
49799 xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
49800 ale=2d0*log(ecm/pymass(11))-1d0
49801 sigv=ale/3d0+2d0*log(ecm**2/(pymass(13)*pymass(15)))/3d0-4d0/3d0+
49802 &1.526d0*log(ecm**2/0.932d0)
49803
49804C...Soft and hard radiative cross-section in QED case.
49805 IF(mstj(102).LE.1) THEN
49806 sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+2d0*sigv
49807 sigs=ale*(2d0*log(xkl)-log(1d0-xkl)-xkl)
49808 sigh=ale*(2d0*log(xku/xkl)-log((1d0-xku)/(1d0-xkl))-(xku-xkl))
49809
49810C...Soft and hard radiative cross-section in QFD case.
49811 ELSE
49812 szm=1d0-(parj(123)/ecm)**2
49813 szw=parj(123)*parj(124)/ecm**2
49814 parj(161)=-rqq/rsum
49815 parj(162)=-(rqq+rqv+rva)/rsum
49816 parj(163)=(rqv*(1d0-0.5d0*szm-sfi)+rva*(1.5d0-szm-sfw))/rsum
49817 parj(164)=(rqv*szw**2*(1d0-2d0*sfw)+rva*(2d0*sfi+szw**2-
49818 & 4d0+3d0*szm-szm**2))/(szw*rsum)
49819 sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+((2d0*rqq+sfi*rqv)/
49820 & rsum)*sigv+(szw*sfw*rqv/rsum)*paru(1)*20d0/9d0
49821 sigs=ale*(2d0*log(xkl)+parj(161)*log(1d0-xkl)+parj(162)*xkl+
49822 & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
49823 & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
49824 sigh=ale*(2d0*log(xku/xkl)+parj(161)*log((1d0-xku)/
49825 & (1d0-xkl))+parj(162)*(xku-xkl)+parj(163)*
49826 & log(((xku-szm)**2+szw**2)/((xkl-szm)**2+szw**2))+
49827 & parj(164)*(atan((xku-szm)/szw)-atan((xkl-szm)/szw)))
49828 ENDIF
49829
49830C...Total cross-section and fraction of hard photon events.
49831 parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
49832 parj(157)=rsum*(1d0+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
49833 parj(144)=parj(157)
49834 parj(148)=parj(144)*86.8d0/ecm**2
49835 xtot=parj(148)
49836
49837 RETURN
49838 END
49839
49840C*********************************************************************
49841
49842C...PYRADK
49843C...Generates initial state photon radiation.
49844
49845 SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)
49846
49847C...Double precision and integer declarations.
49848 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49849 IMPLICIT INTEGER(I-N)
49850 INTEGER PYK,PYCHGE,PYCOMP
49851C...Commonblocks.
49852 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49853 SAVE /pydat1/
49854
49855C...Function: cumulative hard photon spectrum in QFD case.
49856 fxk(xx)=2d0*log(xx)+parj(161)*log(1d0-xx)+parj(162)*xx+
49857 &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
49858
49859C...Determine whether radiative photon or not.
49860 mk=0
49861 pak=0d0
49862 IF(parj(160).LT.pyr(0)) RETURN
49863 mk=1
49864
49865C...Photon energy range. Find photon momentum in QED case.
49866 xkl=parj(135)
49867 xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
49868 IF(mstj(102).LE.1) THEN
49869 100 xk=1d0/(1d0+(1d0/xkl-1d0)*((1d0/xku-1d0)/(1d0/xkl-1d0))**pyr(0))
49870 IF(1d0+(1d0-xk)**2.LT.2d0*pyr(0)) GOTO 100
49871
49872C...Ditto in QFD case, by numerical inversion of integrated spectrum.
49873 ELSE
49874 szm=1d0-(parj(123)/ecm)**2
49875 szw=parj(123)*parj(124)/ecm**2
49876 fxkl=fxk(xkl)
49877 fxku=fxk(xku)
49878 fxkd=1d-4*(fxku-fxkl)
49879 fxkr=fxkl+pyr(0)*(fxku-fxkl)
49880 nxk=0
49881 110 nxk=nxk+1
49882 xk=0.5d0*(xkl+xku)
49883 fxkv=fxk(xk)
49884 IF(fxkv.GT.fxkr) THEN
49885 xku=xk
49886 fxku=fxkv
49887 ELSE
49888 xkl=xk
49889 fxkl=fxkv
49890 ENDIF
49891 IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) GOTO 110
49892 xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
49893 ENDIF
49894 pak=0.5d0*ecm*xk
49895
49896C...Photon polar and azimuthal angle.
49897 pme=2d0*(pymass(11)/ecm)**2
49898 120 cthm=pme*(2d0/pme)**pyr(0)
49899 IF(1d0-(xk**2*cthm*(1d0-0.5d0*cthm)+2d0*(1d0-xk)*pme/max(pme,
49900 &cthm*(1d0-0.5d0*cthm)))/(1d0+(1d0-xk)**2).LT.pyr(0)) GOTO 120
49901 cthe=1d0-cthm
49902 IF(pyr(0).GT.0.5d0) cthe=-cthe
49903 sthe=sqrt(max(0d0,(cthm-pme)*(2d0-cthm)))
49904 thek=pyangl(cthe,sthe)
49905 phik=paru(2)*pyr(0)
49906
49907C...Rotation angle for hadronic system.
49908 sgn=1d0
49909 IF(0.5d0*(2d0-xk*(1d0-cthe))**2/((2d0-xk)**2+(xk*cthe)**2).GT.
49910 &pyr(0)) sgn=-1d0
49911 alpk=asin(sgn*sthe*(xk-sgn*(2d0*sqrt(1d0-xk)-2d0+xk)*cthe)/
49912 &(2d0-xk*(1d0-sgn*cthe)))
49913
49914 RETURN
49915 END
49916
49917C*********************************************************************
49918
49919C...PYXKFL
49920C...Selects flavour for produced qqbar pair.
49921
49922 SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)
49923
49924C...Double precision and integer declarations.
49925 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49926 IMPLICIT INTEGER(I-N)
49927 INTEGER PYK,PYCHGE,PYCOMP
49928C...Commonblocks.
49929 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49930 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49931 SAVE /pydat1/,/pydat2/
49932
49933C...Calculate maximum weight in QED or QFD case.
49934 IF(mstj(102).LE.1) THEN
49935 rfmax=4d0/9d0
49936 ELSE
49937 poll=1d0-parj(131)*parj(132)
49938 sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
49939 sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
49940 sfi=sfw*(1d0-(parj(123)/ecmc)**2)
49941 ve=4d0*paru(102)-1d0
49942 hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
49943 hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
49944 rfmax=max(4d0/9d0*poll-4d0/3d0*(1d0-8d0*paru(102)/3d0)*hf1i+
49945 & ((1d0-8d0*paru(102)/3d0)**2+1d0)*hf1w,1d0/9d0*poll+2d0/3d0*
49946 & (-1d0+4d0*paru(102)/3d0)*hf1i+((-1d0+4d0*paru(102)/3d0)**2+
49947 & 1d0)*hf1w)
49948 ENDIF
49949
49950C...Choose flavour. Gives charge and velocity.
49951 ntry=0
49952 100 ntry=ntry+1
49953 IF(ntry.GT.100) THEN
49954 CALL pyerrm(14,'(PYXKFL:) caught in an infinite loop')
49955 kflc=0
49956 RETURN
49957 ENDIF
49958 kflc=kfl
49959 IF(kfl.LE.0) kflc=1+int(mstj(104)*pyr(0))
49960 mstj(93)=1
49961 pmq=pymass(kflc)
49962 IF(ecm.LT.2d0*pmq+parj(127)) GOTO 100
49963 qf=kchg(kflc,1)/3d0
49964 vq=1d0
49965 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-(2d0*pmq/ecmc)**2))
49966
49967C...Calculate weight in QED or QFD case.
49968 IF(mstj(102).LE.1) THEN
49969 rf=qf**2
49970 rfv=0.5d0*vq*(3d0-vq**2)*qf**2
49971 ELSE
49972 vf=sign(1d0,qf)-4d0*qf*paru(102)
49973 rf=qf**2*poll-2d0*qf*vf*hf1i+(vf**2+1d0)*hf1w
49974 rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+vf**2*hf1w)+
49975 & vq**3*hf1w
49976 IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
49977 ENDIF
49978
49979C...Weighting or new event (radiative photon). Cross-section update.
49980 IF(kfl.LE.0.AND.rf.LT.pyr(0)*rfmax) GOTO 100
49981 parj(158)=parj(158)+1d0
49982 IF(ecmc.LT.2d0*pmq+parj(127).OR.rfv.LT.pyr(0)*rf) kflc=0
49983 IF(mstj(107).LE.0.AND.kflc.EQ.0) GOTO 100
49984 IF(kflc.NE.0) parj(159)=parj(159)+1d0
49985 parj(144)=parj(157)*parj(159)/parj(158)
49986 parj(148)=parj(144)*86.8d0/ecm**2
49987
49988 RETURN
49989 END
49990
49991C*********************************************************************
49992
49993C...PYXJET
49994C...Selects number of jets in matrix element approach.
49995
49996 SUBROUTINE pyxjet(ECM,NJET,CUT)
49997
49998C...Double precision and integer declarations.
49999 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50000 IMPLICIT INTEGER(I-N)
50001 INTEGER PYK,PYCHGE,PYCOMP
50002C...Commonblocks.
50003 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50004 SAVE /pydat1/
50005C...Local array and data.
50006 dimension zhut(5)
50007 DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/
50008
50009C...Trivial result for two-jets only, including parton shower.
50010 IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
50011 cut=0d0
50012
50013C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
50014 ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
50015 cf=4d0/3d0
50016 IF(mstj(109).EQ.2) cf=1d0
50017 IF(mstj(111).EQ.0) THEN
50018 q2=ecm**2
50019 q2r=ecm**2
50020 ELSEIF(mstu(111).EQ.0) THEN
50021 parj(169)=min(1d0,parj(129))
50022 q2=parj(169)*ecm**2
50023 parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
50024 & ((33d0-2d0*mstu(112))*paru(111)))))
50025 q2r=parj(168)*ecm**2
50026 ELSE
50027 parj(169)=min(1d0,max(parj(129),(2d0*paru(112)/ecm)**2))
50028 q2=parj(169)*ecm**2
50029 parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
50030 & (2d0*paru(112)/ecm)**2))
50031 q2r=parj(168)*ecm**2
50032 ENDIF
50033
50034C...alpha_strong for R and R itself.
50035 alspi=(3d0/4d0)*cf*pyalps(q2r)/paru(1)
50036 IF(iabs(mstj(101)).EQ.1) THEN
50037 rqcd=1d0+alspi
50038 ELSEIF(mstj(109).EQ.0) THEN
50039 rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
50040 IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+
50041 & (33d0-2d0*mstu(112))/12d0*log(parj(168))*alspi**2)
50042 ELSE
50043 rqcd=1d0+alspi-(3d0/32d0+0.519d0*mstu(118))*(4d0*alspi/3d0)**2
50044 ENDIF
50045
50046C...alpha_strong for jet rate. Initial value for y cut.
50047 alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
50048 cut=max(0.001d0,parj(125),(parj(126)/ecm)**2)
50049 IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
50050 & cut=max(cut,exp(-sqrt(0.75d0/alspi))/2d0)
50051 IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
50052
50053C...Parametrization of first order three-jet cross-section.
50054 100 IF(mstj(101).EQ.0.OR.cut.GE.0.25d0) THEN
50055 parj(152)=0d0
50056 ELSE
50057 parj(152)=(2d0*alspi/3d0)*((3d0-6d0*cut+2d0*log(cut))*
50058 & log(cut/(1d0-2d0*cut))+(2.5d0+1.5d0*cut-6.571d0)*
50059 & (1d0-3d0*cut)+5.833d0*(1d0-3d0*cut)**2-3.894d0*
50060 & (1d0-3d0*cut)**3+1.342d0*(1d0-3d0*cut)**4)/rqcd
50061 IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
50062 & parj(152)=0d0
50063 ENDIF
50064
50065C...Parametrization of second order three-jet cross-section.
50066 IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
50067 & cut.GE.0.25d0) THEN
50068 parj(153)=0d0
50069 ELSEIF(mstj(110).LE.1) THEN
50070 ct=log(1d0/cut-2d0)
50071 parj(153)=alspi**2*ct**2*(2.419d0+0.5989d0*ct+0.6782d0*ct**2-
50072 & 0.2661d0*ct**3+0.01159d0*ct**4)/rqcd
50073
50074C...Interpolation in second/first order ratio for Zhu parametrization.
50075 ELSEIF(mstj(110).EQ.2) THEN
50076 iza=0
50077 DO 110 iy=1,5
50078 IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
50079 110 CONTINUE
50080 IF(iza.NE.0) THEN
50081 zhurat=zhut(iza)
50082 ELSE
50083 iz=100d0*cut
50084 zhurat=zhut(iz)+(100d0*cut-iz)*(zhut(iz+1)-zhut(iz))
50085 ENDIF
50086 parj(153)=alspi*parj(152)*zhurat
50087 ENDIF
50088
50089C...Shift in second order three-jet cross-section with optimized Q^2.
50090 IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3
50091 & .AND.cut.LT.0.25d0) parj(153)=parj(153)+
50092 & (33d0-2d0*mstu(112))/12d0*log(parj(169))*alspi*parj(152)
50093
50094C...Parametrization of second order four-jet cross-section.
50095 IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125d0) THEN
50096 parj(154)=0d0
50097 ELSE
50098 ct=log(1d0/cut-5d0)
50099 IF(cut.LE.0.018d0) THEN
50100 xqqgg=6.349d0-4.330d0*ct+0.8304d0*ct**2
50101 IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(3.035d0-2.091d0*ct+
50102 & 0.4059d0*ct**2)
50103 xqqqq=1.25d0*(-0.1080d0+0.01486d0*ct+0.009364d0*ct**2)
50104 IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
50105 ELSE
50106 xqqgg=-0.09773d0+0.2959d0*ct-0.2764d0*ct**2+0.08832d0*ct**3
50107 IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(-0.04079d0+
50108 & 0.1340d0*ct-0.1326d0*ct**2+0.04365d0*ct**3)
50109 xqqqq=1.25d0*(0.003661d0-0.004888d0*ct-0.001081d0*ct**2+
50110 & 0.002093d0*ct**3)
50111 IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
50112 ENDIF
50113 parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
50114 parj(155)=xqqqq/(xqqgg+xqqqq)
50115 ENDIF
50116
50117C...If negative three-jet rate, change y' optimization parameter.
50118 IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0d0.AND.
50119 & parj(169).LT.0.99d0) THEN
50120 parj(169)=min(1d0,1.2d0*parj(169))
50121 q2=parj(169)*ecm**2
50122 alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
50123 GOTO 100
50124 ENDIF
50125
50126C...If too high cross-section, use harder cuts, or fail.
50127 IF(parj(152)+parj(153)+parj(154).GE.1) THEN
50128 IF(mstj(110).EQ.2.AND.cut.GT.0.0499d0.AND.mstj(111).EQ.1.AND.
50129 & parj(169).LT.0.99d0) THEN
50130 parj(169)=min(1d0,1.2d0*parj(169))
50131 q2=parj(169)*ecm**2
50132 alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
50133 GOTO 100
50134 ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499d0) THEN
50135 CALL pyerrm(26,
50136 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
50137 ENDIF
50138 cut=0.26d0*(4d0*cut)**(parj(152)+parj(153)+
50139 & parj(154))**(-1d0/3d0)
50140 IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
50141 GOTO 100
50142 ENDIF
50143
50144C...Scalar gluon (first order only).
50145 ELSE
50146 alspi=pyalps(ecm**2)/paru(1)
50147 cut=max(0.001d0,parj(125),(parj(126)/ecm)**2,exp(-3d0/alspi))
50148 parj(152)=0d0
50149 IF(cut.LT.0.25d0) parj(152)=(alspi/3d0)*((1d0-2d0*cut)*
50150 & log((1d0-2d0*cut)/cut)+0.5d0*(9d0*cut**2-1d0))
50151 parj(153)=0d0
50152 parj(154)=0d0
50153 ENDIF
50154
50155C...Select number of jets.
50156 parj(150)=cut
50157 IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
50158 njet=2
50159 ELSEIF(mstj(101).LE.0) THEN
50160 njet=min(4,2-mstj(101))
50161 ELSE
50162 rnj=pyr(0)
50163 njet=2
50164 IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
50165 IF(parj(154).GT.rnj) njet=4
50166 ENDIF
50167
50168 RETURN
50169 END
50170
50171C*********************************************************************
50172
50173C...PYX3JT
50174C...Selects the kinematical variables of three-jet events.
50175
50176 SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)
50177
50178C...Double precision and integer declarations.
50179 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50180 IMPLICIT INTEGER(I-N)
50181 INTEGER PYK,PYCHGE,PYCOMP
50182C...Commonblocks.
50183 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50184 SAVE /pydat1/
50185C...Local array.
50186 dimension zhup(5,12)
50187
50188C...Coefficients of Zhu second order parametrization.
50189 DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
50190 &18.29d0, 89.56d0, 4.541d0, -52.09d0, -109.8d0, 24.90d0,
50191 &11.63d0, 3.683d0, 17.50d0,0.002440d0, -1.362d0,-0.3537d0,
50192 &11.42d0, 6.299d0, -22.55d0, -8.915d0, 59.25d0, -5.855d0,
50193 &-32.85d0, -1.054d0, -16.90d0,0.006489d0,-0.8156d0,0.01095d0,
50194 &7.847d0, -3.964d0, -35.83d0, 1.178d0, 29.39d0, 0.2806d0,
50195 &47.82d0, -12.36d0, -56.72d0, 0.04054d0,-0.4365d0, 0.6062d0,
50196 &5.441d0, -56.89d0, -50.27d0, 15.13d0, 114.3d0, -18.19d0,
50197 &97.05d0, -1.890d0, -139.9d0, 0.08153d0,-0.4984d0, 0.9439d0,
50198 &-17.65d0, 51.44d0, -58.32d0, 70.95d0, -255.7d0, -78.99d0,
50199 &476.9d0, 29.65d0, -239.3d0, 0.4745d0, -1.174d0, 6.081d0/
50200
50201C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
50202 dilog(x)=x+x**2/4d0+x**3/9d0+x**4/16d0+x**5/25d0+x**6/36d0+
50203 &x**7/49d0
50204
50205C...Event type. Mass effect factors and other common constants.
50206 mstj(120)=2
50207 mstj(121)=0
50208 pmq=pymass(kfl)
50209 qme=(2d0*pmq/ecm)**2
50210 IF(mstj(109).NE.1) THEN
50211 cutl=log(cut)
50212 cutd=log(1d0/cut-2d0)
50213 IF(mstj(109).EQ.0) THEN
50214 cf=4d0/3d0
50215 cn=3d0
50216 tr=2d0
50217 wtmx=min(20d0,37d0-6d0*cutd)
50218 IF(mstj(110).EQ.2) wtmx=2d0*(7.5d0+80d0*cut)
50219 ELSE
50220 cf=1d0
50221 cn=0d0
50222 tr=12d0
50223 wtmx=0d0
50224 ENDIF
50225
50226C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
50227 als2pi=paru(118)/paru(2)
50228 wtopt=0d0
50229 IF(mstj(111).EQ.1) wtopt=(33d0-2d0*mstu(112))/6d0*
50230 & log(parj(169))*als2pi
50231 wtmax=max(0d0,1d0+wtopt+als2pi*wtmx)
50232
50233C...Choose three-jet events in allowed region.
50234 100 njet=3
50235 110 y13l=cutl+cutd*pyr(0)
50236 y23l=cutl+cutd*pyr(0)
50237 y13=exp(y13l)
50238 y23=exp(y23l)
50239 y12=1d0-y13-y23
50240 IF(y12.LE.cut) GOTO 110
50241 IF(y13**2+y23**2+2d0*y12.LE.2d0*pyr(0)) GOTO 110
50242
50243C...Second order corrections.
50244 IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
50245 y12l=log(y12)
50246 y13m=log(1d0-y13)
50247 y23m=log(1d0-y23)
50248 y12m=log(1d0-y12)
50249 IF(y13.LE.0.5d0) y13i=dilog(y13)
50250 IF(y13.GE.0.5d0) y13i=1.644934d0-y13l*y13m-dilog(1d0-y13)
50251 IF(y23.LE.0.5d0) y23i=dilog(y23)
50252 IF(y23.GE.0.5d0) y23i=1.644934d0-y23l*y23m-dilog(1d0-y23)
50253 IF(y12.LE.0.5d0) y12i=dilog(y12)
50254 IF(y12.GE.0.5d0) y12i=1.644934d0-y12l*y12m-dilog(1d0-y12)
50255 wt1=(y13**2+y23**2+2d0*y12)/(y13*y23)
50256 wt2=cf*(-2d0*(cutl-y12l)**2-3d0*cutl-1d0+3.289868d0+
50257 & 2d0*(2d0*cutl-y12l)*cut/y12)+
50258 & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-
50259 & 11d0*cutl/6d0+67d0/18d0+1.644934d0-(2d0*cutl-y12l)*cut/y12+
50260 & (2d0*cutl-y13l)*cut/y13+(2d0*cutl-y23l)*cut/y23)+
50261 & tr*(2d0*cutl/3d0-10d0/9d0)+
50262 & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
50263 & y13l*(4d0*y12**2+2d0*y12*y13+4d0*y12*y23+y13*y23)/
50264 & (y12+y23)**2+y23l*(4d0*y12**2+2d0*y12*y23+4d0*y12*y13+
50265 & y13*y23)/(y12+y13)**2)/wt1+
50266 & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+(cn-2d0*cf)*
50267 & ((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
50268 & y23m+1.644934d0-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
50269 & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934d0-y12i-y13i)/
50270 & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
50271 & 2d0*y12l*y12**2/(y13+y23)**2-4d0*y12l*y12/(y13+y23))/wt1-
50272 & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934d0-y13i-y23i)
50273 IF(1d0+wtopt+als2pi*wt2.LE.0d0) mstj(121)=1
50274 IF(1d0+wtopt+als2pi*wt2.LE.wtmax*pyr(0)) GOTO 110
50275 parj(156)=(wtopt+als2pi*wt2)/(1d0+wtopt+als2pi*wt2)
50276
50277 ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
50278C...Second order corrections; Zhu parametrization of ERT.
50279 zx=(y23-y13)**2
50280 zy=1d0-y12
50281 iza=0
50282 DO 120 iy=1,5
50283 IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
50284 120 CONTINUE
50285 IF(iza.NE.0) THEN
50286 iz=iza
50287 wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
50288 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
50289 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
50290 & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
50291 ELSE
50292 iz=100d0*cut
50293 wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
50294 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
50295 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
50296 & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
50297 iz=iz+1
50298 wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
50299 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
50300 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
50301 & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
50302 wt2=wtl+(wtu-wtl)*(100d0*cut+1d0-iz)
50303 ENDIF
50304 IF(1d0+wtopt+2d0*als2pi*wt2.LE.0d0) mstj(121)=1
50305 IF(1d0+wtopt+2d0*als2pi*wt2.LE.wtmax*pyr(0)) GOTO 110
50306 parj(156)=(wtopt+2d0*als2pi*wt2)/(1d0+wtopt+2d0*als2pi*wt2)
50307 ENDIF
50308
50309C...Impose mass cuts (gives two jets). For fixed jet number new try.
50310 x1=1d0-y23
50311 x2=1d0-y13
50312 x3=1d0-y12
50313 IF(4d0*y23*y13*y12/x3**2.LE.qme) njet=2
50314 IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
50315 & 0.5d0*qme**2+(0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/(1d0-x1)+
50316 & (1d0-x1)/(1d0-x2)).GT.(x1**2+x2**2)*pyr(0)) njet=2
50317 IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 100
50318
50319C...Scalar gluon model (first order only, no mass effects).
50320 ELSE
50321 130 njet=3
50322 140 x3=sqrt(4d0*cut**2+pyr(0)*((1d0-cut)**2-4d0*cut**2))
50323 IF(log((x3-cut)/cut).LE.pyr(0)*log((1d0-2d0*cut)/cut)) GOTO 140
50324 yd=sign(2d0*cut*((x3-cut)/cut)**pyr(0)-x3,pyr(0)-0.5d0)
50325 x1=1d0-0.5d0*(x3+yd)
50326 x2=1d0-0.5d0*(x3-yd)
50327 IF(4d0*(1d0-x1)*(1d0-x2)*(1d0-x3)/x3**2.LE.qme) njet=2
50328 IF(mstj(102).GE.2) THEN
50329 IF(x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*parj(171).LT.
50330 & x3**2*pyr(0)) njet=2
50331 ENDIF
50332 IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 130
50333 ENDIF
50334
50335 RETURN
50336 END
50337
50338C*********************************************************************
50339
50340C...PYX4JT
50341C...Selects the kinematical variables of four-jet events.
50342
50343 SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
50344
50345C...Double precision and integer declarations.
50346 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50347 IMPLICIT INTEGER(I-N)
50348 INTEGER PYK,PYCHGE,PYCOMP
50349C...Commonblocks.
50350 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50351 SAVE /pydat1/
50352C...Local arrays.
50353 dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
50354
50355C...Common constants. Colour factors for QCD and Abelian gluon theory.
50356 pmq=pymass(kfl)
50357 qme=(2d0*pmq/ecm)**2
50358 ct=log(1d0/cut-5d0)
50359 IF(mstj(109).EQ.0) THEN
50360 cf=4d0/3d0
50361 cn=3d0
50362 tr=2.5d0
50363 ELSE
50364 cf=1d0
50365 cn=0d0
50366 tr=15d0
50367 ENDIF
50368
50369C...Choice of process (qqbargg or qqbarqqbar).
50370 100 njet=4
50371 it=1
50372 IF(parj(155).GT.pyr(0)) it=2
50373 IF(mstj(101).LE.-3) it=-mstj(101)-2
50374 IF(it.EQ.1) wtmx=0.7d0/cut**2
50375 IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6d0/cut**2
50376 IF(it.EQ.2) wtmx=0.1125d0*cf*tr/cut**2
50377 id=1
50378
50379C...Sample the five kinematical variables (for qqgg preweighted in y34).
50380 110 y134=3d0*cut+(1d0-6d0*cut)*pyr(0)
50381 y234=3d0*cut+(1d0-6d0*cut)*pyr(0)
50382 IF(it.EQ.1) y34=(1d0-5d0*cut)*exp(-ct*pyr(0))
50383 IF(it.EQ.2) y34=cut+(1d0-6d0*cut)*pyr(0)
50384 IF(y34.LE.y134+y234-1d0.OR.y34.GE.y134*y234) GOTO 110
50385 vt=pyr(0)
50386 cp=cos(paru(1)*pyr(0))
50387 y14=(y134-y34)*vt
50388 y13=y134-y14-y34
50389 vb=y34*(1d0-y134-y234+y34)/((y134-y34)*(y234-y34))
50390 y24=0.5d0*(y234-y34)*(1d0-4d0*sqrt(max(0d0,vt*(1d0-vt)*
50391 &vb*(1d0-vb)))*cp-(1d0-2d0*vt)*(1d0-2d0*vb))
50392 y23=y234-y34-y24
50393 y12=1d0-y134-y23-y24
50394 IF(min(y12,y13,y14,y23,y24).LE.cut) GOTO 110
50395 y123=y12+y13+y23
50396 y124=y12+y14+y24
50397
50398C...Calculate matrix elements for qqgg or qqqq process.
50399 ic=0
50400 wttot=0d0
50401 120 ic=ic+1
50402 IF(it.EQ.1) THEN
50403 wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3d0*y12*y23*y34+
50404 & 3d0*y12*y14*y34+4d0*y12**2*y34-y13*y23*y24+2d0*y12*y23*y24-
50405 & y13*y14*y24-2d0*y12*y13*y24+2d0*y12**2*y24+y14*y23**2+2d0*y12*
50406 & y23**2+y14**2*y23+4d0*y12*y14*y23+4d0*y12**2*y23+2d0*y12*y14**2+
50407 & 2d0*y12*y13*y14+4d0*y12**2*y14+2d0*y12**2*y13+2d0*y12**3)/
50408 & (2d0*y13*y134*y234*y24)+(y24*y34+y12*y34+y13*y24-
50409 & y14*y23+y12*y13)/(y13*y134**2)+2d0*y23*(1d0-y13)/
50410 & (y13*y134*y24)+y34/(2d0*y13*y24)
50411 wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2d0*y12*
50412 & y14*y24)/(y13*y134*y23*y14)+y12*(1d0+y34)*y124/(y134*y234*y14*
50413 & y24)-(2d0*y13*y24+y14**2+y13*y23+2d0*y12*y13)/(y13*y134*y14)+
50414 & y12*y123*y124/(2d0*y13*y14*y23*y24)
50415 wtc(ic)=-(5d0*y12*y34**2+2d0*y12*y24*y34+2d0*y12*y23*y34+
50416 & 2d0*y12*y14*y34+2d0*y12*y13*y34+4d0*y12**2*y34-y13*y24**2+
50417 & y14*y23*y24+y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-
50418 & 3d0*y12*y13*y24-y14*y23**2-y14**2*y23+y13*y14*y23-
50419 & 3d0*y12*y14*y23-y12*y13*y23)/(4d0*y134*y234*y34**2)+
50420 & (3d0*y12*y34**2-3d0*y13*y24*y34+3d0*y12*y24*y34+
50421 & 3d0*y14*y23*y34-y13*y24**2-y12*y23*y34+6d0*y12*y14*y34+
50422 & 2d0*y12*y13*y34-2d0*y12**2*y34+y14*y23*y24-3d0*y13*y23*y24-
50423 & 2d0*y13*y14*y24+4d0*y12*y14*y24+2d0*y12*y13*y24+
50424 & 3d0*y14*y23**2+2d0*y14**2*y23+2d0*y14**2*y12+
50425 & 2d0*y12**2*y14+6d0*y12*y14*y23-2d0*y12*y13**2-
50426 & 2d0*y12**2*y13)/(4d0*y13*y134*y234*y34)
50427 wtc(ic)=wtc(ic)+(2d0*y12*y34**2-2d0*y13*y24*y34+y12*y24*y34+
50428 & 4d0*y13*y23*y34+4d0*y12*y14*y34+2d0*y12*y13*y34+2d0*y12**2*y34-
50429 & y13*y24**2+3d0*y14*y23*y24+4d0*y13*y23*y24-2d0*y13*y14*y24+
50430 & 4d0*y12*y14*y24+2d0*y12*y13*y24+2d0*y14*y23**2+4d0*y13*y23**2+
50431 & 2d0*y13*y14*y23+2d0*y12*y14*y23+4d0*y12*y13*y23+2d0*y12*y14**2+
50432 & 4d0*y12**2*y13+4d0*y12*y13*y14+2d0*y12**2*y14)/
50433 & (4d0*y13*y134*y24*y34)-(y12*y34**2-2d0*y14*y24*y34-
50434 & 2d0*y13*y24*y34-y14*y23*y34+y13*y23*y34+y12*y14*y34+
50435 & 2d0*y12*y13*y34-2d0*y14**2*y24-4d0*y13*y14*y24-
50436 & 4d0*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-
50437 & y12*y13**2)/(2d0*y13*y34*y134**2)+(y12*y34**2-
50438 & 4d0*y14*y24*y34-2d0*y13*y24*y34-2d0*y14*y23*y34-
50439 & 4d0*y13*y23*y34-4d0*y12*y14*y34-4d0*y12*y13*y34-
50440 & 2d0*y13*y14*y24+2d0*y13**2*y24+2d0*y14**2*y23-
50441 & 2d0*y13*y14*y23-y12*y14**2-6d0*y12*y13*y14-
50442 & y12*y13**2)/(4d0*y34**2*y134**2)
50443 wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5d0*cn)*wtb(ic)+
50444 & cn*wtc(ic))/8d0
50445 ELSE
50446 wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2d0*y12*
50447 & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
50448 & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
50449 & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
50450 & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
50451 & y13*y14*y24+2d0*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
50452 & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
50453 & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
50454 & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
50455 wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
50456 & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
50457 & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
50458 & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
50459 & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
50460 & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
50461 & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
50462 & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
50463 wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5d0*cn)*wte(ic))/16d0
50464 ENDIF
50465
50466C...Permutations of momenta in matrix element. Weighting.
50467 130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
50468 ysav=y13
50469 y13=y14
50470 y14=ysav
50471 ysav=y23
50472 y23=y24
50473 y24=ysav
50474 ysav=y123
50475 y123=y124
50476 y124=ysav
50477 ENDIF
50478 IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
50479 ysav=y13
50480 y13=y23
50481 y23=ysav
50482 ysav=y14
50483 y14=y24
50484 y24=ysav
50485 ysav=y134
50486 y134=y234
50487 y234=ysav
50488 ENDIF
50489 IF(ic.LE.3) GOTO 120
50490 IF(id.EQ.1.AND.wttot.LT.pyr(0)*wtmx) GOTO 110
50491 ic=5
50492
50493C...qqgg events: string configuration and event type.
50494 IF(it.EQ.1) THEN
50495 IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
50496 parj(156)=y34*(2d0*(wta(1)+wta(2)+wta(3)+wta(4))+4d0*(wtc(1)+
50497 & wtc(2)+wtc(3)+wtc(4)))/(9d0*wttot)
50498 IF(wta(2)+wta(4)+2d0*(wtc(2)+wtc(4)).GT.pyr(0)*(wta(1)+wta(2)+
50499 & wta(3)+wta(4)+2d0*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
50500 IF(id.EQ.2) GOTO 130
50501 ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
50502 parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8d0*wttot)
50503 IF(wta(2)+wta(4).GT.pyr(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
50504 IF(id.EQ.2) GOTO 130
50505 ENDIF
50506 mstj(120)=3
50507 IF(mstj(109).EQ.0.AND.0.5d0*y34*(wtc(1)+wtc(2)+wtc(3)+
50508 & wtc(4)).GT.pyr(0)*wttot) mstj(120)=4
50509 kfln=21
50510
50511C...Mass cuts. Kinematical variables out.
50512 IF(y12.LE.cut+qme) njet=2
50513 IF(njet.EQ.2) GOTO 150
50514 q12=0.5d0*(1d0-sqrt(1d0-qme/y12))
50515 x1=1d0-(1d0-q12)*y234-q12*y134
50516 x4=1d0-(1d0-q12)*y134-q12*y234
50517 x2=1d0-y124
50518 x12=(1d0-q12)*y13+q12*y23
50519 x14=y12-0.5d0*qme
50520 IF(y134*y234/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
50521
50522C...qqbarqqbar events: string configuration, choose new flavour.
50523 ELSE
50524 IF(id.EQ.1) THEN
50525 wtr=pyr(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
50526 IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
50527 IF(wtr.LT.wtd(3)+wtd(4)) id=3
50528 IF(wtr.LT.wtd(4)) id=4
50529 IF(id.GE.2) GOTO 130
50530 ENDIF
50531 mstj(120)=5
50532 parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16d0*wttot)
50533 140 kfln=1+int(5d0*pyr(0))
50534 IF(kfln.NE.kfl.AND.0.2d0*parj(156).LE.pyr(0)) GOTO 140
50535 IF(kfln.EQ.kfl.AND.1d0-0.8d0*parj(156).LE.pyr(0)) GOTO 140
50536 IF(kfln.GT.mstj(104)) njet=2
50537 pmqn=pymass(kfln)
50538 qmen=(2d0*pmqn/ecm)**2
50539
50540C...Mass cuts. Kinematical variables out.
50541 IF(y24.LE.cut+qme.OR.y13.LE.1.1d0*qmen) njet=2
50542 IF(njet.EQ.2) GOTO 150
50543 q24=0.5d0*(1d0-sqrt(1d0-qme/y24))
50544 q13=0.5d0*(1d0-sqrt(1d0-qmen/y13))
50545 x1=1d0-(1d0-q24)*y123-q24*y134
50546 x4=1d0-(1d0-q24)*y134-q24*y123
50547 x2=1d0-(1d0-q13)*y234-q13*y124
50548 x12=(1d0-q24)*((1d0-q13)*y14+q13*y34)+q24*((1d0-q13)*y12+
50549 & q13*y23)
50550 x14=y24-0.5d0*qme
50551 x34=(1d0-q24)*((1d0-q13)*y23+q13*y12)+q24*((1d0-q13)*y34+
50552 & q13*y14)
50553 IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
50554 & (parj(127)+pmq+pmqn)**2) njet=2
50555 IF(y123*y134/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
50556 ENDIF
50557 150 IF(mstj(101).LE.-2.AND.njet.EQ.2) GOTO 100
50558
50559 RETURN
50560 END
50561
50562C*********************************************************************
50563
50564C...PYXDIF
50565C...Gives the angular orientation of events.
50566
50567 SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
50568
50569C...Double precision and integer declarations.
50570 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50571 IMPLICIT INTEGER(I-N)
50572 INTEGER PYK,PYCHGE,PYCOMP
50573C...Commonblocks.
50574 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
50575 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50576 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50577 SAVE /pyjets/,/pydat1/,/pydat2/
50578
50579C...Charge. Factors depending on polarization for QED case.
50580 qf=kchg(kfl,1)/3d0
50581 poll=1d0-parj(131)*parj(132)
50582 pold=parj(132)-parj(131)
50583 IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
50584 hf1=poll
50585 hf2=0d0
50586 hf3=parj(133)**2
50587 hf4=0d0
50588
50589C...Factors depending on flavour, energy and polarization for QFD case.
50590 ELSE
50591 sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
50592 sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
50593 sfi=sfw*(1d0-(parj(123)/ecm)**2)
50594 ae=-1d0
50595 ve=4d0*paru(102)-1d0
50596 af=sign(1d0,qf)
50597 vf=af-4d0*qf*paru(102)
50598 hf1=qf**2*poll-2d0*qf*vf*sfi*sff*(ve*poll-ae*pold)+
50599 & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2d0*ve*ae*pold)
50600 hf2=-2d0*qf*af*sfi*sff*(ae*poll-ve*pold)+2d0*vf*af*sfw*sff**2*
50601 & (2d0*ve*ae*poll-(ve**2+ae**2)*pold)
50602 hf3=parj(133)**2*(qf**2-2d0*qf*vf*sfi*sff*ve+(vf**2+af**2)*
50603 & sfw*sff**2*(ve**2-ae**2))
50604 hf4=-parj(133)**2*2d0*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
50605 & sff*ae
50606 ENDIF
50607
50608C...Mass factor. Differential cross-sections for two-jet events.
50609 sq2=sqrt(2d0)
50610 qme=0d0
50611 IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
50612 &mstj(109).NE.1) qme=(2d0*pymass(kfl)/ecm)**2
50613 IF(njet.EQ.2) THEN
50614 sigu=4d0*sqrt(1d0-qme)
50615 sigl=2d0*qme*sqrt(1d0-qme)
50616 sigt=0d0
50617 sigi=0d0
50618 siga=0d0
50619 sigp=4d0
50620
50621C...Kinematical variables. Reduce four-jet event to three-jet one.
50622 ELSE
50623 IF(njet.EQ.3) THEN
50624 x1=2d0*p(nc+1,4)/ecm
50625 x2=2d0*p(nc+3,4)/ecm
50626 ELSE
50627 ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
50628 & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
50629 x1=2d0*p(nc+1,4)/ecmr
50630 x2=2d0*p(nc+4,4)/ecmr
50631 ENDIF
50632
50633C...Differential cross-sections for three-jet (or reduced four-jet).
50634 xq=(1d0-x1)/(1d0-x2)
50635 ct12=(x1*x2-2d0*x1-2d0*x2+2d0+qme)/sqrt((x1**2-qme)*(x2**2-qme))
50636 st12=sqrt(1d0-ct12**2)
50637 IF(mstj(109).NE.1) THEN
50638 sigu=2d0*x1**2+x2**2*(1d0+ct12**2)-qme*(3d0+ct12**2-x1-x2)-
50639 & qme*x1/xq+0.5d0*qme*((x2**2-qme)*st12**2-2d0*x2)*xq
50640 sigl=(x2*st12)**2-qme*(3d0-ct12**2-2.5d0*(x1+x2)+x1*x2+qme)+
50641 & 0.5d0*qme*(x1**2-x1-qme)/xq+0.5d0*qme*((x2**2-qme)*ct12**2-
50642 & x2)*xq
50643 sigt=0.5d0*(x2**2-qme-0.5d0*qme*(x2**2-qme)/xq)*st12**2
50644 sigi=((1d0-0.5d0*qme*xq)*(x2**2-qme)*st12*ct12+
50645 & qme*(1d0-x1-x2+0.5d0*x1*x2+0.5d0*qme)*st12/ct12)/sq2
50646 siga=x2**2*st12/sq2
50647 sigp=2d0*(x1**2-x2**2*ct12)
50648
50649C...Differential cross-sect for scalar gluons (no mass effects).
50650 ELSE
50651 x3=2d0-x1-x2
50652 xt=x2*st12
50653 ct13=sqrt(max(0d0,1d0-(xt/x3)**2))
50654 sigu=(1d0-parj(171))*(x3**2-0.5d0*xt**2)+
50655 & parj(171)*(x3**2-0.5d0*xt**2-4d0*(1d0-x1)*(1d0-x2)**2/x1)
50656 sigl=(1d0-parj(171))*0.5d0*xt**2+
50657 & parj(171)*0.5d0*(1d0-x1)**2*xt**2
50658 sigt=(1d0-parj(171))*0.25d0*xt**2+
50659 & parj(171)*0.25d0*xt**2*(1d0-2d0*x1)
50660 sigi=-(0.5d0/sq2)*((1d0-parj(171))*xt*x3*ct13+
50661 & parj(171)*xt*((1d0-2d0*x1)*x3*ct13-x1*(x1-x2)))
50662 siga=(0.25d0/sq2)*xt*(2d0*(1d0-x1)-x1*x3)
50663 sigp=x3**2-2d0*(1d0-x1)*(1d0-x2)/x1
50664 ENDIF
50665 ENDIF
50666
50667C...Upper bounds for differential cross-section.
50668 hf1a=abs(hf1)
50669 hf2a=abs(hf2)
50670 hf3a=abs(hf3)
50671 hf4a=abs(hf4)
50672 sigmax=(2d0*hf1a+hf3a+hf4a)*abs(sigu)+2d0*(hf1a+hf3a+hf4a)*
50673 &abs(sigl)+2d0*(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigt)+2d0*sq2*
50674 &(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigi)+4d0*sq2*hf2a*abs(siga)+
50675 &2d0*hf2a*abs(sigp)
50676
50677C...Generate angular orientation according to differential cross-sect.
50678 100 chi=paru(2)*pyr(0)
50679 cthe=2d0*pyr(0)-1d0
50680 phi=paru(2)*pyr(0)
50681 cchi=cos(chi)
50682 schi=sin(chi)
50683 c2chi=cos(2d0*chi)
50684 s2chi=sin(2d0*chi)
50685 the=acos(cthe)
50686 sthe=sin(the)
50687 c2phi=cos(2d0*(phi-parj(134)))
50688 s2phi=sin(2d0*(phi-parj(134)))
50689 sig=((1d0+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
50690 &2d0*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
50691 &2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*c2chi*c2phi-2d0*cthe*s2chi*
50692 &s2phi)*hf3-((1d0+cthe**2)*c2chi*s2phi+2d0*cthe*s2chi*c2phi)*hf4)*
50693 &sigt-2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*(cthe*cchi*c2phi-
50694 &schi*s2phi)*hf3+2d0*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
50695 &4d0*sq2*sthe*cchi*hf2*siga+2d0*cthe*hf2*sigp
50696 IF(sig.LT.sigmax*pyr(0)) GOTO 100
50697
50698 RETURN
50699 END
50700
50701C*********************************************************************
50702
50703C...PYONIA
50704C...Generates Upsilon and toponium decays into three gluons
50705C...or two gluons and a photon.
50706
50707 SUBROUTINE pyonia(KFL,ECM)
50708
50709C...Double precision and integer declarations.
50710 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50711 IMPLICIT INTEGER(I-N)
50712 INTEGER PYK,PYCHGE,PYCOMP
50713C...Commonblocks.
50714 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
50715 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50716 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50717 SAVE /pyjets/,/pydat1/,/pydat2/
50718
50719C...Printout. Check input parameters.
50720 IF(mstu(12).GE.1) CALL pylist(0)
50721 IF(kfl.LT.0.OR.kfl.GT.8) THEN
50722 CALL pyerrm(16,'(PYONIA:) called with unknown flavour code')
50723 IF(mstu(21).GE.1) RETURN
50724 ENDIF
50725 IF(ecm.LT.parj(127)+2.02d0*parf(101)) THEN
50726 CALL pyerrm(16,'(PYONIA:) called with too small CM energy')
50727 IF(mstu(21).GE.1) RETURN
50728 ENDIF
50729
50730C...Initial e+e- and onium state (optional).
50731 nc=0
50732 IF(mstj(115).GE.2) THEN
50733 nc=nc+2
50734 CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
50735 k(nc-1,1)=21
50736 CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
50737 k(nc,1)=21
50738 ENDIF
50739 kflc=iabs(kfl)
50740 IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
50741 nc=nc+1
50742 kf=110*kflc+3
50743 mstu10=mstu(10)
50744 mstu(10)=1
50745 p(nc,5)=ecm
50746 CALL py1ent(nc,kf,ecm,0d0,0d0)
50747 k(nc,1)=21
50748 k(nc,3)=1
50749 mstu(10)=mstu10
50750 ENDIF
50751
50752C...Choose x1 and x2 according to matrix element.
50753 ntry=0
50754 100 x1=pyr(0)
50755 x2=pyr(0)
50756 x3=2d0-x1-x2
50757 IF(x3.GE.1d0.OR.((1d0-x1)/(x2*x3))**2+((1d0-x2)/(x1*x3))**2+
50758 &((1d0-x3)/(x1*x2))**2.LE.2d0*pyr(0)) GOTO 100
50759 ntry=ntry+1
50760 njet=3
50761 IF(mstj(101).LE.4) CALL py3ent(nc+1,21,21,21,ecm,x1,x3)
50762 IF(mstj(101).GE.5) CALL py3ent(-(nc+1),21,21,21,ecm,x1,x3)
50763
50764C...Photon-gluon-gluon events. Small system modifications. Jet origin.
50765 mstu(111)=mstj(108)
50766 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
50767 &mstu(111)=1
50768 paru(112)=parj(121)
50769 IF(mstu(111).EQ.2) paru(112)=parj(122)
50770 qf=0d0
50771 IF(kflc.NE.0) qf=kchg(kflc,1)/3d0
50772 rgam=7.2d0*qf**2*paru(101)/pyalps(ecm**2)
50773 mk=0
50774 ecmc=ecm
50775 IF(pyr(0).GT.rgam/(1d0+rgam)) THEN
50776 IF(1d0-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
50777 & njet=2
50778 IF(njet.EQ.2.AND.mstj(101).LE.4) CALL py2ent(nc+1,21,21,ecm)
50779 IF(njet.EQ.2.AND.mstj(101).GE.5) CALL py2ent(-(nc+1),21,21,ecm)
50780 ELSE
50781 mk=1
50782 ecmc=sqrt(1d0-x1)*ecm
50783 IF(ecmc.LT.2d0*parj(127)) GOTO 100
50784 k(nc+1,1)=1
50785 k(nc+1,2)=22
50786 k(nc+1,4)=0
50787 k(nc+1,5)=0
50788 IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
50789 IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
50790 IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
50791 IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
50792 njet=2
50793 IF(ecmc.LT.4d0*parj(127)) THEN
50794 mstu10=mstu(10)
50795 mstu(10)=1
50796 p(nc+2,5)=ecmc
50797 CALL py1ent(nc+2,83,0.5d0*(x2+x3)*ecm,paru(1),0d0)
50798 mstu(10)=mstu10
50799 njet=0
50800 ENDIF
50801 ENDIF
50802 DO 110 ip=nc+1,n
50803 k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
50804 110 CONTINUE
50805
50806C...Differential cross-sections. Upper limit for cross-section.
50807 IF(mstj(106).EQ.1) THEN
50808 sq2=sqrt(2d0)
50809 hf1=1d0-parj(131)*parj(132)
50810 hf3=parj(133)**2
50811 ct13=(x1*x3-2d0*x1-2d0*x3+2d0)/(x1*x3)
50812 st13=sqrt(1d0-ct13**2)
50813 sigl=0.5d0*x3**2*((1d0-x2)**2+(1d0-x3)**2)*st13**2
50814 sigu=(x1*(1d0-x1))**2+(x2*(1d0-x2))**2+(x3*(1d0-x3))**2-sigl
50815 sigt=0.5d0*sigl
50816 sigi=(sigl*ct13/st13+0.5d0*x1*x3*(1d0-x2)**2*st13)/sq2
50817 sigmax=(2d0*hf1+hf3)*abs(sigu)+2d0*(hf1+hf3)*abs(sigl)+2d0*(hf1+
50818 & 2d0*hf3)*abs(sigt)+2d0*sq2*(hf1+2d0*hf3)*abs(sigi)
50819
50820C...Angular orientation of event.
50821 120 chi=paru(2)*pyr(0)
50822 cthe=2d0*pyr(0)-1d0
50823 phi=paru(2)*pyr(0)
50824 cchi=cos(chi)
50825 schi=sin(chi)
50826 c2chi=cos(2d0*chi)
50827 s2chi=sin(2d0*chi)
50828 the=acos(cthe)
50829 sthe=sin(the)
50830 c2phi=cos(2d0*(phi-parj(134)))
50831 s2phi=sin(2d0*(phi-parj(134)))
50832 sig=((1d0+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2d0*(sthe**2*hf1-
50833 & sthe**2*c2phi*hf3)*sigl+2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*
50834 & c2chi*c2phi-2d0*cthe*s2chi*s2phi)*hf3)*sigt-
50835 & 2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*
50836 & (cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
50837 IF(sig.LT.sigmax*pyr(0)) GOTO 120
50838 CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
50839 CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
50840 ENDIF
50841
50842C...Generate parton shower. Rearrange along strings and check.
50843 IF(mstj(101).GE.5.AND.njet.GE.2) THEN
50844 CALL pyshow(nc+mk+1,-njet,ecmc)
50845 mstj14=mstj(14)
50846 IF(mstj(105).EQ.-1) mstj(14)=-1
50847 IF(mstj(105).GE.0) mstu(28)=0
50848 CALL pyprep(0)
50849 mstj(14)=mstj14
50850 IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
50851 ENDIF
50852
50853C...Generate fragmentation. Information for PYTABU:
50854 IF(mstj(105).EQ.1) CALL pyexec
50855 mstu(161)=110*kflc+3
50856 mstu(162)=0
50857
50858 RETURN
50859 END
50860
50861C*********************************************************************
50862
50863C...PYBOOK
50864C...Books a histogram.
50865
50866 SUBROUTINE pybook(ID,TITLE,NX,XL,XU)
50867
50868C...Double precision declaration.
50869 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50870 IMPLICIT INTEGER(I-N)
50871C...Commonblock.
50872 common/pybins/ihist(4),indx(1000),bin(20000)
50873 SAVE /pybins/
50874C...Local character variables.
50875 CHARACTER TITLE*(*), TITFX*60
50876
50877C...Check that input is sensible. Find initial address in memory.
50878 IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
50879 &'(PYBOOK:) not allowed histogram number')
50880 IF(nx.LE.0.OR.nx.GT.100) CALL pyerrm(28,
50881 &'(PYBOOK:) not allowed number of bins')
50882 IF(xl.GE.xu) CALL pyerrm(28,
50883 &'(PYBOOK:) x limits in wrong order')
50884 indx(id)=ihist(4)
50885 ihist(4)=ihist(4)+28+nx
50886 IF(ihist(4).GT.ihist(2)) CALL pyerrm(28,
50887 &'(PYBOOK:) out of histogram space')
50888 is=indx(id)
50889
50890C...Store histogram size and reset contents.
50891 bin(is+1)=nx
50892 bin(is+2)=xl
50893 bin(is+3)=xu
50894 bin(is+4)=(xu-xl)/nx
50895 CALL pynull(id)
50896
50897C...Store title by conversion to integer to double precision.
50898 titfx=title//' '
50899 DO 100 it=1,20
50900 bin(is+8+nx+it)=256**2*ichar(titfx(3*it-2:3*it-2))+
50901 & 256*ichar(titfx(3*it-1:3*it-1))+ichar(titfx(3*it:3*it))
50902 100 CONTINUE
50903
50904 RETURN
50905 END
50906
50907C*********************************************************************
50908
50909C...PYFILL
50910C...Fills entry in histogram.
50911
50912 SUBROUTINE pyfill(ID,X,W)
50913
50914C...Double precision declaration.
50915 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50916 IMPLICIT INTEGER(I-N)
50917C...Commonblock.
50918 common/pybins/ihist(4),indx(1000),bin(20000)
50919 SAVE /pybins/
50920
50921C...Find initial address in memory. Increase number of entries.
50922 IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
50923 &'(PYFILL:) not allowed histogram number')
50924 is=indx(id)
50925 IF(is.EQ.0) CALL pyerrm(28,
50926 &'(PYFILL:) filling unbooked histogram')
50927 bin(is+5)=bin(is+5)+1d0
50928
50929C...Find bin in x, including under/overflow, and fill.
50930 IF(x.LT.bin(is+2)) THEN
50931 bin(is+6)=bin(is+6)+w
50932 ELSEIF(x.GE.bin(is+3)) THEN
50933 bin(is+8)=bin(is+8)+w
50934 ELSE
50935 bin(is+7)=bin(is+7)+w
50936 ix=(x-bin(is+2))/bin(is+4)
50937 ix=max(0,min(nint(bin(is+1))-1,ix))
50938 bin(is+9+ix)=bin(is+9+ix)+w
50939 ENDIF
50940
50941 RETURN
50942 END
50943
50944C*********************************************************************
50945
50946C...PYFACT
50947C...Multiplies histogram contents by factor.
50948
50949 SUBROUTINE pyfact(ID,F)
50950
50951C...Double precision declaration.
50952 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50953 IMPLICIT INTEGER(I-N)
50954C...Commonblock.
50955 common/pybins/ihist(4),indx(1000),bin(20000)
50956 SAVE /pybins/
50957
50958C...Find initial address in memory. Multiply all contents bins.
50959 IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
50960 &'(PYFACT:) not allowed histogram number')
50961 is=indx(id)
50962 IF(is.EQ.0) CALL pyerrm(28,
50963 &'(PYFACT:) scaling unbooked histogram')
50964 DO 100 ix=is+6,is+8+nint(bin(is+1))
50965 bin(ix)=f*bin(ix)
50966 100 CONTINUE
50967
50968 RETURN
50969 END
50970
50971C*********************************************************************
50972
50973C...PYOPER
50974C...Performs operations between histograms.
50975
50976 SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)
50977
50978C...Double precision declaration.
50979 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50980 IMPLICIT INTEGER(I-N)
50981C...Commonblock.
50982 common/pybins/ihist(4),indx(1000),bin(20000)
50983 SAVE /pybins/
50984C...Character variable.
50985 CHARACTER OPER*(*)
50986
50987C...Find initial addresses in memory, and histogram size.
50988 IF(id1.LE.0.OR.id1.GT.ihist(1)) CALL pyerrm(28,
50989 &'(PYFACT:) not allowed histogram number')
50990 is1=indx(id1)
50991 is2=indx(min(ihist(1),max(1,id2)))
50992 is3=indx(min(ihist(1),max(1,id3)))
50993 nx=nint(bin(is3+1))
50994 IF(oper.EQ.'M'.AND.id3.EQ.0) nx=nint(bin(is2+1))
50995
50996C...Update info on number of histogram entries.
50997 IF(oper.EQ.'+'.OR.oper.EQ.'-'.OR.oper.EQ.'*'.OR.oper.EQ.'/') THEN
50998 bin(is3+5)=bin(is1+5)+bin(is2+5)
50999 ELSEIF(oper.EQ.'A'.OR.oper.EQ.'S'.OR.oper.EQ.'L') THEN
51000 bin(is3+5)=bin(is1+5)
51001 ENDIF
51002
51003C...Operations on pair of histograms: addition, subtraction,
51004C...multiplication, division.
51005 IF(oper.EQ.'+') THEN
51006 DO 100 ix=6,8+nx
51007 bin(is3+ix)=f1*bin(is1+ix)+f2*bin(is2+ix)
51008 100 CONTINUE
51009 ELSEIF(oper.EQ.'-') THEN
51010 DO 110 ix=6,8+nx
51011 bin(is3+ix)=f1*bin(is1+ix)-f2*bin(is2+ix)
51012 110 CONTINUE
51013 ELSEIF(oper.EQ.'*') THEN
51014 DO 120 ix=6,8+nx
51015 bin(is3+ix)=f1*bin(is1+ix)*f2*bin(is2+ix)
51016 120 CONTINUE
51017 ELSEIF(oper.EQ.'/') THEN
51018 DO 130 ix=6,8+nx
51019 fa2=f2*bin(is2+ix)
51020 IF(abs(fa2).LE.1d-20) THEN
51021 bin(is3+ix)=0d0
51022 ELSE
51023 bin(is3+ix)=f1*bin(is1+ix)/fa2
51024 ENDIF
51025 130 CONTINUE
51026
51027C...Operations on single histogram: multiplication+addition,
51028C...square root+addition, logarithm+addition.
51029 ELSEIF(oper.EQ.'A') THEN
51030 DO 140 ix=6,8+nx
51031 bin(is3+ix)=f1*bin(is1+ix)+f2
51032 140 CONTINUE
51033 ELSEIF(oper.EQ.'S') THEN
51034 DO 150 ix=6,8+nx
51035 bin(is3+ix)=f1*sqrt(max(0d0,bin(is1+ix)))+f2
51036 150 CONTINUE
51037 ELSEIF(oper.EQ.'L') THEN
51038 zmin=1d20
51039 DO 160 ix=9,8+nx
51040 IF(bin(is1+ix).LT.zmin.AND.bin(is1+ix).GT.1d-20)
51041 & zmin=0.8d0*bin(is1+ix)
51042 160 CONTINUE
51043 DO 170 ix=6,8+nx
51044 bin(is3+ix)=f1*log10(max(zmin,bin(is1+ix)))+f2
51045 170 CONTINUE
51046
51047C...Operation on two or three histograms: average and
51048C...standard deviation.
51049 ELSEIF(oper.EQ.'M') THEN
51050 DO 180 ix=6,8+nx
51051 IF(abs(bin(is1+ix)).LE.1d-20) THEN
51052 bin(is2+ix)=0d0
51053 ELSE
51054 bin(is2+ix)=bin(is2+ix)/bin(is1+ix)
51055 ENDIF
51056 IF(id3.NE.0) THEN
51057 IF(abs(bin(is1+ix)).LE.1d-20) THEN
51058 bin(is3+ix)=0d0
51059 ELSE
51060 bin(is3+ix)=sqrt(max(0d0,bin(is3+ix)/bin(is1+ix)-
51061 & bin(is2+ix)**2))
51062 ENDIF
51063 ENDIF
51064 bin(is1+ix)=f1*bin(is1+ix)
51065 180 CONTINUE
51066 ENDIF
51067
51068 RETURN
51069 END
51070
51071C*********************************************************************
51072
51073C...PYHIST
51074C...Prints and resets all histograms.
51075
51076 SUBROUTINE pyhist
51077
51078C...Double precision declaration.
51079 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51080 IMPLICIT INTEGER(I-N)
51081C...Commonblock.
51082 common/pybins/ihist(4),indx(1000),bin(20000)
51083 SAVE /pybins/
51084
51085C...Loop over histograms, print and reset used ones.
51086 DO 100 id=1,ihist(1)
51087 is=indx(id)
51088 IF(is.NE.0.AND.nint(bin(is+5)).GT.0) THEN
51089 CALL pyplot(id)
51090 CALL pynull(id)
51091 ENDIF
51092 100 CONTINUE
51093
51094 RETURN
51095 END
51096
51097C*********************************************************************
51098
51099C...PYPLOT
51100C...Prints a histogram (but does not reset it).
51101
51102 SUBROUTINE pyplot(ID)
51103
51104C...Double precision declaration.
51105 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51106 IMPLICIT INTEGER(I-N)
51107C...Commonblocks.
51108 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51109 common/pybins/ihist(4),indx(1000),bin(20000)
51110 SAVE /pydat1/,/pybins/
51111C...Local arrays and character variables.
51112 dimension idati(6), irow(100), ifra(100), dyac(10)
51113 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
51114
51115C...Steps in histogram scale. Character sequence.
51116 DATA dyac/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
51117 DATA cha/'0','1','2','3','4','5','6','7','8','9','X','-'/
51118
51119C...Find initial address in memory; skip if empty histogram.
51120 IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
51121 is=indx(id)
51122 IF(is.EQ.0) RETURN
51123 IF(nint(bin(is+5)).LE.0) THEN
51124 WRITE(mstu(11),5000) id
51125 RETURN
51126 ENDIF
51127
51128C...Number of histogram lines and x bins.
51129 lin=ihist(3)-18
51130 nx=nint(bin(is+1))
51131
51132C...Extract title by conversion from double precision via integer.
51133 DO 100 it=1,20
51134 ieq=nint(bin(is+8+nx+it))
51135 title(3*it-2:3*it)=char(ieq/256**2)//char(mod(ieq,256**2)/256)
51136 & //char(mod(ieq,256))
51137 100 CONTINUE
51138
51139C...Find time; print title.
51140 CALL pytime(idati)
51141 IF(idati(1).GT.0) THEN
51142 WRITE(mstu(11),5100) id, title, (idati(j),j=1,5)
51143 ELSE
51144 WRITE(mstu(11),5200) id, title
51145 ENDIF
51146
51147C...Find minimum and maximum bin content.
51148 ymin=bin(is+9)
51149 ymax=bin(is+9)
51150 DO 110 ix=is+10,is+8+nx
51151 IF(bin(ix).LT.ymin) ymin=bin(ix)
51152 IF(bin(ix).GT.ymax) ymax=bin(ix)
51153 110 CONTINUE
51154
51155C...Determine scale and step size for y axis.
51156 IF(ymax-ymin.GT.lin*dyac(1)*1d-9) THEN
51157 IF(ymin.GT.0d0.AND.ymin.LT.0.1d0*ymax) ymin=0d0
51158 IF(ymax.LT.0d0.AND.ymax.GT.0.1d0*ymin) ymax=0d0
51159 ipot=int(log10(ymax-ymin)+10d0)-10
51160 IF(ymax-ymin.LT.lin*dyac(1)*10d0**ipot) ipot=ipot-1
51161 IF(ymax-ymin.GT.lin*dyac(10)*10d0**ipot) ipot=ipot+1
51162 dely=dyac(1)
51163 DO 120 idel=1,9
51164 IF(ymax-ymin.GE.lin*dyac(idel)*10d0**ipot) dely=dyac(idel+1)
51165 120 CONTINUE
51166 dy=dely*10d0**ipot
51167
51168C...Convert bin contents to integer form; fractional fill in top row.
51169 DO 130 ix=1,nx
51170 cta=abs(bin(is+8+ix))/dy
51171 irow(ix)=sign(cta+0.95d0,bin(is+8+ix))
51172 ifra(ix)=10d0*(cta+1.05d0-dble(int(cta+0.95d0)))
51173 130 CONTINUE
51174 irmi=sign(abs(ymin)/dy+0.95d0,ymin)
51175 irma=sign(abs(ymax)/dy+0.95d0,ymax)
51176
51177C...Print histogram row by row.
51178 DO 150 ir=irma,irmi,-1
51179 IF(ir.EQ.0) GOTO 150
51180 out=' '
51181 DO 140 ix=1,nx
51182 IF(ir.EQ.irow(ix)) out(ix:ix)=cha(ifra(ix))
51183 IF(ir*(irow(ix)-ir).GT.0) out(ix:ix)=cha(10)
51184 140 CONTINUE
51185 WRITE(mstu(11),5300) ir*dely, ipot, out
51186 150 CONTINUE
51187
51188C...Print sign and value of bin contents.
51189 ipot=int(log10(max(ymax,-ymin))+10.0001d0)-10
51190 out=' '
51191 DO 160 ix=1,nx
51192 IF(bin(is+8+ix).LT.-10d0**(ipot-4)) out(ix:ix)=cha(11)
51193 irow(ix)=nint(10d0**(3-ipot)*abs(bin(is+8+ix)))
51194 160 CONTINUE
51195 WRITE(mstu(11),5400) out
51196 DO 180 ir=4,1,-1
51197 DO 170 ix=1,nx
51198 out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
51199 170 CONTINUE
51200 WRITE(mstu(11),5500) ipot+ir-4, out
51201 180 CONTINUE
51202
51203C...Print sign and value of lower bin edge.
51204 ipot=int(log10(max(-bin(is+2),bin(is+3)-bin(is+4)))+
51205 & 10.0001d0)-10
51206 out=' '
51207 DO 190 ix=1,nx
51208 IF(bin(is+2)+(ix-1)*bin(is+4).LT.-10d0**(ipot-3))
51209 & out(ix:ix)=cha(11)
51210 irow(ix)=nint(10d0**(2-ipot)*abs(bin(is+2)+(ix-1)*bin(is+4)))
51211 190 CONTINUE
51212 WRITE(mstu(11),5600) out
51213 DO 210 ir=3,1,-1
51214 DO 200 ix=1,nx
51215 out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
51216 200 CONTINUE
51217 WRITE(mstu(11),5500) ipot+ir-3, out
51218 210 CONTINUE
51219 ENDIF
51220
51221C...Calculate and print statistics.
51222 csum=0d0
51223 cxsum=0d0
51224 cxxsum=0d0
51225 DO 220 ix=1,nx
51226 cta=abs(bin(is+8+ix))
51227 x=bin(is+2)+(ix-0.5d0)*bin(is+4)
51228 csum=csum+cta
51229 cxsum=cxsum+cta*x
51230 cxxsum=cxxsum+cta*x**2
51231 220 CONTINUE
51232 xmean=cxsum/max(csum,1d-20)
51233 xrms=sqrt(max(0d0,cxxsum/max(csum,1d-20)-xmean**2))
51234 WRITE(mstu(11),5700) nint(bin(is+5)),xmean,bin(is+6),
51235 &bin(is+2),bin(is+7),xrms,bin(is+8),bin(is+3)
51236
51237C...Formats for output.
51238 5000 FORMAT(/5x,'Histogram no',i5,' : no entries')
51239 5100 FORMAT('1'/5x,'Histogram no',i5,6x,a60,5x,i4,'-',i2,'-',i2,1x,
51240 &i2,':',i2/)
51241 5200 FORMAT('1'/5x,'Histogram no',i5,6x,a60/)
51242 5300 FORMAT(2x,f7.2,'*10**',i2,3x,a100)
51243 5400 FORMAT(/8x,'Contents',3x,a100)
51244 5500 FORMAT(9x,'*10**',i2,3x,a100)
51245 5600 FORMAT(/8x,'Low edge',3x,a100)
51246 5700 FORMAT(/5x,'Entries =',i12,1p,6x,'Mean =',d12.4,6x,'Underflow ='
51247 &,d12.4,6x,'Low edge =',d12.4/5x,'All chan =',d12.4,6x,
51248 &'Rms =',d12.4,6x,'Overflow =',d12.4,6x,'High edge =',d12.4)
51249
51250 RETURN
51251 END
51252
51253C*********************************************************************
51254
51255C...PYNULL
51256C...Resets bin contents of a histogram.
51257
51258 SUBROUTINE pynull(ID)
51259
51260C...Double precision declaration.
51261 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51262 IMPLICIT INTEGER(I-N)
51263C...Commonblock.
51264 common/pybins/ihist(4),indx(1000),bin(20000)
51265 SAVE /pybins/
51266
51267 IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
51268 is=indx(id)
51269 IF(is.EQ.0) RETURN
51270 DO 100 ix=is+5,is+8+nint(bin(is+1))
51271 bin(ix)=0d0
51272 100 CONTINUE
51273
51274 RETURN
51275 END
51276
51277C*********************************************************************
51278
51279C...PYDUMP
51280C...Dumps histogram contents on file for reading by other program.
51281C...Can also read back own dump.
51282
51283 SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)
51284
51285C...Double precision declaration.
51286 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51287 IMPLICIT INTEGER(I-N)
51288C...Commonblock.
51289 common/pybins/ihist(4),indx(1000),bin(20000)
51290 SAVE /pybins/
51291C...Local arrays and character variables.
51292 dimension ihi(*),iss(100),val(5)
51293 CHARACTER TITLE*60,FORMAT*13
51294
51295C...Dump all histograms that have been booked,
51296C...including titles and ranges, one after the other.
51297 IF(mdump.EQ.1) THEN
51298
51299C...Loop over histograms and find which are wanted and booked.
51300 IF(nhi.LE.0) THEN
51301 nw=ihist(1)
51302 ELSE
51303 nw=nhi
51304 ENDIF
51305 DO 130 iw=1,nw
51306 IF(nhi.EQ.0) THEN
51307 id=iw
51308 ELSE
51309 id=ihi(iw)
51310 ENDIF
51311 is=indx(id)
51312 IF(is.NE.0) THEN
51313
51314C...Write title, histogram size, filling statistics.
51315 nx=nint(bin(is+1))
51316 DO 100 it=1,20
51317 ieq=nint(bin(is+8+nx+it))
51318 title(3*it-2:3*it)=char(ieq/256**2)//
51319 & char(mod(ieq,256**2)/256)//char(mod(ieq,256))
51320 100 CONTINUE
51321 WRITE(lfn,5100) id,title
51322 WRITE(lfn,5200) nx,bin(is+2),bin(is+3)
51323 WRITE(lfn,5300) nint(bin(is+5)),bin(is+6),bin(is+7),
51324 & bin(is+8)
51325
51326
51327C...Write histogram contents, in groups of five.
51328 DO 120 ixg=1,(nx+4)/5
51329 DO 110 ixv=1,5
51330 ix=5*ixg+ixv-5
51331 IF(ix.LE.nx) THEN
51332 val(ixv)=bin(is+8+ix)
51333 ELSE
51334 val(ixv)=0d0
51335 ENDIF
51336 110 CONTINUE
51337 WRITE(lfn,5400) (val(ixv),ixv=1,5)
51338 120 CONTINUE
51339
51340C...Go to next histogram; finish.
51341 ELSEIF(nhi.GT.0) THEN
51342 CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
51343 ENDIF
51344 130 CONTINUE
51345
51346C...Read back in histograms dumped MDUMP=1.
51347 ELSEIF(mdump.EQ.2) THEN
51348
51349C...Read histogram number, title and range, and book.
51350 140 READ(lfn,5100,END=170) ID,title
51351 READ(lfn,5200) nx,xl,xu
51352 CALL pybook(id,title,nx,xl,xu)
51353 is=indx(id)
51354
51355C...Read filling statistics.
51356 READ(lfn,5300) nentry,bin(is+6),bin(is+7),bin(is+8)
51357 bin(is+5)=dble(nentry)
51358
51359C...Read histogram contents, in groups of five.
51360 DO 160 ixg=1,(nx+4)/5
51361 READ(lfn,5400) (val(ixv),ixv=1,5)
51362 DO 150 ixv=1,5
51363 ix=5*ixg+ixv-5
51364 IF(ix.LE.nx) bin(is+8+ix)=val(ixv)
51365 150 CONTINUE
51366 160 CONTINUE
51367
51368C...Go to next histogram; finish.
51369 GOTO 140
51370 170 CONTINUE
51371
51372C...Write histogram contents in column format,
51373C...convenient e.g. for GNUPLOT input.
51374 ELSEIF(mdump.EQ.3) THEN
51375
51376C...Find addresses to wanted histograms.
51377 nss=0
51378 IF(nhi.LE.0) THEN
51379 nw=ihist(1)
51380 ELSE
51381 nw=nhi
51382 ENDIF
51383 DO 180 iw=1,nw
51384 IF(nhi.EQ.0) THEN
51385 id=iw
51386 ELSE
51387 id=ihi(iw)
51388 ENDIF
51389 is=indx(id)
51390 IF(is.NE.0.AND.nss.LT.100) THEN
51391 nss=nss+1
51392 iss(nss)=is
51393 ELSEIF(nss.GE.100) THEN
51394 CALL pyerrm(8,'(PYDUMP:) too many histograms requested')
51395 ELSEIF(nhi.GT.0) THEN
51396 CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
51397 ENDIF
51398 180 CONTINUE
51399
51400C...Check that they have common number of x bins. Fix format.
51401 nx=nint(bin(iss(1)+1))
51402 DO 190 iw=2,nss
51403 IF(nint(bin(iss(iw)+1)).NE.nx) THEN
51404 CALL pyerrm(8,'(PYDUMP:) different number of bins')
51405 RETURN
51406 ENDIF
51407 190 CONTINUE
51408 format='(1P,000E12.4)'
51409 WRITE(FORMAT(5:7),'(I3)') nss+1
51410
51411C...Write histogram contents; first column x values.
51412 DO 200 ix=1,nx
51413 x=bin(iss(1)+2)+(ix-0.5d0)*bin(iss(1)+4)
51414 WRITE(lfn,format) x, (bin(iss(iw)+8+ix),iw=1,nss)
51415 200 CONTINUE
51416
51417 ENDIF
51418
51419C...Formats for output.
51420 5100 FORMAT(i5,5x,a60)
51421 5200 FORMAT(i5,1p,2d12.4)
51422 5300 FORMAT(i12,1p,3d12.4)
51423 5400 FORMAT(1p,5d12.4)
51424
51425 RETURN
51426 END
51427
51428C*********************************************************************
51429
51430C...PYKCUT
51431C...Dummy routine, which the user can replace in order to make cuts on
51432C...the kinematics on the parton level before the matrix elements are
51433C...evaluated and the event is generated. The cross-section estimates
51434C...will automatically take these cuts into account, so the given
51435C...values are for the allowed phase space region only. MCUT=0 means
51436C...that the event has passed the cuts, MCUT=1 that it has failed.
51437
51438 SUBROUTINE pykcut(MCUT)
51439
51440C...Double precision and integer declarations.
51441 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51442 IMPLICIT INTEGER(I-N)
51443 INTEGER PYK,PYCHGE,PYCOMP
51444C...Commonblocks.
51445 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51446 common/pyint1/mint(400),vint(400)
51447 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
51448 SAVE /pydat1/,/pyint1/,/pyint2/
51449
51450C...Set default value (accepting event) for MCUT.
51451 mcut=0
51452
51453C...Read out subprocess number.
51454 isub=mint(1)
51455 istsb=iset(isub)
51456
51457C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
51458 tau=vint(21)
51459 yst=vint(22)
51460 cth=0d0
51461 IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
51462 taup=0d0
51463 IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
51464
51465C...Calculate x_1, x_2, x_F.
51466 IF(istsb.LE.2.OR.istsb.GE.5) THEN
51467 x1=sqrt(tau)*exp(yst)
51468 x2=sqrt(tau)*exp(-yst)
51469 ELSE
51470 x1=sqrt(taup)*exp(yst)
51471 x2=sqrt(taup)*exp(-yst)
51472 ENDIF
51473 xf=x1-x2
51474
51475C...Calculate shat, that, uhat, p_T^2.
51476 shat=tau*vint(2)
51477 sqm3=vint(63)
51478 sqm4=vint(64)
51479 rm3=sqm3/shat
51480 rm4=sqm4/shat
51481 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
51482 rpts=4d0*vint(71)**2/shat
51483 be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
51484 rm34=2d0*rm3*rm4
51485 rsqm=1d0+rm34
51486 rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
51487 that=-0.5d0*shat*max(rthm,1d0-rm3-rm4-be34*cth)
51488 uhat=-0.5d0*shat*max(rthm,1d0-rm3-rm4+be34*cth)
51489 pt2=max(vint(71)**2,0.25d0*shat*be34**2*(1d0-cth**2))
51490
51491C...Decisions by user to be put here.
51492
51493C...Stop program if this routine is ever called.
51494C...You should not copy these lines to your own routine.
51495 WRITE(mstu(11),5000)
51496 IF(pyr(0).LT.10d0) stop
51497
51498C...Format for error printout.
51499 5000 FORMAT(1x,'Error: you did not link your PYKCUT routine ',
51500 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
51501 &1x,'Execution stopped!')
51502
51503 RETURN
51504 END
51505
51506C*********************************************************************
51507
51508C...PYEVWT
51509C...Dummy routine, which the user can replace in order to multiply the
51510C...standard PYTHIA differential cross-section by a process- and
51511C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
51512C...to generation of weighted events, with weight 1/WTXS, while for
51513C...MSTP(142)=2 it corresponds to a modification of the underlying
51514C...physics.
51515
51516 SUBROUTINE pyevwt(WTXS)
51517
51518C...Double precision and integer declarations.
51519 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51520 IMPLICIT INTEGER(I-N)
51521 INTEGER PYK,PYCHGE,PYCOMP
51522C...Commonblocks.
51523 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51524 common/pyint1/mint(400),vint(400)
51525 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
51526 SAVE /pydat1/,/pyint1/,/pyint2/
51527
51528C...Set default weight for WTXS.
51529 wtxs=1d0
51530
51531C...Read out subprocess number.
51532 isub=mint(1)
51533 istsb=iset(isub)
51534
51535C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
51536 tau=vint(21)
51537 yst=vint(22)
51538 cth=0d0
51539 IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
51540 taup=0d0
51541 IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
51542
51543C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
51544 x1=vint(41)
51545 x2=vint(42)
51546 xf=x1-x2
51547 shat=vint(44)
51548 that=vint(45)
51549 uhat=vint(46)
51550 pt2=vint(48)
51551
51552C...Modifications by user to be put here.
51553
51554C...Stop program if this routine is ever called.
51555C...You should not copy these lines to your own routine.
51556 WRITE(mstu(11),5000)
51557 IF(pyr(0).LT.10d0) stop
51558
51559C...Format for error printout.
51560 5000 FORMAT(1x,'Error: you did not link your PYEVWT routine ',
51561 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
51562 &1x,'Execution stopped!')
51563
51564 RETURN
51565 END
51566
51567C*********************************************************************
51568
51569C...PYUPIN
51570C...Dummy copy of routine to be called by user to set up a user-defined
51571C...process.
51572
51573 SUBROUTINE pyupin(ISUB,TITLE,SIGMAX)
51574
51575C...Double precision and integer declarations.
51576 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51577 IMPLICIT INTEGER(I-N)
51578 INTEGER PYK,PYCHGE,PYCOMP
51579C...Commonblocks.
51580 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51581 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
51582 common/pyint6/proc(0:500)
51583 CHARACTER PROC*28
51584 SAVE /pydat1/,/pyint2/,/pyint6/
51585C...Local character variable.
51586 CHARACTER*(*) TITLE
51587
51588C...Check that subprocess number free.
51589 IF(isub.LT.1.OR.isub.GT.500.OR.iset(isub).GE.0) THEN
51590 WRITE(mstu(11),5000) isub
51591 stop
51592 ENDIF
51593
51594C...Fill information on new process.
51595 iset(isub)=11
51596 coef(isub,1)=sigmax
51597 proc(isub)=title//' '
51598
51599C...Format for error output.
51600 5000 FORMAT(1x,'Error: user-defined subprocess code ',i4,
51601 &' not allowed.'//1x,'Execution stopped!')
51602
51603 RETURN
51604 END
51605
51606C*********************************************************************
51607
51608C...PYUPEV
51609C...Dummy routine, to be replaced by user. When called from PYTHIA
51610C...the subprocess number ISUB will be given, and PYUPEV is supposed
51611C...to generate an event of this type, to be stored in the PYUPPR
51612C...commonblock. SIGEV gives the differential cross-section associated
51613C...with the event, i.e. the acceptance probability of the event is
51614C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
51615C...call.
51616
51617 SUBROUTINE pyupev(ISUB,SIGEV)
51618
51619C...Double precision and integer declarations.
51620 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51621 IMPLICIT INTEGER(I-N)
51622 INTEGER PYK,PYCHGE,PYCOMP
51623C...Commonblocks.
51624 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51625 common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
51626 SAVE /pydat1/,/pyuppr/
51627
51628C...Stop program if this routine is ever called.
51629C...You should not copy these lines to your own routine.
51630 WRITE(mstu(11),5000)
51631 IF(pyr(0).LT.10d0) stop
51632 sigev=isub
51633
51634C...Format for error printout.
51635 5000 FORMAT(1x,'Error: you did not link your PYUPEV routine ',
51636 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
51637 &1x,'Execution stopped!')
51638
51639 RETURN
51640 END
51641
51642C*********************************************************************
51643
51644C...PDFSET
51645C...Dummy routine, to be removed when PDFLIB is to be linked.
51646
51647 SUBROUTINE pdfset(PARM,VALUE)
51648
51649C...Double precision and integer declarations.
51650 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51651 IMPLICIT INTEGER(I-N)
51652 INTEGER PYK,PYCHGE,PYCOMP
51653C...Commonblocks.
51654 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51655 SAVE /pydat1/
51656C...Local arrays and character variables.
51657 CHARACTER*20 PARM(20)
51658 DOUBLE PRECISION VALUE(20)
51659
51660C...Stop program if this routine is ever called.
51661 WRITE(mstu(11),5000)
51662 IF(pyr(0).LT.10d0) stop
51663 parm(20)=parm(1)
51664 value(20)=value(1)
51665
51666C...Format for error printout.
51667 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
51668 &1x,'Dummy routine PDFSET in PYTHIA file called instead.'/
51669 &1x,'Execution stopped!')
51670
51671 RETURN
51672 END
51673
51674C*********************************************************************
51675
51676C...STRUCTM
51677C...Dummy routine, to be removed when PDFLIB is to be linked.
51678
51679 SUBROUTINE structm(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
51680
51681C...Double precision and integer declarations.
51682 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51683 IMPLICIT INTEGER(I-N)
51684 INTEGER PYK,PYCHGE,PYCOMP
51685C...Commonblocks.
51686 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51687 SAVE /pydat1/
51688C...Local variables
51689 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
51690
51691C...Stop program if this routine is ever called.
51692 WRITE(mstu(11),5000)
51693 IF(pyr(0).LT.10d0) stop
51694 upv=xx+qq
51695 dnv=xx+2d0*qq
51696 usea=xx+3d0*qq
51697 dsea=xx+4d0*qq
51698 str=xx+5d0*qq
51699 chm=xx+6d0*qq
51700 bot=xx+7d0*qq
51701 top=xx+8d0*qq
51702 glu=xx+9d0*qq
51703
51704C...Format for error printout.
51705 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
51706 &1x,'Dummy routine STRUCTM in PYTHIA file called instead.'/
51707 &1x,'Execution stopped!')
51708
51709 RETURN
51710 END
51711
51712C*********************************************************************
51713
51714C...STRUCTP
51715C...Dummy routine, to be removed when PDFLIB is to be linked.
51716
51717 SUBROUTINE structp(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
51718 &BOT,TOP,GLU)
51719
51720C...Double precision and integer declarations.
51721 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51722 IMPLICIT INTEGER(I-N)
51723 INTEGER PYK,PYCHGE,PYCOMP
51724C...Commonblocks.
51725 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51726 SAVE /pydat1/
51727C...Local variables
51728 DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
51729 &top,glu
51730
51731C...Stop program if this routine is ever called.
51732 WRITE(mstu(11),5000)
51733 IF(pyr(0).LT.10d0) stop
51734 upv=xx+qq2
51735 dnv=xx+2d0*qq2
51736 usea=xx+3d0*qq2
51737 dsea=xx+4d0*qq2
51738 str=xx+5d0*qq2
51739 chm=xx+6d0*qq2
51740 bot=xx+7d0*qq2
51741 top=xx+8d0*qq2
51742 glu=xx+9d0*qq2
51743
51744C...Format for error printout.
51745 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
51746 &1x,'Dummy routine STRUCTP in PYTHIA file called instead.'/
51747 &1x,'Execution stopped!')
51748
51749 RETURN
51750 END
51751
51752C*********************************************************************
51753
51754C...PYTAUD
51755C...Dummy routine, to be replaced by user, to handle the decay of a
51756C...polarized tau lepton.
51757C...Input:
51758C...ITAU is the position where the decaying tau is stored in /PYJETS/.
51759C...IORIG is the position where the mother of the tau is stored;
51760C... is 0 when the mother is not stored.
51761C...KFORIG is the flavour of the mother of the tau;
51762C... is 0 when the mother is not known.
51763C...Note that IORIG=0 does not necessarily imply KFORIG=0;
51764C... e.g. in B hadron semileptonic decays the W propagator
51765C... is not explicitly stored but the W code is still unambiguous.
51766C...Output:
51767C...NDECAY is the number of decay products in the current tau decay.
51768C...These decay products should be added to the /PYJETS/ common block,
51769C...in positions N+1 through N+NDECAY. For each product I you must
51770C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
51771C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
51772
51773 SUBROUTINE pytaud(ITAU,IORIG,KFORIG,NDECAY)
51774
51775C...Double precision and integer declarations.
51776 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51777 IMPLICIT INTEGER(I-N)
51778 INTEGER PYK,PYCHGE,PYCOMP
51779C...Commonblocks.
51780 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
51781 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51782 SAVE /pyjets/,/pydat1/
51783
51784C...Stop program if this routine is ever called.
51785C...You should not copy these lines to your own routine.
51786 ndecay=itau+iorig+kforig
51787 WRITE(mstu(11),5000)
51788 IF(pyr(0).LT.10d0) stop
51789
51790C...Format for error printout.
51791 5000 FORMAT(1x,'Error: you did not link your PYTAUD routine ',
51792 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
51793 &1x,'Execution stopped!')
51794
51795 RETURN
51796 END
51797
51798C*********************************************************************
51799
51800C...PYTIME
51801C...Finds current date and time.
51802C...Since this task is not standardized in Fortran 77, the routine
51803C...is dummy, to be replaced by the user. Examples are given for
51804C...the Fortran 90 routine and DEC Fortran 77, and what to do if
51805C...you do not have access to suitable routines.
51806
51807 SUBROUTINE pytime(IDATI)
51808
51809C...Double precision and integer declarations.
51810 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51811 IMPLICIT INTEGER(I-N)
51812 INTEGER PYK,PYCHGE,PYCOMP
51813 CHARACTER*8 ATIME
51814C...Local array.
51815 INTEGER IDATI(6),IDTEMP(3)
51816
51817C...Example 0: if you do not have suitable routines.
51818C DO 100 J=1,6
51819C IDATI(J)=0
51820C 100 CONTINUE
51821
51822C...Example 1: Fortran 90 routine.
51823C INTEGER IVAL(8)
51824C CALL DATE_AND_TIME(VALUES=IVAL)
51825C IDATI(1)=IVAL(1)
51826C IDATI(2)=IVAL(2)
51827C IDATI(3)=IVAL(3)
51828C IDATI(4)=IVAL(5)
51829C IDATI(5)=IVAL(6)
51830C IDATI(6)=IVAL(7)
51831
51832C...Example 2: DEC Fortran 77. AIX.
51833C CALL IDATE(IMON,IDAY,IYEAR)
51834C IF(IYEAR.LT.70) THEN
51835C IDATI(1)=2000+IYEAR
51836C ELSEIF(IYEAR.LT.100) THEN
51837C IDATI(1)=1900+IYEAR
51838C ELSE
51839C IDATI(1)=IYEAR
51840C ENDIF
51841C IDATI(2)=IMON
51842C IDATI(3)=IDAY
51843C CALL ITIME(IHOUR,IMIN,ISEC)
51844C IDATI(4)=IHOUR
51845C IDATI(5)=IMIN
51846C IDATI(6)=ISEC
51847
51848C...Example 3: DEC Fortran, IRIX, IRIX64.
51849C CALL IDATE(IMON,IDAY,IYEAR)
51850C IF(IYEAR.LT.70) THEN
51851C IDATI(1)=2000+IYEAR
51852C ELSEIF(IYEAR.LT.100) THEN
51853C IDATI(1)=1900+IYEAR
51854C ELSE
51855C IDATI(1)=IYEAR
51856C ENDIF
51857C IDATI(2)=IMON
51858C IDATI(3)=IDAY
51859C CALL TIME(ATIME)
51860C IHOUR=0
51861C IMIN=0
51862C ISEC=0
51863C READ(ATIME(1:2),'(I2)') IHOUR
51864C READ(ATIME(4:5),'(I2)') IMIN
51865C READ(ATIME(7:8),'(I2)') ISEC
51866C IDATI(4)=IHOUR
51867C IDATI(5)=IMIN
51868C IDATI(6)=ISEC
51869
51870C...Example 4: GNU LINUX libU77, SunOS.
51871 CALL idate(idtemp)
51872 idati(1)=idtemp(3)
51873 idati(2)=idtemp(2)
51874 idati(3)=idtemp(1)
51875 CALL itime(idtemp)
51876 idati(4)=idtemp(1)
51877 idati(5)=idtemp(2)
51878 idati(6)=idtemp(3)
51879
51880 RETURN
51881 END