C++ Interface to Tauola
pythia6152.f
1 C*********************************************************************
2 C*********************************************************************
3 C* **
4 C* March 1997 **
5 C* **
6 C* The Lund Monte Carlo for Hadronic Processes **
7 C* **
8 C* PYTHIA version 6.1 **
9 C* **
10 C* Torbjorn Sjostrand **
11 C* Department of Theoretical Physics 2 **
12 C* Lund University **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* phone +46 - 46 - 222 48 16 **
15 C* E-mail torbjorn@thep.lu.se **
16 C* **
17 C* SUSY parts by **
18 C* Stephen Mrenna **
19 C* Physics Department, UC Davis **
20 C* One Shields Avenue, Davis, CA 95616, USA **
21 C* phone + 1 - 530 - 752 - 2661 **
22 C* E-mail mrenna@physics.ucdavis.edu **
23 C* **
24 C* Several parts are written by Hans-Uno Bengtsson **
25 C* PYSHOW is written together with Mats Bengtsson **
26 C* advanced popcorn baryon production written by Patrik Eden **
27 C* code for virtual photons mainly written by Christer Friberg **
28 C* code for low-mass strings mainly written by Emanuel Norrbin **
29 C* Bose-Einstein code mainly written by Leif Lonnblad **
30 C* CTEQ parton distributions are by the CTEQ collaboration **
31 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
32 C* SaS photon parton distributions together with Gerhard Schuler **
33 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
34 C* MSSM Higgs mass calculation code by M. Carena, **
35 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
36 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
37 C* **
38 C* The latest program version and documentation is found on WWW **
39 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
40 C* **
41 C* Copyright Torbjorn Sjostrand, Lund 1997 **
42 C* **
43 C*********************************************************************
44 C*********************************************************************
45 C *
46 C List of subprograms in order of appearance, with main purpose *
47 C (S = subroutine, F = function, B = block data) *
48 C *
49 C B PYDATA to contain all default values *
50 C S PYTEST to test the proper functioning of the package *
51 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
52 C *
53 C S PYINIT to administer the initialization procedure *
54 C S PYEVNT to administer the generation of an event *
55 C S PYSTAT to print cross-section and other information *
56 C S PYINRE to initialize treatment of resonances *
57 C S PYINBM to read in beam, target and frame choices *
58 C S PYINKI to initialize kinematics of incoming particles *
59 C S PYINPR to set up the selection of included processes *
60 C S PYXTOT to give total, elastic and diffractive cross-sect. *
61 C S PYMAXI to find differential cross-section maxima *
62 C S PYPILE to select multiplicity of pileup events *
63 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
64 C S PYGAGA to handle lepton -> lepton + gamma branchings *
65 C S PYRAND to select subprocess and kinematics for event *
66 C S PYSCAT to set up kinematics and colour flow of event *
67 C S PYSSPA to simulate initial state spacelike showers *
68 C S PYRESD to perform resonance decays *
69 C S PYMULT to generate multiple interactions *
70 C S PYREMN to add on target remnants *
71 C S PYDIFF to set up kinematics for diffractive events *
72 C S PYDISG to set up kinematics, remnant and showers for DIS *
73 C S PYDOCU to compute cross-sections and handle documentation *
74 C S PYFRAM to perform boosts between different frames *
75 C S PYWIDT to calculate full and partial widths of resonances *
76 C S PYOFSH to calculate partial width into off-shell channels *
77 C S PYRECO to handle colour reconnection in W+W- events *
78 C S PYKLIM to calculate borders of allowed kinematical region *
79 C S PYKMAP to construct value of kinematical variable *
80 C S PYSIGH to calculate differential cross-sections *
81 C S PYPDFU to evaluate parton distributions *
82 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
83 C S PYPDEL to evaluate electron parton distributions *
84 C S PYPDGA to evaluate photon parton distributions (generic) *
85 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
86 C S PYGVMD to evaluate VMD part of photon parton distributions *
87 C S PYGANO to evaluate anomalous part of photon pdf's *
88 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
89 C S PYGDIR to evaluate direct contribution to photon pdf's *
90 C S PYPDPI to evaluate pion parton distributions *
91 C S PYPDPR to evaluate proton parton distributions *
92 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
93 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
94 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
95 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
96 C F PYGRVV auxiliary to the PYGRV* routines *
97 C F PYGRVW auxiliary to the PYGRV* routines *
98 C F PYGRVS auxiliary to the PYGRV* routines *
99 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
100 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
101 C S PYPDPO to evaluate old proton parton distributions *
102 C F PYHFTH to evaluate threshold factor for heavy flavour *
103 C S PYSPLI to find flavours left in hadron when one removed *
104 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
105 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
106 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
107 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
108 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
109 C *
110 C S PYMSIN to initialize the supersymmetry simulation *
111 C S PYAPPS to determine MSSM parameters from SUGRA input *
112 C F PYRNMQ to determine running quark masses *
113 C F PYRNMT to determine running top mass *
114 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
115 C S PYINOM to calculate neutralino/chargino mass eigenstates *
116 C F PYRNM3 to determine running M3, gluino mass *
117 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
118 C S PYHGGM to determine Higgs mass spectrum *
119 C S PYSUBH to determine Higgs masses in the MSSM *
120 C S PYPOLE to determine Higgs masses in the MSSM *
121 C S PYVACU to determine Higgs masses in the MSSM *
122 C S PYRGHM auxiliary to PYVACU *
123 C S PYGFXX auxiliary to PYRGHM *
124 C F PYFINT auxiliary to PYVACU *
125 C F PYFISB auxiliary to PYFINT *
126 C S PYSFDC to calculate sfermion decay partial widths *
127 C S PYGLUI to calculate gluino decay partial widths *
128 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
129 C S PYTBBC to calculate 3-body decay of gluino to chargino *
130 C S PYNJDC to calculate neutralino decay partial widths *
131 C S PYCJDC to calculate chargino decay partial widths *
132 C F PYXXZ5 auxiliary for neutralino 3-body decay *
133 C F PYXXW5 auxiliary for ino charge change 3-body decay *
134 C F PYXXGA auxiliary for ino -> ino + gamma decay *
135 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
136 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
137 C F PYXXZ2 auxiliary for chargino 3-body decay *
138 C S PYHEXT to calculate non-SM Higgs decay partial widths *
139 C F PYH2XX auxiliary for H -> ino + ino decay *
140 C F PYGAUS to perform Gaussian integration *
141 C F PYSIMP to perform Simpson integration *
142 C F PYLAMF to evaluate the lambda kinematics function *
143 C S PYTBDY to perform 3-body decay of gauginos *
144 C S PYTECM to calculate techni_rho/omega masses *
145 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
146 C *
147 C S PY1ENT to fill one entry (= parton or particle) *
148 C S PY2ENT to fill two entries *
149 C S PY3ENT to fill three entries *
150 C S PY4ENT to fill four entries *
151 C S PY2FRM to interface to generic two-fermion generator *
152 C S PY4FRM to interface to generic four-fermion generator *
153 C S PY6FRM to interface to generic six-fermion generator *
154 C S PY4JET to generate a shower from a given 4-parton config *
155 C S PY4JTW to evaluate the weight od a shower history for above *
156 C S PY4JTS to set up the parton configuration for above *
157 C S PYJOIN to connect entries with colour flow information *
158 C S PYGIVE to fill (or query) commonblock variables *
159 C S PYEXEC to administrate fragmentation and decay chain *
160 C S PYPREP to rearrange showered partons along strings *
161 C S PYSTRF to do string fragmentation of jet system *
162 C S PYINDF to do independent fragmentation of one or many jets *
163 C S PYDECY to do the decay of a particle *
164 C S PYDCYK to select parton and hadron flavours in decays *
165 C S PYKFDI to select parton and hadron flavours in fragm *
166 C S PYNMES to select number of popcorn mesons *
167 C S PYKFIN to calculate falvour prod. ratios from input params. *
168 C S PYPTDI to select transverse momenta in fragm *
169 C S PYZDIS to select longitudinal scaling variable in fragm *
170 C S PYSHOW to do timelike parton shower evolution *
171 C S PYBOEI to include Bose-Einstein effects (crudely) *
172 C S PYBESQ auxiliary to PYBOEI *
173 C F PYMASS to give the mass of a particle or parton *
174 C F PYMRUN to give the running MSbar mass of a quark *
175 C S PYNAME to give the name of a particle or parton *
176 C F PYCHGE to give three times the electric charge *
177 C F PYCOMP to compress standard KF flavour code to internal KC *
178 C S PYERRM to write error messages and abort faulty run *
179 C F PYALEM to give the alpha_electromagnetic value *
180 C F PYALPS to give the alpha_strong value *
181 C F PYANGL to give the angle from known x and y components *
182 C F PYR to provide a random number generator *
183 C S PYRGET to save the state of the random number generator *
184 C S PYRSET to set the state of the random number generator *
185 C S PYROBO to rotate and/or boost an event *
186 C S PYEDIT to remove unwanted entries from record *
187 C S PYLIST to list event record or particle data *
188 C S PYLOGO to write a logo *
189 C S PYUPDA to update particle data *
190 C F PYK to provide integer-valued event information *
191 C F PYP to provide real-valued event information *
192 C S PYSPHE to perform sphericity analysis *
193 C S PYTHRU to perform thrust analysis *
194 C S PYCLUS to perform three-dimensional cluster analysis *
195 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
196 C S PYJMAS to give high and low jet mass of event *
197 C S PYFOWO to give Fox-Wolfram moments *
198 C S PYTABU to analyze events, with tabular output *
199 C *
200 C S PYEEVT to administrate the generation of an e+e- event *
201 C S PYXTEE to give the total cross-section at given CM energy *
202 C S PYRADK to generate initial state photon radiation *
203 C S PYXKFL to select flavour of primary qqbar pair *
204 C S PYXJET to select (matrix element) jet multiplicity *
205 C S PYX3JT to select kinematics of three-jet event *
206 C S PYX4JT to select kinematics of four-jet event *
207 C S PYXDIF to select angular orientation of event *
208 C S PYONIA to perform generation of onium decay to gluons *
209 C *
210 C S PYBOOK to book a histogram *
211 C S PYFILL to fill an entry in a histogram *
212 C S PYFACT to multiply histogram contents by a factor *
213 C S PYOPER to perform operations between histograms *
214 C S PYHIST to print and reset all histograms *
215 C S PYPLOT to print a single histogram *
216 C S PYNULL to reset contents of a single histogram *
217 C S PYDUMP to dump histogram contents onto a file *
218 C *
219 C S PYKCUT dummy routine for user kinematical cuts *
220 C S PYEVWT dummy routine for weighting events *
221 C S PYUPIN dummy routine to initialize a user process *
222 C S PYUPEV dummy routine to generate a user process event *
223 C S PDFSET dummy routine to be removed when using PDFLIB *
224 C S STRUCTM dummy routine to be removed when using PDFLIB *
225 C S STRUCTP dummy routine to be removed when using PDFLIB *
226 C S PYTAUD dummy routine for interface to tau decay libraries *
227 C S PYTIME dummy routine for giving date and time *
228 C *
229 C*********************************************************************
230 
231 C...PYDATA
232 C...Default values for switches and parameters,
233 C...and particle, decay and process data.
234 
235  BLOCK DATA pydata
236 
237 C...Double precision and integer declarations.
238  IMPLICIT DOUBLE PRECISION(a-h, o-z)
239  IMPLICIT INTEGER(I-N)
240  INTEGER PYK,PYCHGE,PYCOMP
241 C...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 
266 C...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 
340 C...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 
480 C...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 
1078 C...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 
1169 C...PYDATR, with initial values for the random number generator.
1170  DATA mrpy/19780503,0,0,97,33,0/
1171 
1172 C...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 
1197 C...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 
1250 C...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 
1409 C...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 
1413 C...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 
1607 C...Cross sections and slope offsets.
1608  DATA sigt/294*0d0/
1609 
1610 C...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 
1620 C...Data for histogramming routines.
1621  DATA ihist/1000,20000,55,1/
1622  DATA indx/1000*0/
1623 
1624  END
1625 
1626 C*********************************************************************
1627 
1628 C...PYTEST
1629 C...A simple program (disguised as subroutine) to run at installation
1630 C...as a check that the program works as intended.
1631 
1632  SUBROUTINE pytest(MTEST)
1633 
1634 C...Double precision and integer declarations.
1635  IMPLICIT DOUBLE PRECISION(a-h, o-z)
1636  IMPLICIT INTEGER(I-N)
1637  INTEGER PYK,PYCHGE,PYCOMP
1638 C...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/
1646 C...Local arrays.
1647  dimension psum(5),pini(6),pfin(6)
1648 
1649 C...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 
1666 C...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 
1671 C...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 
1688 C...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 
1699 C...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 
1712 C...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 
1724 C...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 
1748 C...Fifty e+e- continuum events with matrix elements.
1749  ELSEIF(iev.LE.350) THEN
1750  mstj(101)=2
1751  CALL pyeevt(0,40d0)
1752 
1753 C...Fifty e+e- continuum event with varying shower options.
1754  ELSEIF(iev.LE.400) THEN
1755  mstj(42)=1+mod(iev,2)
1756  mstj(43)=1+mod(iev/2,4)
1757  mstj(44)=mod(iev/8,3)
1758  CALL pyeevt(0,90d0)
1759 
1760 C...Fifty e+e- continuum events with coherent shower.
1761  ELSEIF(iev.LE.450) THEN
1762  CALL pyeevt(0,500d0)
1763 
1764 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1765  ELSE
1766  CALL pyonia(5,9.46d0)
1767  ENDIF
1768 
1769 C...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 
1780 C...Check conservation of energy, momentum and charge;
1781 C...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 
1798 C...Check that all KF codes are known ones, and that partons/particles
1799 C...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 
1815 C...List all erroneous events and some normal ones.
1816  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
1817  IF(merr.GE.1) WRITE(mstu(11),6400)
1818  CALL pylist(2)
1819  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
1820  CALL pylist(1)
1821  ENDIF
1822 
1823 C...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 
1832 C...Summarize result of run.
1833  IF(mtest.GE.1) CALL pytabu(22)
1834 
1835 C...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 
1852 C...Second part: complete events of various kinds.
1853 C...Common initial values. Loop over initiating conditions.
1854  mstp(122)=max(0,min(2,mtest))
1855  mdcy(pycomp(111),1)=0
1856  DO 230 iproc=1,8
1857 
1858 C...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 
1875 C...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 
1884 C...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 
1893 C...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 
1905 C...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 
1920 C...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 
1935 C...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 
1947 C...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 
1957 C...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 
1974 C...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 
1980 C...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 
1999 C...Check that all KF codes are known ones, and that partons/particles
2000 C...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 
2016 C...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 
2029 C...List statistics for each process type.
2030  IF(mtest.GE.1) CALL pystat(1)
2031  230 CONTINUE
2032 
2033 C...Summarize result of run.
2034  IF(nerr.EQ.0) WRITE(mstu(11),6500)
2035  IF(nerr.GT.0) WRITE(mstu(11),6600) nerr
2036 
2037 C...Format statements for output.
2038  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2039  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
2040  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
2041  &4(1x,f12.5),1x,f8.2)
2042  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
2043  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
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 
2055 C*********************************************************************
2056 
2057 C...PYHEPC
2058 C...Converts PYTHIA event record contents to or from
2059 C...the standard event record commonblock.
2060 
2061  SUBROUTINE pyhepc(MCONV)
2062 
2063 C...Double precision and integer declarations.
2064  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2065  IMPLICIT INTEGER(I-N)
2066  INTEGER PYK,PYCHGE,PYCOMP
2067 C...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/
2072 C...HEPEVT commonblock.
2073  parameter(nmxhep=4000)
2074  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
2075  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
2076  DOUBLE PRECISION PHEP,VHEP
2077  SAVE /hepevt/
2078 
2079 C...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 
2108 C...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 
2115 C...Fill in missing mother information.
2116  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
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 
2141 C...Fill in missing daughter information.
2142  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
2143  DO 130 i1=jdahep(1,i),jdahep(2,i)
2144  i2=mod(k(i1,4)/mstu(5),mstu(5))
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 
2163 C...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 
2192 C...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 
2212 C*********************************************************************
2213 
2214 C...PYINIT
2215 C...Initializes the generation procedure; finds maxima of the
2216 C...differential cross-sections to be used for weighting.
2217 
2218  SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
2219 
2220 C...Double precision and integer declarations.
2221  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2222  IMPLICIT INTEGER(I-N)
2223  INTEGER PYK,PYCHGE,PYCOMP
2224 C...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/
2237 C...Local arrays and character variables.
2238  dimension alamin(20),nfin(20)
2239  CHARACTER*(*) FRAME,BEAM,TARGET
2240  CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2241 
2242 C...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 
2249 C...Data:Lambda and n_f values for parton distributions..
2250  DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,
2251  &0.192d0,0.326d0,2*0.2d0,0.2d0,0.2d0,0.29d0,0.2d0,0.4d0,5*0.2d0/,
2252  &nfin/20*4/
2253  DATA chlh/'lepton','hadron'/
2254 
2255 C...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 
2263 C...Maximum 4 generations; set maximum number of allowed flavours.
2264  mstp(1)=min(4,mstp(1))
2265  mstu(114)=min(mstu(114),2*mstp(1))
2266  mstp(58)=min(mstp(58),2*mstp(1))
2267 
2268 C...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 
2286 C...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 
2300 C...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 
2320 C...Initialize the SUSY generation: couplings, masses,
2321 C...decay modes, branching ratios, and so on.
2322  CALL pymsin
2323 
2324 C...Initialize widths and partial widths for resonances.
2325  CALL pyinre
2326 C...Set Z0 mass and width for e+e- routines.
2327  parj(123)=pmas(23,1)
2328  parj(124)=pmas(23,2)
2329 
2330 C...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 
2337 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2338 C...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 
2378 C...Set up kinematics of process.
2379  CALL pyinki(0)
2380 
2381 C...Set up kinematics for photons inside leptons.
2382  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(1,wtgaga)
2383 
2384 C...Precalculate flavour selection weights.
2385  CALL pykfin
2386 
2387 C...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 
2394 C...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 
2401 C...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 
2428 C...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 
2436 C...Find parametrized total cross-sections.
2437  CALL pyxtot
2438  vint(318)=vint(317)
2439 
2440 C...Maxima of differential cross-sections.
2441  IF(mstp(121).LE.1) CALL pymaxi
2442 
2443 C...Initialize possibility of pileup events.
2444  IF(mint(121).GT.1) mstp(131)=0
2445  IF(mstp(131).NE.0) CALL pypile(1)
2446 
2447 C...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 
2451 C...Save results for gamma-p and gamma-gamma alternatives.
2452  IF(mint(121).GT.1) CALL pysave(1,iga)
2453  160 CONTINUE
2454 
2455 C...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 
2462 C...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 
2479 C*********************************************************************
2480 
2481 C...PYEVNT
2482 C...Administers the generation of a high-pT event via calls to
2483 C...a number of subroutines.
2484 
2485  SUBROUTINE pyevnt
2486 
2487 C...Double precision and integer declarations.
2488  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2489  IMPLICIT INTEGER(I-N)
2490  INTEGER PYK,PYCHGE,PYCOMP
2491 C...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/
2503 C...Local array.
2504  dimension vtx(4)
2505 
2506 C...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 
2517 C...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 
2529 C...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 
2544 C...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
2562 C...Hard scattering (including low-pT):
2563 C...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 
2573 C...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 
2580 C...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 
2601 C...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 
2607 C...Multiple interactions.
2608  IF(mstp(81).GE.1.AND.mint(50).EQ.1) CALL pymult(6)
2609  mint(53)=n
2610 
2611 C...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
2617 C...Diffractive and elastic scattering.
2618  CALL pydiff
2619 
2620  ELSE
2621 C...DIS scattering (photon flux external).
2622  CALL pydisg
2623  IF(mint(51).EQ.1) GOTO 100
2624  ENDIF
2625 
2626 C...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 
2640 C...Boost hadronic subsystem to overall rest frame.
2641 C..(Only relevant when photon inside lepton beam.)
2642  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
2643 
2644 C...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 
2653 C...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 
2692 C...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 
2703 C...Go back to lab frame (needed for vertices, also in fragmentation).
2704  CALL pyfram(1)
2705 
2706 C...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 
2719 C...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 
2732 C...Store event information and calculate Monte Carlo estimates of
2733 C...subprocess cross-sections.
2734  250 IF(ipile.EQ.1) CALL pydocu
2735 
2736 C...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 
2748 C...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 
2757 C...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 
2765 C***********************************************************************
2766 
2767 C...PYSTAT
2768 C...Prints out information about cross-sections, decay widths, branching
2769 C...ratios, kinematical limits, status codes and parameter values.
2770 
2771  SUBROUTINE pystat(MSTAT)
2772 
2773 C...Double precision and integer declarations.
2774  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2775  IMPLICIT INTEGER(I-N)
2776  INTEGER PYK,PYCHGE,PYCOMP
2777 C...Parameter statement to help give large particle numbers.
2778  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
2779 C...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/
2794 C...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 
2830 C...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 
2869 C...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
2888 C...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
2915 C...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 
2951 C...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 
2970 C...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 
2990 C...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 
2999 C...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 
3010 C...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 
3078 C*********************************************************************
3079 
3080 C...PYINRE
3081 C...Calculates full and effective widths of gauge bosons, stores
3082 C...masses and widths, rescales coefficients to be used for
3083 C...resonance production generation.
3084 
3085  SUBROUTINE pyinre
3086 
3087 C...Double precision and integer declarations.
3088  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3089  IMPLICIT INTEGER(I-N)
3090  INTEGER PYK,PYCHGE,PYCOMP
3091 C...Parameter statement to help give large particle numbers.
3092  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
3093 C...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/
3109 C...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 
3113 C...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 
3167 C...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 
3174 C...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 
3198 C...Loop over possible resonances.
3199  DO 180 i=1,nres
3200  kc=kcord(i)
3201  kf=kchg(kc,4)
3202 
3203 C...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 
3215 C...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 
3226 C...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 
3233 C...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 
3260 C...Set resonance widths and branching ratios;
3261 C...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 
3274 C...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 
3286 C...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 
3307 C...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 
3324 C...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 
3333 C...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 
3340 C*********************************************************************
3341 
3342 C...PYINBM
3343 C...Identifies the two incoming particles and the choice of frame.
3344 
3345  SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)
3346 
3347 C...Double precision and integer declarations.
3348  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3349  IMPLICIT INTEGER(I-N)
3350  INTEGER PYK,PYCHGE,PYCOMP
3351 C...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/
3359 C...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 
3378 C...Store initial energy. Default frame.
3379  vint(290)=win
3380  mint(111)=0
3381 
3382 C...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 
3397 C...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 
3425 C...Identify free initialization.
3426  IF(chcom(1)(1:2).EQ.'no') THEN
3427  mint(65)=1
3428  RETURN
3429  ENDIF
3430 
3431 C...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 
3452 C...Identify choice of frame and input energies.
3453  chinit=' '
3454 
3455 C...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 
3475 C...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 
3489 C...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 
3510 C...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 
3531 C...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 
3548 C...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 
3558 C...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 
3580 C*********************************************************************
3581 
3582 C...PYINKI
3583 C...Sets up kinematics, including rotations and boosts to/from CM frame.
3584 
3585  SUBROUTINE pyinki(MODKI)
3586 
3587 C...Double precision and integer declarations.
3588  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3589  IMPLICIT INTEGER(I-N)
3590  INTEGER PYK,PYCHGE,PYCOMP
3591 C...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 
3600 C...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 
3608 C...Reset boost. Do kinematics for various cases.
3609  DO 110 j=6,10
3610  vint(j)=0d0
3611  110 CONTINUE
3612 
3613 C...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 
3632 C...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 
3652 C...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 
3670 C...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 
3686 C...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 
3699 C...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 
3710 C...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 
3736 C...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 
3749 C*********************************************************************
3750 
3751 C...PYINPR
3752 C...Selects partonic subprocesses to be included in the simulation.
3753 
3754  SUBROUTINE pyinpr
3755 
3756 C...Double precision and integer declarations.
3757  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3758  IMPLICIT INTEGER(I-N)
3759  INTEGER PYK,PYCHGE,PYCOMP
3760 C...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 
3769 C...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 
3776 C...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 
3783 C...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 
3787 C...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 
3792 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
3793 C...allow mixture.
3794 C...Here also set a few parameters otherwise normally not touched.
3795  ELSEIF(mint(121).GT.1) THEN
3796 
3797 C...Parton distributions dampened at small Q2; go to low energies,
3798 C...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 
3807 C...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 
3819 C...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 
3823 C...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 
3841 C...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 
3851 C...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 
3870 C...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 
3876 C...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 
3888 C...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 
3897 C...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 
3916 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
3917  ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
3918 
3919 C...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 
3931 C...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 
3940 C...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 
3949 C...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 
3967 C...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 
3985 C...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 
4003 C...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 
4008 C...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 
4014 C...Set up for gamma* * p; virtual photons = dir, res.
4015  ELSEIF(mint(121).EQ.2) THEN
4016 
4017 C...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 
4026 C...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 
4045 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4046  ELSEIF(mint(121).EQ.4) THEN
4047 
4048 C...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 
4060 C...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 
4069 C...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 
4088 C...End of special set up for gamma-p and gamma-gamma.
4089  ENDIF
4090  ckin(1)=2d0*ckin(3)
4091  ENDIF
4092 
4093 C...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 
4104 C...If two real gammas, whereof one direct, pick the first.
4105 C...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 
4147 C...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 
4216 C...Select default processes according to incoming beams
4217 C...(already done for gamma-p and gamma-gamma with
4218 C...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
4223 C...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
4229 C...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
4235 C...DIS as pure gamma* + f -> f process.
4236  msub(99)=1
4237 
4238  ELSEIF(mint(43).LE.3) THEN
4239 C...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
4244 C...Two unresolved photons: fermion pair production,
4245 C...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
4260 C...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
4266 C...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
4279 C...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
4294 C...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
4309 C...Prompt photon production:
4310  msub(14)=1
4311  msub(18)=1
4312  msub(29)=1
4313 
4314  ELSEIF(msel.EQ.11) THEN
4315 C...Z0/gamma* production:
4316  msub(1)=1
4317 
4318  ELSEIF(msel.EQ.12) THEN
4319 C...W+/- production:
4320  msub(2)=1
4321 
4322  ELSEIF(msel.EQ.13) THEN
4323 C...Z0 + jet:
4324  msub(15)=1
4325  msub(30)=1
4326 
4327  ELSEIF(msel.EQ.14) THEN
4328 C...W+/- + jet:
4329  msub(16)=1
4330  msub(31)=1
4331 
4332  ELSEIF(msel.EQ.15) THEN
4333 C...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
4341 C...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
4349 C...h0 & Z0 or W+/- pair production:
4350  msub(24)=1
4351  msub(26)=1
4352 
4353  ELSEIF(msel.EQ.18) THEN
4354 C...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
4361 C...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
4376 C...Z'0 production:
4377  msub(141)=1
4378 
4379  ELSEIF(msel.EQ.22) THEN
4380 C...W'+/- production:
4381  msub(142)=1
4382 
4383  ELSEIF(msel.EQ.23) THEN
4384 C...H+/- production:
4385  msub(143)=1
4386 
4387  ELSEIF(msel.EQ.24) THEN
4388 C...R production:
4389  msub(144)=1
4390 
4391  ELSEIF(msel.EQ.25) THEN
4392 C...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
4399 C...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 
4406 CMRENNA++Define SUSY alternatives.
4407  ELSEIF(msel.EQ.39) THEN
4408 C...Turn on all SUSY processes.
4409  IF(mint(43).EQ.4) THEN
4410 C...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
4415 C...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
4433 C...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
4452 C...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
4462 C...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
4473 C...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
4484 C...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
4496 C...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 
4517 C...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 
4535 C...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 
4551 C*********************************************************************
4552 
4553 C...PYXTOT
4554 C...Parametrizes total, elastic and diffractive cross-sections
4555 C...for different energies and beams. Donnachie-Landshoff for
4556 C...total and Schuler-Sjostrand for elastic and diffractive.
4557 C...Process code IPROC:
4558 C...= 1 : p + p;
4559 C...= 2 : pbar + p;
4560 C...= 3 : pi+ + p;
4561 C...= 4 : pi- + p;
4562 C...= 5 : pi0 + p;
4563 C...= 6 : phi + p;
4564 C...= 7 : J/psi + p;
4565 C...= 11 : rho + rho;
4566 C...= 12 : rho + phi;
4567 C...= 13 : rho + J/psi;
4568 C...= 14 : phi + phi;
4569 C...= 15 : phi + J/psi;
4570 C...= 16 : J/psi + J/psi;
4571 C...= 21 : gamma + p (DL);
4572 C...= 22 : gamma + p (VDM).
4573 C...= 23 : gamma + pi (DL);
4574 C...= 24 : gamma + pi (VDM);
4575 C...= 25 : gamma + gamma (DL);
4576 C...= 26 : gamma + gamma (VDM).
4577 
4578  SUBROUTINE pyxtot
4579 
4580 C...Double precision and integer declarations.
4581  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4582  IMPLICIT INTEGER(I-N)
4583  INTEGER PYK,PYCHGE,PYCOMP
4584 C...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/
4592 C...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 
4597 C...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 
4602 C...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/
4604 C...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 
4613 C...Beam and target hadron class:
4614 C...= 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/
4617 C...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 
4622 C...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 
4653 C...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 
4662 C...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 
4668 C...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 
4680 C...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 
4701 C... 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 
4716 C...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 
4721 C...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 
4730 C...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 
4741 C...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 
4751 C...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 
4757 C...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 
4762 C...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 
4773 C...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 
4784 C...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 
4791 C...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 
4811 C...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 
4816 C...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 
4822 C...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 
4851 C...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 
4880 C...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 
4941 C...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 
4956 C*********************************************************************
4957 
4958 C...PYMAXI
4959 C...Finds optimal set of coefficients for kinematical variable selection
4960 C...and the maximum of the part of the differential cross-section used
4961 C...in the event weighting.
4962 
4963  SUBROUTINE pymaxi
4964 
4965 C...Double precision and integer declarations.
4966  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4967  IMPLICIT INTEGER(I-N)
4968  INTEGER PYK,PYCHGE,PYCOMP
4969 C...Parameter statement to help give large particle numbers.
4970  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
4971 C...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/
4987 C...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 
4995 C...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 
5004 C...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 
5009 C...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 
5054 C...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 
5135 C...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
5152 C...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 
5198 C...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 
5211 C...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 
5233 C...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 
5249 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5250 C...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
5261 C...Special case when both resonances have same mass,
5262 C...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 
5302 C...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 
5315 C...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 
5323 C..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 
5338 C...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 
5355 C...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 
5376 C...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 
5396 C...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 
5416 C...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 
5433 C...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 
5464 C...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 
5490 C...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 
5502 C...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 
5528 C...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 
5538 C...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 
5570 C...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 
5617 C...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 
5631 C...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 
5652 C...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 
5690 C...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 
5722 C...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 
5763 C...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 
5783 C...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 
5811 C*********************************************************************
5812 
5813 C...PYPILE
5814 C...Initializes multiplicity distribution and selects mutliplicity
5815 C...of pileup events, i.e. several events occuring at the same
5816 C...beam crossing.
5817 
5818  SUBROUTINE pypile(MPILE)
5819 
5820 C...Double precision and integer declarations.
5821  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5822  IMPLICIT INTEGER(I-N)
5823  INTEGER PYK,PYCHGE,PYCOMP
5824 C...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/
5830 C...Local arrays and saved variables.
5831  dimension wti(0:200)
5832  SAVE imin,imax,wti,wts
5833 
5834 C...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 
5842 C...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 
5850 C...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 
5861 C...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 
5878 C...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 
5893 C...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 
5900 C*********************************************************************
5901 
5902 C...PYSAVE
5903 C...Saves and restores parameter and cross section values for the
5904 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alnternatives.
5905 C...Also makes random choice between alternatives.
5906 
5907  SUBROUTINE pysave(ISAVE,IGA)
5908 
5909 C...Double precision and integer declarations.
5910  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5911  IMPLICIT INTEGER(I-N)
5912  INTEGER PYK,PYCHGE,PYCOMP
5913 C...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/
5921 C...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 
5927 C...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 
5956 C...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 
5968 C...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 
5982 C...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 
5998 C...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 
6025 C...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 
6038 C...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 
6068 C*********************************************************************
6069 
6070 C...PYGAGA
6071 C...For lepton beams it gives photon-hadron or photon-photon systems
6072 C...to be treated with the ordinary machinery and combines this with a
6073 C...description of the lepton -> lepton + photon branching.
6074 
6075  SUBROUTINE pygaga(IGAGA,WTGAGA)
6076 
6077 C...Double precision and integer declarations.
6078  IMPLICIT DOUBLE PRECISION(a-h, o-z)
6079  IMPLICIT INTEGER(I-N)
6080  INTEGER PYK,PYCHGE,PYCOMP
6081 C...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/
6091 C...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 
6097 C...Initialize generation of photons inside leptons.
6098  IF(igaga.EQ.1) THEN
6099 
6100 C...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 
6110 C...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))
6132 C...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 
6141 C...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 
6158 C...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 
6164 C...W value for photon on one or both sides, and for processes
6165 C...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 
6179 C...Upper estimate of photon flux weight factor.
6180 C...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 
6209 C...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 
6220 C...Generate photons inside leptons and
6221 C...calculate photon flux weight factors.
6222  ELSEIF(igaga.EQ.3) THEN
6223  isub=mint(1)
6224  mint(15)=0
6225  mint(16)=0
6226 
6227 C...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
6232 C...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)
6235 C...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
6239 C...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 
6249 C...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 
6254 C...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 
6270 C...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 
6290 C...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 
6304 C...Assign weight for photon flux; different for transverse and
6305 C...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 
6333 C...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 
6343 C...Reconstruct kinematics of photons inside leptons.
6344  ELSEIF(igaga.EQ.4) THEN
6345 
6346 C...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 
6370 C...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 
6392 C...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 
6418 C...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 
6433 C...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 
6455 C...Define boost and rotation between hadronic subsystem and
6456 C...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 
6467 C...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 
6486 C*********************************************************************
6487 
6488 C...PYRAND
6489 C...Generates quantities characterizing the high-pT scattering at the
6490 C...parton level according to the matrix elements. Chooses incoming,
6491 C...reacting partons, their momentum fractions and one of the possible
6492 C...subprocesses.
6493 
6494  SUBROUTINE pyrand
6495 
6496 C...Double precision and integer declarations.
6497  IMPLICIT DOUBLE PRECISION(a-h, o-z)
6498  IMPLICIT INTEGER(I-N)
6499  INTEGER PYK,PYCHGE,PYCOMP
6500 C...Parameter statement to help give large particle numbers.
6501  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
6502 C...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/
6518 C...Local arrays.
6519  dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)
6520 
6521 C...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 
6525 C...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 
6541 C...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 
6553 C...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 
6557 C...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 
6562 C...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 
6577 C...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 
6588 C...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 
6600 C...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
6607 C...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 
6613 C...Restrict direct*resolved processes to pTmin >= Q,
6614 C...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 
6624 C...Set up for multiple interactions.
6625  IF(inmult.EQ.1) CALL pymult(2)
6626 
6627 C...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 
6637 C...Random choice of flavour for some SUSY processes.
6638  IF(isub.GE.201.AND.isub.LE.301) THEN
6639 C...~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
6643 C...~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)
6647 C...~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
6659 C...~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))
6676 C...~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)
6683 C...~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 
6707 C...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 
6786 C...Find product masses and minimum pT of process,
6787 C...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
6804 C...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 
6846 C...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 
6859 C...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
6890 C...Elastic scattering or single or double diffractive scattering.
6891 
6892 C...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 
6934 C...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 
6954 C...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 
6960 C...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 
6974 C...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 
6989 C...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 
7000 C...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 
7015 C..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 
7033 C...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 
7048 C...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 
7059 C...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 
7070 C...Note: in the following, by In is meant the integral over the
7071 C...quantity multiplying coefficient cn.
7072 C...Choose tau according to h1(tau)/tau, where
7073 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7074 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7075 C...I1/I5*c5*1/(tau+tau_R') +
7076 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7077 C...I1/I7*c7*tau/(1.-tau), and
7078 C...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 
7102 C...2 -> 3, 4 processes:
7103 C...Choose tau' according to h4(tau,tau')/tau', where
7104 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7105 C...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 
7123 C...Choose y* according to h2(y*), where
7124 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7125 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7126 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7127 C...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 
7146 C...2 -> 2 processes:
7147 C...Choose cos(theta-hat) (cth) according to h3(cth), where
7148 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7149 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7150 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7151 C...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 
7172 C...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 
7185 C...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 
7193 C...Low-pT or multiple interactions (first semihard interaction).
7194  ELSEIF(istsb.EQ.9) THEN
7195  CALL pymult(3)
7196  isub=mint(1)
7197 
7198 C...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 
7214 C...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 
7226 C...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 
7247 C...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 
7265 C...Choose azimuthal angle.
7266  vint(24)=paru(2)*pyr(0)
7267 
7268 C...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 
7293 C...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 
7298 C...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 
7307 C...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 
7327 C...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 
7340 C...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 
7346 C...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 
7365 C...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 
7403 C...Check for possible violation of estimated maximum of differential
7404 C...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 
7444 C...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 
7465 C...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 
7481 C...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 
7493 C...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 
7503 C...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 
7519 C...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 
7562 C...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 
7603 C...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 
7621 C*********************************************************************
7622 
7623 C...PYSCAT
7624 C...Finds outgoing flavours and event type; sets up the kinematics
7625 C...and colour flow of the hard scattering
7626 
7627  SUBROUTINE pyscat
7628 
7629 C...Double precision and integer declarations
7630  IMPLICIT DOUBLE PRECISION(a-h, o-z)
7631  IMPLICIT INTEGER(I-N)
7632  INTEGER PYK,PYCHGE,PYCOMP
7633 C...Parameter statement to help give large particle numbers.
7634  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
7635 C...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/
7652 C...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 
7657 C...Read out process
7658  isub=mint(1)
7659  isubsv=isub
7660 
7661 C...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 
7667 C...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 
7686 C...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 
7701 C...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 
7721 C...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 
7737 C...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 
7749 C...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 
7775 C...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
7785 C...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
7797 C...f + fbar -> gamma*/Z0
7798  kfres=23
7799 
7800  ELSEIF(isub.EQ.2) THEN
7801 C...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
7807 C...f + fbar -> h0 (or H0, or A0)
7808  kfres=kfhigg
7809 
7810  ELSEIF(isub.EQ.4) THEN
7811 C...gamma + W+/- -> W+/-
7812 
7813  ELSEIF(isub.EQ.5) THEN
7814 C...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
7858 C...Z0 + W+/- -> W+/-
7859 
7860  ELSEIF(isub.EQ.7) THEN
7861 C...W+ + W- -> Z0
7862 
7863  ELSEIF(isub.EQ.8) THEN
7864 C...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
7925 C...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
7929 C...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
7955 C...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
7960 C...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
7966 C...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
7972 C...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
7979 C...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
7986 C...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
7995 C...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
8002 C...f + fbar -> gamma + gamma; th arbitrary
8003  mint(21)=22
8004  mint(22)=22
8005 
8006  ELSEIF(isub.EQ.19) THEN
8007 C...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
8013 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8014 C...(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
8024 C...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
8030 C...f + fbar -> Z0 + Z0; th arbitrary
8031  mint(21)=23
8032  mint(22)=23
8033 
8034  ELSEIF(isub.EQ.23) THEN
8035 C...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
8043 C...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
8049 C...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
8054 C...f + fbar' -> W+/- + h0 (or H0, or A0);
8055 C...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
8063 C...f + fbar -> h0 + h0
8064 
8065  ELSEIF(isub.EQ.28) THEN
8066 C...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
8073 C...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
8080 C...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
8089 C...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
8108 C...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
8115 C...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
8122 C...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
8128 C...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
8134 C...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
8157 C...f + gamma -> f + h0
8158 
8159  ELSEIF(isub.EQ.38) THEN
8160 C...f + Z0 -> f + g
8161 
8162  ELSEIF(isub.EQ.39) THEN
8163 C...f + Z0 -> f + gamma
8164 
8165  ELSEIF(isub.EQ.40) THEN
8166 C...f + Z0 -> f + Z0
8167  ENDIF
8168 
8169  ELSEIF(isub.LE.50) THEN
8170  IF(isub.EQ.41) THEN
8171 C...f + Z0 -> f' + W+/-
8172 
8173  ELSEIF(isub.EQ.42) THEN
8174 C...f + Z0 -> f + h0
8175 
8176  ELSEIF(isub.EQ.43) THEN
8177 C...f + W+/- -> f' + g
8178 
8179  ELSEIF(isub.EQ.44) THEN
8180 C...f + W+/- -> f' + gamma
8181 
8182  ELSEIF(isub.EQ.45) THEN
8183 C...f + W+/- -> f' + Z0
8184 
8185  ELSEIF(isub.EQ.46) THEN
8186 C...f + W+/- -> f' + W+/-
8187 
8188  ELSEIF(isub.EQ.47) THEN
8189 C...f + W+/- -> f' + h0
8190 
8191  ELSEIF(isub.EQ.48) THEN
8192 C...f + h0 -> f + g
8193 
8194  ELSEIF(isub.EQ.49) THEN
8195 C...f + h0 -> f + gamma
8196 
8197  ELSEIF(isub.EQ.50) THEN
8198 C...f + h0 -> f + Z0
8199  ENDIF
8200 
8201  ELSEIF(isub.LE.60) THEN
8202  IF(isub.EQ.51) THEN
8203 C...f + h0 -> f' + W+/-
8204 
8205  ELSEIF(isub.EQ.52) THEN
8206 C...f + h0 -> f + h0
8207 
8208  ELSEIF(isub.EQ.53) THEN
8209 C...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
8216 C...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
8224 C...g + Z0 -> f + fbar
8225 
8226  ELSEIF(isub.EQ.56) THEN
8227 C...g + W+/- -> f + fbar'
8228 
8229  ELSEIF(isub.EQ.57) THEN
8230 C...g + h0 -> f + fbar
8231 
8232  ELSEIF(isub.EQ.58) THEN
8233 C...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
8240 C...gamma + Z0 -> f + fbar
8241 
8242  ELSEIF(isub.EQ.60) THEN
8243 C...gamma + W+/- -> f + fbar'
8244  ENDIF
8245 
8246  ELSEIF(isub.LE.70) THEN
8247  IF(isub.EQ.61) THEN
8248 C...gamma + h0 -> f + fbar
8249 
8250  ELSEIF(isub.EQ.62) THEN
8251 C...Z0 + Z0 -> f + fbar
8252 
8253  ELSEIF(isub.EQ.63) THEN
8254 C...Z0 + W+/- -> f + fbar'
8255 
8256  ELSEIF(isub.EQ.64) THEN
8257 C...Z0 + h0 -> f + fbar
8258 
8259  ELSEIF(isub.EQ.65) THEN
8260 C...W+ + W- -> f + fbar
8261 
8262  ELSEIF(isub.EQ.66) THEN
8263 C...W+/- + h0 -> f + fbar'
8264 
8265  ELSEIF(isub.EQ.67) THEN
8266 C...h0 + h0 -> f + fbar
8267 
8268  ELSEIF(isub.EQ.68) THEN
8269 C...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
8274 C...gamma + gamma -> W+ + W-; th arbitrary
8275  mint(21)=24
8276  mint(22)=-24
8277  kcc=21
8278 
8279  ELSEIF(isub.EQ.70) THEN
8280 C...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
8288 C...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
8331 C...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
8393 C...Z0 + h0 -> Z0 + h0
8394 
8395  ELSEIF(isub.EQ.75) THEN
8396 C...W+ + W- -> gamma + gamma
8397 
8398  ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
8399 C...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
8459 C...W+/- + h0 -> W+/- + h0
8460 
8461  ELSEIF(isub.EQ.79) THEN
8462 C...h0 + h0 -> h0 + h0
8463 
8464  ELSEIF(isub.EQ.80) THEN
8465 C...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
8477 C...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
8483 C...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
8490 C...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
8521 C...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
8529 C...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
8536 C...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
8545 C...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
8550 C...Multiple interactions (should be reassigned to QCD process)
8551  ENDIF
8552 
8553  ELSEIF(isub.LE.110) THEN
8554  IF(isub.EQ.101) THEN
8555 C...g + g -> gamma*/Z0
8556  kcc=21
8557  kfres=22
8558 
8559  ELSEIF(isub.EQ.102) THEN
8560 C...g + g -> h0 (or H0, or A0)
8561  kcc=21
8562  kfres=kfhigg
8563 
8564  ELSEIF(isub.EQ.103) THEN
8565 C...gamma + gamma -> h0 (or H0, or A0)
8566  kcc=21
8567  kfres=kfhigg
8568 
8569  ELSEIF(isub.EQ.104.OR.isub.EQ.105) THEN
8570 C...g + g -> chi_0c or chi_2c.
8571  kcc=21
8572  kfres=kfpr(isub,1)
8573 
8574  ELSEIF(isub.EQ.106) THEN
8575 C...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
8581 C...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
8588 C...gamma + gamma -> J/Psi + gamma
8589  mint(21)=kfpr(isub,1)
8590  mint(22)=kfpr(isub,2)
8591 
8592  ELSEIF(isub.EQ.110) THEN
8593 C...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
8601 C...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
8608 C...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
8615 C...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
8622 C...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
8629 C...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
8636 C...g + g -> gamma + Z0
8637 
8638  ELSEIF(isub.EQ.117) THEN
8639 C...g + g -> Z0 + Z0
8640 
8641  ELSEIF(isub.EQ.118) THEN
8642 C...g + g -> W+ + W-
8643  ENDIF
8644 
8645  ELSEIF(isub.LE.140) THEN
8646  IF(isub.EQ.121) THEN
8647 C...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
8655 C...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
8662 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
8663 C...inner process)
8664  kcc=22
8665  kfres=kfhigg
8666 
8667  ELSEIF(isub.EQ.124) THEN
8668 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
8669 C...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
8693 C...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
8700 C...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
8706 C...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
8714 C...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
8724 C...f + fbar -> gamma*/Z0/Z'0
8725  kfres=32
8726 
8727  ELSEIF(isub.EQ.142) THEN
8728 C...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
8734 C...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
8740 C...f + fbar' -> R
8741  kfres=isign(40,mint(15)+mint(16))
8742 
8743  ELSEIF(isub.EQ.145) THEN
8744 C...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
8751 C...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
8757 C...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
8764 C...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
8772 C...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
8783 C...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
8792 C...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
8799 C...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
8805 C...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
8810 C...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
8820 C...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
8830 C...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
8838 C...f + fbar -> rho_tech0.
8839  kfres=54
8840 
8841  ELSEIF(isub.EQ.192) THEN
8842 C...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
8848 C...f + fbar -> omega_tech0.
8849  kfres=56
8850 
8851  ELSEIF(isub.EQ.194) THEN
8852 C...f + fbar -> f' + fbar' via mixture of s-channel
8853 C...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
8858 C...f + fbar' -> f'' + fbar''' via s-channel
8859 C...rho_tech+ th=(p(f)-p(f'))**2
8860 C...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 
8870 CMRENNA++
8871  ELSEIF(isub.LE.215) THEN
8872  IF(isub.EQ.201) THEN
8873 C...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
8878 C...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
8883 C...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
8890 C...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
8895 C...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
8900 C...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
8907 C...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
8912 C...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
8917 C...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
8924 C...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
8931 C...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
8938 C...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
8945 C...f + fbar -> ~nul + ~nulbar
8946  mint(21)=isign(kfpr(isub,1),kcs)
8947  mint(22)=-mint(21)
8948 
8949  ELSEIF(isub.EQ.214) THEN
8950 C...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
8957 C...f + fbar -> ~chi01 + ~chi01
8958  mint(21)=ksusy1+22
8959  mint(22)=ksusy1+22
8960 
8961  ELSEIF(isub.EQ.217) THEN
8962 C...f + fbar -> ~chi02 + ~chi02
8963  mint(21)=ksusy1+23
8964  mint(22)=ksusy1+23
8965 
8966  ELSEIF(isub.EQ.218 ) THEN
8967 C...f + fbar -> ~chi03 + ~chi03
8968  mint(21)=ksusy1+25
8969  mint(22)=ksusy1+25
8970 
8971  ELSEIF(isub.EQ.219 ) THEN
8972 C...f + fbar -> ~chi04 + ~chi04
8973  mint(21)=ksusy1+35
8974  mint(22)=ksusy1+35
8975 
8976  ELSEIF(isub.EQ.220 ) THEN
8977 C...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
8983 C...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
8989 C...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
8995 C...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
9001 C...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
9007 C...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
9015 C...f + fbar -> ~chi+-1 + ~chi-+1
9016 C...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
9022 C...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
9028 C...f + fbar -> ~chi+-1 + ~chi-+2
9029 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9030 C...js=1 if pyr<.5, js=2 if pyr>.5
9031 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9032 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9033 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9034 C...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))
9036 C 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
9049 C...q + qbar' -> ~chi01 + ~chi+-1
9050 C...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))
9053 C...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
9059 C...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
9067 C...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
9075 C...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
9083 C...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
9091 C...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
9099 C...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
9107 C...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
9117 C...q + qbar -> ~chi01 + ~g
9118 C...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
9125 C...q + qbar -> ~chi02 + ~g
9126 C...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
9133 C...q + qbar -> ~chi03 + ~g
9134 C...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
9141 C...q + qbar -> ~chi04 + ~g
9142 C...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
9149 C...q + qbar' -> ~chi+-1 + ~g
9150 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9151 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9152 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9153 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9154 C...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
9164 C...q + qbar' -> ~chi+-2 + ~g
9165 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
9166 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
9167 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
9168 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
9169 C...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
9179 C...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
9185 C...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
9194 C...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
9204 C...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
9214 C...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
9224 C...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
9234 C...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
9244 C...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
9254 C...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
9264 C...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
9274 C...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
9285 C...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
9296 C...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
9307 C...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
9318 C...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
9329 C...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
9342 C...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)
9347 C...Correct color combination
9348  IF(mint(43).EQ.4) kcc=4
9349 
9350  ELSEIF(isub.EQ.262) THEN
9351 C...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)
9356 C...Correct color combination
9357  IF(mint(43).EQ.4) kcc=4
9358 
9359  ELSEIF(isub.EQ.263) THEN
9360 C...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
9370 C...Correct color combination
9371  IF(mint(43).EQ.4) kcc=4
9372 
9373  ELSEIF(isub.EQ.264) THEN
9374 C...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
9381 C...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
9390 C...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
9397 C...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
9404 C...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
9411 C...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
9418 C...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
9425 C...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
9432 C...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
9440 C...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
9448 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
9449 C...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
9456 C...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
9463 C...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
9474 C...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
9488 C...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
9495 C...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
9500 C...f + fbar -> H+ H-
9501  mint(21)=isign(kfpr(isub,1),kcs)
9502  mint(22)=-mint(21)
9503  ENDIF
9504 CMRENNA--
9505 
9506  ELSEIF(isub.LE.360) THEN
9507 
9508  IF(isub.EQ.341.OR.isub.EQ.342) THEN
9509 C...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
9515 C...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
9522 C...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
9527 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
9528 C...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
9556 C...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)
9560 C...f + fbar -> neutral neutral
9561  ELSEIF(isub.LE.367) THEN
9562  mint(21)=kfpr(isub,1)
9563  mint(22)=kfpr(isub,2)
9564 C...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
9571 c MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
9572 c 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
9588 C...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 
9615 C...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 
9635 C...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
9651 C...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 
9666 C...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
9688 C...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 
9724 C...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
9728 C...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
9774 C...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
9823 C...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
9867 C...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)
9880 C...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
9912 C...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 
9926 C...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
9942 C...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 
9958 C...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 
9971 C...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 
9989 C*********************************************************************
9990 
9991 C...PYSSPA
9992 C...Generates spacelike parton showers.
9993 
9994  SUBROUTINE pysspa(IPU1,IPU2)
9995 
9996 C...Double precision and integer declarations.
9997  IMPLICIT DOUBLE PRECISION(a-h, o-z)
9998  IMPLICIT INTEGER(I-N)
9999  INTEGER PYK,PYCHGE,PYCOMP
10000 C...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/
10011 C...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 
10019 C...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 
10030 C...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 
10068 C...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 
10086 C...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 
10096 C...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
10114 C...Special kinematics check for c/b quarks (that g -> c cbar or
10115 C...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 
10127 C...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 
10154 C...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 
10167 C...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
10180 C***Currently kill QED shower for resolved photoproduction.
10181  IF(mint(18+jt).EQ.1) meev=0
10182 C***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 
10193 C...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 
10217 C...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 
10231 C...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
10237 C...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)
10243 C...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)
10251 C...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)
10259 C...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 
10272 C...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 
10290 C...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 
10311 C...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))
10314 C...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 
10340 C...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 
10354 C...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 
10367 C...Choose z value and corrective weight.
10368  wtz=0d0
10369 C...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)
10374 C...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)
10378 C...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)
10388 C...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
10393 C...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))
10399 C...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)
10403 C...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
10407 C...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 
10414 C...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 
10423 C...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 
10432 C...Remove kinematically impossible branchings.
10433  uhat=q2b-dsh*(1d0-z)/z
10434  IF(mstp(68).GE.0.AND.uhat.GT.0d0) GOTO 210
10435 
10436 C...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 
10449 C...Impose angular constraint in first branching from interference
10450 C...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 
10461 C...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 
10468 C...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 
10510 C...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 
10536 C...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 
10555 C...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
10562 C...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
10566 C...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
10574 C...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 
10608 C...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 
10632 C...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 
10645 C...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
10650 C...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)
10655 C...f -> gamma (Z, W) + f.
10656  ELSEIF(iabs(k(is(jt),2)).GE.22) THEN
10657  id1=it
10658  id2=it
10659 C...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
10665 C...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)
10669 C...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
10673 C...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
10677 C...qbar -> g + qbar.
10678  ELSEIF(k(n+1,2).LT.0) THEN
10679  id1=it
10680  id2=is(jt)
10681 C...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 
10699 C...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 
10709 C...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 
10715 C...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 
10740 C...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 
10754 C...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 
10767 C*********************************************************************
10768 
10769 C...PYRESD
10770 C...Allows resonances to decay (including parton showers for hadronic
10771 C...channels).
10772 
10773  SUBROUTINE pyresd(IRES)
10774 
10775 C...Double precision and integer declarations.
10776  IMPLICIT DOUBLE PRECISION(a-h, o-z)
10777  IMPLICIT INTEGER(I-N)
10778  INTEGER PYK,PYCHGE,PYCOMP
10779 C...Parameter statement to help give large particle numbers.
10780  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
10781 C...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/
10793 C...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 
10803 C...The F, Xi and Xj functions of Gunion and Kunszt
10804 C...(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 
10813 C...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 
10824 C...Reset original resonance configuration.
10825  DO 100 jt=1,8
10826  iref(1,jt)=0
10827  100 CONTINUE
10828 
10829 C...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 
10852 C...Define original resonance for odd cases.
10853  ELSE
10854  isub=0
10855  iref(1,1)=ires
10856  jtmax=1
10857  ENDIF
10858 
10859 C...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 
10877 C.....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 
10884 C...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 
10895 C...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 
10906 C...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 
10917 C...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 
10927 C...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 
10942 C...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 
10960 C...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 
10975 C...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 
10996 C...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 
11005 C...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)
11021 CMRENNA++
11022 C...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
11034 CMRENNA--
11035  ELSEIF(kflw.EQ.6) THEN
11036  pmmn(i)=pmas(24,1)+pmas(5,1)
11037  ENDIF
11038  200 CONTINUE
11039 
11040 C...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 
11060 C...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
11063 CMRENNA++
11064 C....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
11071 CMRENNA--
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 
11082 C...For three wide resonances select narrower of three
11083 C...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
11096 C...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 
11117 C...Begin fill decay products, with colour flow for coloured objects.
11118  mstu10=mstu(10)
11119  mstu(10)=1
11120  mstu(19)=1
11121 
11122 CMRENNA++
11123 C...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
11128 C 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 
11143 C...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 
11152 C...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
11183 CMRENNA--
11184 
11185 C...2) Everything else two-body decay.
11186  ELSE
11187  CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
11188 C...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
11199 C...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
11208 C...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 
11227 C...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 
11241 C...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 
11258 C...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 
11262 C...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 
11274 C...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 
11283 C...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 
11308 C...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 
11320 C...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 
11342 C...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 
11351 C...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 
11355 C...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 
11373 C...Generate parton shower.
11374  IF(mstj(101).EQ.5) CALL pyshow(n-1,n,p(id,5))
11375 
11376 C... End special case for Z0: skip ahead.
11377  mstu(111)=mst111
11378  paru(112)=par112
11379  GOTO 610
11380  ENDIF
11381 
11382 C...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 
11401 C...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 
11421 C...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 
11434 C...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 
11456 C...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 
11477 C...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
11491 C...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
11496 C 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 
11510 C...Store incoming and outgoing momenta, with random rotation to
11511 C...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 
11534 C...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 
11554 C...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
11573 C...Isotropic decay selected by user.
11574  wt=1d0
11575  wtmax=1d0
11576 
11577  ELSEIF(jtmax.EQ.3) THEN
11578 C...Isotropic decay when three mother particles.
11579  wt=1d0
11580  wtmax=1d0
11581 
11582  ELSEIF(it4.GE.1) THEN
11583 C... 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
11589 C...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
11614 C...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
11630 C...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
11649 C...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
11654 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
11655 C...-> 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
11674 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
11675 C...-> 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
11680 C...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
11706 C...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
11723 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
11724 C...(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
11732 C...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
11750 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
11751 C...(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
11756 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
11757 C...-> 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
11778 C...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
11785 C...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
11790 C...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
11796 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
11797 C...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
11816 C...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
11835 C...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
11846 C...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
11857 C...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
11861 C...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
11868 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11869 C...(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
11880 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
11881 C...(W:s approximately longitudinal, like if intermediate H).
11882  wt=16d0*pkk(3,5)*pkk(4,6)
11883  wtmax=sh**2
11884  ELSE
11885 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
11886 C...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
11893 C...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
11908 C...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
11918 C...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
11925 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11926 C...(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
11937 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
11938 C...(W/Z approximately longitudinal, like if intermediate H).
11939  wt=16d0*pkk(3,5)*pkk(4,6)
11940  wtmax=sh**2
11941  ELSE
11942 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
11943 C...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
11950 C...Isotropic decay of leptoquarks (assumed spin 0).
11951  wt=1d0
11952  wtmax=1d0
11953 
11954  ELSEIF(isub.GE.146.AND.isub.LE.148) THEN
11955 C...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
11966 C...W/Z decay assumed isotropic, since not known.
11967  wt=1d0
11968  wtmax=1d0
11969  ENDIF
11970 
11971  ELSEIF(isub.EQ.149) THEN
11972 C...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
11978 C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
11979 C...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
11983 C...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
12009 C...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
12016 C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
12017 C...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
12021 C...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
12026 C...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
12033 C...Angular weight for f + fbar -> omega_tech0 ->
12034 C...gamma pi_tech0 or Z0 pi_tech0.
12035  wt=1d0+cthe(1)**2
12036  wtmax=2d0
12037  ELSEIF(ip.EQ.1) THEN
12038 C...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
12063 C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
12064  wt=1d0
12065  wtmax=1d0
12066  ENDIF
12067 
12068 C...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 
12075 C...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)
12083 CMRENNA++
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
12097 C...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
12104 CMRENNA--
12105 
12106 C...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
12111 C...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 
12118 C...Add documentation lines.
12119  IF(isub.NE.0) THEN
12120  idoc=mint(83)+mint(4)
12121 CMRENNA+++
12122  ihi=nsd(jt)+2
12123  IF(kfl3(jt).NE.0) ihi=ihi+1
12124  DO 560 i=nsd(jt)+1,ihi
12125 CMRENNA---
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 
12145 C...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 
12179 C...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 
12203 C...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 
12217 C...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 
12233 C...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 
12244 C...Loop back if needed.
12245  620 IF(ip.LT.np) GOTO 150
12246 
12247  RETURN
12248  END
12249 
12250 C*********************************************************************
12251 
12252 C...PYMULT
12253 C...Initializes treatment of multiple interactions, selects kinematics
12254 C...of hardest interaction if low-pT physics included in run, and
12255 C...generates all non-hardest interactions.
12256 
12257  SUBROUTINE pymult(MMUL)
12258 
12259 C...Double precision and integer declarations.
12260  IMPLICIT DOUBLE PRECISION(a-h, o-z)
12261  IMPLICIT INTEGER(I-N)
12262  INTEGER PYK,PYCHGE,PYCOMP
12263 C...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/
12276 C...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 
12280 C...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 
12290 C...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 
12301 C...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 
12317 C...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 
12326 C...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 
12338 C...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 
12355 C...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 
12382 C...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 
12394 C...Store some results for subsequent use.
12395  vint(145)=sigsum
12396  vint(146)=sop/so
12397  vint(147)=sop/sp
12398 
12399 C...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
12418 C...Low-pT or multiple interactions (first semihard interaction):
12419 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
12420 C...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 
12446 C...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
12458 C...Multiple interactions (first semihard interaction).
12459 C...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 
12477 C...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 
12493 C...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 
12513 C...Multiple interactions (variable impact parameter) : reject with
12514 C...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 
12532 C...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 
12543 C...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 
12572 C...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 
12599 C...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 
12612 C...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 
12628 C...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 
12637 C...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 
12650 C...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 
12661 C...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
12672 C....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 
12690 C....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 
12707 C...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 
12719 C...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 
12728 C...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 
12747 C...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 
12758 C*********************************************************************
12759 
12760 C...PYREMN
12761 C...Adds on target remnants (one or two from each side) and
12762 C...includes primordial kT for hadron beams.
12763 
12764  SUBROUTINE pyremn(IPU1,IPU2)
12765 
12766 C...Double precision and integer declarations.
12767  IMPLICIT DOUBLE PRECISION(a-h, o-z)
12768  IMPLICIT INTEGER(I-N)
12769  INTEGER PYK,PYCHGE,PYCOMP
12770 C...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/
12777 C...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 
12781 C...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 
12789 C...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 
12811 C...No primordial kT, or chosen according to truncated Gaussian or
12812 C...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 
12870 C...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 
12886 C...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 
12899 C...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 
12905 C...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 
12926 C...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 
12945 C...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 
12967 C...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 
12996 C...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 
13006 C...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 
13014 C...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 
13037 C...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 
13055 C...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 
13086 C...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 
13094 C...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 
13108 C...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 
13130 C...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 
13144 C...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 
13159 C...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 
13175 C...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 
13179 C***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 
13184 C...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 
13190 C...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 
13218 C...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 
13236 C...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 
13251 C...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 
13261 C...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 
13289 C...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 
13298 C...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 
13333 C...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 
13351 C...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 
13387 C...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 
13402 C...Calculate rotation and boost from overall CM frame to
13403 C...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 
13411 C...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 
13427 C...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 
13446 C*********************************************************************
13447 
13448 C...PYDIFF
13449 C...Handles diffractive and elastic scattering.
13450 
13451  SUBROUTINE pydiff
13452 
13453 C...Double precision and integer declarations.
13454  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13455  IMPLICIT INTEGER(I-N)
13456  INTEGER PYK,PYCHGE,PYCOMP
13457 C...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 
13464 C...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 
13490 C...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 
13498 C...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 
13509 C...Decay rho from elastic scattering of gamma with sin**2(theta)
13510 C...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 
13529 C...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 
13569 C...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 
13590 C...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))
13606 C...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 
13649 C...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 
13660 C...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 
13670 C*********************************************************************
13671 
13672 C...PYDISG
13673 C...Set up a DIS process as gamma* + f -> f, with beam remnant
13674 C...and showering added consecutively. Photon flux by the PYGAGA
13675 C...routine (if at all).
13676 
13677  SUBROUTINE pydisg
13678 
13679 C...Double precision and integer declarations.
13680  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13681  IMPLICIT INTEGER(I-N)
13682  INTEGER PYK,PYCHGE,PYCOMP
13683 C...Parameter statement to help give large particle numbers.
13684  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
13685 C...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/
13693 C...Local arrays.
13694  dimension pms(4)
13695 
13696 C...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 
13706 C...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 
13725 C...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 
13751 C...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 
13762 C...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 
13772 C...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 
13780 C...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 
13799 C...No primordial kT, or chosen according to truncated Gaussian or
13800 C...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 
13856 C...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 
13865 C...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 
13887 C...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 
13903 C...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 
13914 C...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 
13932 C...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 
13941 C...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 
13952 C...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 
13964 C...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 
13977 C*********************************************************************
13978 
13979 C...PYDOCU
13980 C...Handles the documentation of the process in MSTI and PARI,
13981 C...and also computes cross-sections based on accumulated statistics.
13982 
13983  SUBROUTINE pydocu
13984 
13985 C...Double precision and integer declarations.
13986  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13987  IMPLICIT INTEGER(I-N)
13988  INTEGER PYK,PYCHGE,PYCOMP
13989 C...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 
14000 C...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 
14024 C...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 
14042 C...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 
14049 C...Reset information on hard interaction.
14050  DO 110 j=1,200
14051  msti(j)=0
14052  pari(j)=0d0
14053  110 CONTINUE
14054 
14055 C...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 
14061 C...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 
14069 C...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 
14090 C...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 
14108 C...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 
14128 C...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 
14136 C...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 
14145 C...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 
14160 C*********************************************************************
14161 
14162 C...PYFRAM
14163 C...Performs transformations between different coordinate frames.
14164 
14165  SUBROUTINE pyfram(IFRAME)
14166 
14167 C...Double precision and integer declarations.
14168  IMPLICIT DOUBLE PRECISION(a-h, o-z)
14169  IMPLICIT INTEGER(I-N)
14170  INTEGER PYK,PYCHGE,PYCOMP
14171 C...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 
14177 C...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
14187 C...Transform from fixed target or user specified frame to
14188 C...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
14193 C...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
14199 C...Transform from overall CM frame to fixed target or user specified
14200 C...frame.
14201  CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))
14202  ELSEIF(iframe.EQ.3) THEN
14203 C...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 
14209 C...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 
14220 C*********************************************************************
14221 
14222 C...PYWIDT
14223 C...Calculates full and partial widths of resonances.
14224 
14225  SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)
14226 
14227 C...Double precision and integer declarations.
14228  IMPLICIT DOUBLE PRECISION(a-h, o-z)
14229  IMPLICIT INTEGER(I-N)
14230  INTEGER PYK,PYCHGE,PYCOMP
14231 C...Parameter statement to help give large particle numbers.
14232  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
14233 C...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/
14246 C...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 
14252 C...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 
14259 C...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 
14267 C...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 
14277 C...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
14279 C...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 
14284 C...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 
14301 C...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 
14358 C...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 
14439 C...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
14446 C...Return.
14447  mint(61)=0
14448  mint(62)=0
14449  mint(63)=0
14450  RETURN
14451  ENDIF
14452 
14453 C...Here begins detailed dynamical calculation of resonance widths.
14454 C...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 
14462 C...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
14473 C...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
14484 C...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
14496 C...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)
14501 CMRENNA++
14502  ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN
14503 C...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
14532 C...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
14551 C...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)
14559 CMRENNA--
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
14571 C...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
14581 C...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
14597 C...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
14618 C...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
14628 C...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
14640 C...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
14661 C...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
14671 C...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
14682 C...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
14703 C...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
14713 C...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
14724 C...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
14745 C...QCD:
14746 C***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
14755 C...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
14770 C...QED photon.
14771 C***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
14780 C...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
14788 C...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
14803 C...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
14835 C...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
14844 C...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
14887 C...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
14897 C...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
14909 C...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
14929 C...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
14947 C...h0 -> q + qbar
14948  wdtp(i)=fac*3d0*(pymrun(kfdp(idc,1),sh)**2/sh)*
14949  & sqrt(max(0d0,1d0-4d0*rm1))*radc
14950 C...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
14960 C...h0 -> l+ + l-
14961  wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))
14962 C...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
14969 C...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
14974 C...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
14995 C...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
15012 C...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
15030 C...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
15045 C...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
15067 C...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
15075 C...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
15088 C...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
15111 C...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
15153 C...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
15170 C...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
15179 C...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
15193 C...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
15228 C***H0 -> Z0 + h0 (not yet implemented).
15229 
15230  ELSEIF(i.EQ.19.AND.kfla.EQ.35) THEN
15231 C...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
15237 C...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
15243 C...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 
15248 CMRENNA++
15249  ELSE
15250 C...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)
15261 CMRENNA--
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
15282 C...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
15342 C...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
15362 C...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
15402 C...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
15421 C...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
15443 C...Z'0 -> Z0 + gamma.
15444  ELSEIF(i.EQ.20) THEN
15445 C...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
15464 C...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
15524 C...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
15535 C...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
15548 C...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
15559 C...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
15566 C...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
15582 C...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
15594 C...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
15608 C...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
15618 C...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 
15624 CMRENNA++
15625  ELSE
15626 C...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)
15637 CMRENNA--
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
15654 C...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
15679 C...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
15705 C...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
15715 C...R -> q + qbar'
15716  fcof=3d0*radc
15717  ELSEIF(i.LE.9) THEN
15718 C...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
15744 C...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
15755 C...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
15766 C...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
15792 C...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
15806 C...pi_tech -> f + f'.
15807  fcof=1d0
15808  IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc
15809 C...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
15856 C...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
15876 C...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
15881 C...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
15889 C...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
15897 C...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
15902 C...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
15908 C...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
15913 C...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
15919 C...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
15925 C...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
15956 C...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
15974 C...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
15983 C...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
15995 C...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
16010 C...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
16019 C...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
16029 C...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
16038 C...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
16073 C...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
16091 C...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
16096 C...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
16102 C...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
16108 C...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
16114 C...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
16121 C...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
16128 C...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
16133 C...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
16138 C...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
16169 C...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
16179 C...H_L++/-- -> l+/- + l'+/-
16180  fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
16181  & (iabs(kfdp(idc,2))-9)/2)**2
16182 C***Should be factor 4 below ???
16183  IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
16184  ELSEIF(i.EQ.7) THEN
16185 C...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
16202 C...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
16212 C...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
16217 C...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
16233 C...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
16243 C...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
16251 C...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
16266 C...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
16276 C...d* -> g + d.
16277  wdtp(i)=fac*as*paru(159)**2/3d0
16278  wid2=1d0
16279  ELSEIF(i.EQ.2) THEN
16280 C...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
16285 C...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
16291 C...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
16307 C...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
16317 C...u* -> g + u.
16318  wdtp(i)=fac*as*paru(159)**2/3d0
16319  wid2=1d0
16320  ELSEIF(i.EQ.2) THEN
16321 C...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
16326 C...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
16332 C...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
16348 C...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
16358 C...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
16363 C...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
16369 C...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
16385 C...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
16395 C...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
16401 C...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 
16424 C***********************************************************************
16425 
16426 C...PYWIDX
16427 C...Calculates full and partial widths of resonances.
16428 C....copy of PYWIDT, used for techniparticle widths
16429 
16430  SUBROUTINE pywidx(KFLR,SH,WDTP,WDTE)
16431 
16432 C...Double precision and integer declarations.
16433  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16434  IMPLICIT INTEGER(I-N)
16435  INTEGER PYK,PYCHGE,PYCOMP
16436 C...Parameter statement to help give large particle numbers.
16437  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
16438 C...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/
16451 C...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 
16457 C...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 
16464 C...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 
16472 C...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
16483 C...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
16496 C...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
16505 C...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
16527 C...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
16537 C...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
16549 C...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 
16572 C***********************************************************************
16573 
16574 C...PYOFSH
16575 C...Calculates partial width and differential cross-section maxima
16576 C...of channels/processes not allowed on mass-shell, and selects
16577 C...masses in such channels/processes.
16578 
16579  SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
16580 
16581 C...Double precision and integer declarations.
16582  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16583  IMPLICIT INTEGER(I-N)
16584  INTEGER PYK,PYCHGE,PYCOMP
16585 C...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/
16596 C...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 
16602 C...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 
16628 C...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 
16647 C...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 
16698 C...Calculation of partial width of resonance.
16699  IF(mofsh.EQ.1) THEN
16700 
16701 C..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 
16712 C...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 
16727 C...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 
16745 C...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 
16753 C...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 
16781 C...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 
16792 C...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 
16820 C...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 
16832 C...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 
16843 C...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 
16855 C...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 
16871 C...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 
16889 C...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 
16907 C...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 
16913 C...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 
16949 C...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 
16981 C***********************************************************************
16982 
16983 C...PYRECO
16984 C...Handles the possibility of colour reconnection in W+W- events,
16985 C...Based on the main scenarios of the Sjostrand and Khoze study:
16986 C...I, II, II', intermediate and instantaneous; plus one model
16987 C...along the lines of the Gustafson and Hakkinen: GH.
16988 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
16989 C...is as if first resonance is W+ and second W-.
16990 
16991  SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)
16992 
16993 C...Double precision and integer declarations.
16994  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16995  IMPLICIT INTEGER(I-N)
16996  INTEGER PYK,PYCHGE,PYCOMP
16997 C...Parameter value; number of points in MC integration.
16998  parameter(npt=100)
16999 C...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/
17006 C...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 
17013 C...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 
17019 C...Only allow fraction of recoupling for GH, intermediate and
17020 C...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 
17026 C...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 
17030 C...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 
17043 C...Find range of decay products of the W's.
17044 C...Background: the W's are stored in IW1 and IW2.
17045 C...Their direct decay products in NSD1+1 through NSD1+4.
17046 C...Products after shower (if any) in NSD1+5 through NAFT1
17047 C...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 
17063 C...Rearrange parton shower products along strings.
17064  nold=n
17065  CALL pyprep(nsd1+1)
17066 
17067 C...Find partons pointing back to W+ and W-; store them with quark
17068 C...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 
17103 C...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 
17111 C...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 
17122 C...Begin scenario I specifics.
17123  IF(mstp(115).EQ.1) THEN
17124 
17125 C...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 
17146 C...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 
17167 C...Loop over number of space-time points.
17168  nacc=0
17169  sum=0d0
17170  DO 250 ipt=1,npt
17171 
17172 C...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 
17182 C...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 
17187 C...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 
17214 C...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 
17241 C...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 
17254 C...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 
17268 C...Begin scenario II and II' specifics.
17269  ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN
17270 
17271 C...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 
17283 C...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 
17291 C...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 
17300 C...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 
17311 C...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 
17317 C...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 
17328 C...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 
17339 C...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 
17363 C...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
17369 C...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
17375 C...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 
17397 C...Begin scenario GH specifics.
17398  ELSEIF(mstp(115).EQ.5) THEN
17399 
17400 C...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 
17412 C...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 
17428 C...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 
17450 C...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 
17464 C...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 
17470 C...Common part for intermediate and instantaneous scenarios.
17471  ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
17472  mint(32)=1
17473 
17474 C...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 
17482 C...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 
17489 C...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 
17497 C...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 
17505 C...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 
17521 C***********************************************************************
17522 
17523 C...PYKLIM
17524 C...Checks generated variables against pre-set kinematical limits;
17525 C...also calculates limits on variables used in generation.
17526 
17527  SUBROUTINE pyklim(ILIM)
17528 
17529 C...Double precision and integer declarations.
17530  IMPLICIT DOUBLE PRECISION(a-h, o-z)
17531  IMPLICIT INTEGER(I-N)
17532  INTEGER PYK,PYCHGE,PYCOMP
17533 C...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 
17545 C...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
17576 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
17577 C...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 
17663 C...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
17674 C...Calculate limits on tau
17675 C...0) due to definition
17676  taumn0=0d0
17677  taumx0=1d0
17678 C...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)
17682 C...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
17689 C...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)
17700 C...4) due to limits on x1 and x2
17701  taumn4=ckin(21)*ckin(23)
17702  taumx4=ckin(22)*ckin(24)
17703 C...5) due to limits on xF
17704  taumn5=0d0
17705  taumx5=max(1d0-ckin(25),1d0+ckin(26))
17706 C...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 
17712 C...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
17726 C...Calculate limits on y*
17727  taue=tau
17728  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
17729  taurt=sqrt(taue)
17730 C...0) due to kinematics
17731  ystmn0=log(taurt)
17732  ystmx0=-ystmn0
17733 C...1) due to explicit limits
17734  ystmn1=ckin(7)
17735  ystmx1=ckin(8)
17736 C...2) due to limits on x1
17737  ystmn2=log(max(taue,ckin(21))/taurt)
17738  ystmx2=log(max(taue,ckin(22))/taurt)
17739 C...3) due to limits on x2
17740  ystmn3=-log(max(taue,ckin(24))/taurt)
17741  ystmx3=-log(max(taue,ckin(23))/taurt)
17742 C...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))
17747 C...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)
17754 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
17755 C... 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 
17766 C...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
17786 C...Calculate limits on cos(theta-hat)
17787  yst=vint(22)
17788 C...0) due to definition
17789  ctnmn0=-1d0
17790  ctnmx0=0d0
17791  ctpmn0=0d0
17792  ctpmx0=1d0
17793 C...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))
17798 C...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
17808 C...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)))
17817 C...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
17841 C...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 
17865 C...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
17873 C...Calculate limits on tau'
17874 C...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
17881 C...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 
17886 C...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 
17902 C...Special case for low-pT and multiple interactions:
17903 C...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 
17933 C*********************************************************************
17934 
17935 C...PYKMAP
17936 C...Maps a uniform distribution into a distribution of a kinematical
17937 C...variable according to one of the possibilities allowed. It is
17938 C...assumed that kinematical limits have been set by a PYKLIM call.
17939 
17940  SUBROUTINE pykmap(IVAR,MVAR,VVAR)
17941 
17942 C...Double precision and integer declarations.
17943  IMPLICIT DOUBLE PRECISION(a-h, o-z)
17944  IMPLICIT INTEGER(I-N)
17945  INTEGER PYK,PYCHGE,PYCOMP
17946 C...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 
17955 C...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 
17992 C...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 
18025 C...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 
18106 C...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 
18130 C...Selection of extra variables needed in 2 -> 3 process:
18131 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
18132 C...Since no options are available, the functions of PYKLIM
18133 C...and PYKMAP are joint for these choices.
18134  ELSEIF(ivar.EQ.5) THEN
18135 
18136 C...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 
18154 C...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 
18172 C...Select transverse momenta according to
18173 C...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 
18209 C...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 
18220 C...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 
18233 C...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 
18244 C...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 
18261 C...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 
18274 C...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 
18302 C***********************************************************************
18303 
18304 C...PYSIGH
18305 C...Differential matrix elements for all included subprocesses
18306 C...Note that what is coded is (disregarding the COMFAC factor)
18307 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
18308 C...when d(sigma-hat) is given in the zero-width limit, the delta
18309 C...function in tau is replaced by a (modified) Breit-Wigner:
18310 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
18311 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
18312 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
18313 C...i.e., dimensionless quantities
18314 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
18315 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
18316 C...(2pi)^4 delta^4(P - sum p_i)
18317 C...COMFAC contains the factor pi/s (or equivalent) and
18318 C...the conversion factor from GeV^-2 to mb
18319 
18320  SUBROUTINE pysigh(NCHN,SIGS)
18321 
18322 C...Double precision and integer declarations
18323  IMPLICIT DOUBLE PRECISION(a-h, o-z)
18324  IMPLICIT INTEGER(I-N)
18325  INTEGER PYK,PYCHGE,PYCOMP
18326 C...Parameter statement to help give large particle numbers.
18327  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
18328 C...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/
18346 C...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 
18356 C...Reset number of channels and cross-section
18357  nchn=0
18358  sigs=0d0
18359 
18360 C...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 
18381 CMRENNA++
18382 C...Convert almost equivalent SUSY processes into each other
18383 C...Extract differences in flavours and couplings
18384  IF(isub.GE.200.AND.isub.LE.301) THEN
18385 
18386 C...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 
18417 C...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 
18452 C...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 
18466 C...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 
18495 C...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 
18508 C...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 
18517 C...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 
18533 C...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 
18548 C...Squark + gluino
18549  ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN
18550  isub=258
18551  rkf=4d0
18552 
18553 C...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 
18561 C...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
18581 C...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
18608 C...Squark + gluino
18609  ELSEIF(isub.EQ.294.OR.isub.EQ.295) THEN
18610  isub=258
18611  rkf=1d0
18612  ENDIF
18613 C...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
18621 C...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
18629 C...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
18643 C... rho_tech0 -> W_L W_L
18644  IF(isub.EQ.361) THEN
18645  kfa=24
18646  kfb=24
18647  cab2=parp(141)**4
18648 C... 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)
18654 C... 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
18660 C... 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
18668 C... 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
18677 C... 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
18686 C... 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
18695 C... 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
18704 C... rho_tech+ -> W_L Z_L
18705  ELSEIF(isub.EQ.370) THEN
18706  kfa=24
18707  kfb=23
18708  cab2=parp(141)**4
18709 C... 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)
18715 C... 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)
18721 C... 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
18727 C... gamma pi_tech+
18728  ELSEIF(isub.EQ.374) THEN
18729  kfa=52
18730  kfb=22
18731  vrgp=qupd*csxi
18732  argp=0d0
18733 C... 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))))
18740 C... 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)))
18747 C... 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
18756 CMRENNA--
18757 
18758 C...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 
18776 C...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
18809 C...Kinematics with incoming masses tricky: now depends on how
18810 C...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 
18832 C...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 
18914 C...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 
18932 C...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 
18956 C...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 
18983 C...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 
19004 C...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 
19018 C...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)
19025 C...MRENNA+++
19026  zwid=pmas(23,2)
19027  wwid=pmas(24,2)
19028  tanw=sqrt(xw/xw1)
19029  ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
19030 C...MRENNA---
19031 
19032 C...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 
19076 C...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 
19107 C...2 -> 1 processes: reduction in angular part of phase space integral
19108 C...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 
19121 C...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 
19138 C...2 -> 2 processes: take into account final state Breit-Wigners
19139  comfac=comfac*vint(80)
19140  ENDIF
19141 
19142 C...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 
19158 C...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 
19168 C...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 
19174 C...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)
19189 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
19190 C...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 
19195 C...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 
19199 C...Extra factors to include the effects of
19200 C...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 
19262 C...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
19265 C...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 
19277 C...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 
19292 C...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 
19304 C...Supersymmetric processes - all of type 2 -> 2 :
19305 C...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 
19323 C...A: 2 -> 1, tree diagrams
19324 
19325  IF(isub.LE.10) THEN
19326  IF(isub.EQ.1) THEN
19327 C...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
19354 C...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
19381 C...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
19409 C...gamma + W+/- -> W+/-
19410 
19411  ELSEIF(isub.EQ.5) THEN
19412 C...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
19440 C...Z0 + W+/- -> W+/-
19441 
19442  ELSEIF(isub.EQ.7) THEN
19443 C...W+ + W- -> Z0
19444 
19445  ELSEIF(isub.EQ.8) THEN
19446 C...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 
19470 C...B: 2 -> 2, tree diagrams
19471 
19472  ELSEIF(isub.EQ.10) THEN
19473 C...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)
19484 C...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)
19492 C...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
19511 C...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
19529 C...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
19537 C...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
19582 C...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
19587 C...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
19612 C...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
19633 C...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
19647 C...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)
19649 C...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
19682 C...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
19693 C...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
19709 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
19710  facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)
19711 C...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
19736 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
19737 
19738  ELSEIF(isub.EQ.18) THEN
19739 C...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
19754 C...f + fbar -> gamma + (gamma*/Z0)
19755  facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)
19756 C...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
19789 C...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
19800 C...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
19817 C...f + fbar' -> gamma + W+/-
19818  facgw=comfac*0.5d0*aem**2/xw
19819 C...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
19825 C...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
19866 C...f + fbar -> gamma + h0
19867 
19868  ELSEIF(isub.EQ.22) THEN
19869 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
19870 C...Kinematics dependence
19871  faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-
19872  & sqm3*sqm4*(1d0/th2+1d0/uh2))
19873 C...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
19921 C...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
19946 C...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
19974 C...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)
20017 C***Protect against slightly negative cross sections. (Reason yet to be
20018 C***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
20024 C...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
20046 C...f + fbar -> W+ + W-
20047 C...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)
20058 C...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
20066 C...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)
20075 C...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
20123 C...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
20146 C...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
20176 C...f + fbar -> h0 + h0
20177 
20178  ELSEIF(isub.EQ.28) THEN
20179 C...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
20203 C...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
20221 C...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)
20224 C...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
20257 C...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
20268 C...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
20290 C...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)
20293 C...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
20316 C...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
20345 C...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
20363 C...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
20381 C...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)
20393 C...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
20426 C...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
20437 C...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
20458 C...f + gamma -> f' + W+/-
20459  fwq=comfac*aem**2/(2d0*xw)*
20460  & (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)
20461 C...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
20486 C...f + gamma -> f + h0
20487 
20488  ELSEIF(isub.EQ.38) THEN
20489 C...f + Z0 -> f + g (q + Z0 -> q + g only)
20490 
20491  ELSEIF(isub.EQ.39) THEN
20492 C...f + Z0 -> f + gamma
20493 
20494  ELSEIF(isub.EQ.40) THEN
20495 C...f + Z0 -> f + Z0
20496  ENDIF
20497 
20498  ELSEIF(isub.LE.50) THEN
20499  IF(isub.EQ.41) THEN
20500 C...f + Z0 -> f' + W+/-
20501 
20502  ELSEIF(isub.EQ.42) THEN
20503 C...f + Z0 -> f + h0
20504 
20505  ELSEIF(isub.EQ.43) THEN
20506 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
20507 
20508  ELSEIF(isub.EQ.44) THEN
20509 C...f + W+/- -> f' + gamma
20510 
20511  ELSEIF(isub.EQ.45) THEN
20512 C...f + W+/- -> f' + Z0
20513 
20514  ELSEIF(isub.EQ.46) THEN
20515 C...f + W+/- -> f' + W+/-
20516 
20517  ELSEIF(isub.EQ.47) THEN
20518 C...f + W+/- -> f' + h0
20519 
20520  ELSEIF(isub.EQ.48) THEN
20521 C...f + h0 -> f + g (q + h0 -> q + g only)
20522 
20523  ELSEIF(isub.EQ.49) THEN
20524 C...f + h0 -> f + gamma
20525 
20526  ELSEIF(isub.EQ.50) THEN
20527 C...f + h0 -> f + Z0
20528  ENDIF
20529 
20530  ELSEIF(isub.LE.60) THEN
20531  IF(isub.EQ.51) THEN
20532 C...f + h0 -> f' + W+/-
20533 
20534  ELSEIF(isub.EQ.52) THEN
20535 C...f + h0 -> f + h0
20536 
20537  ELSEIF(isub.EQ.53) THEN
20538 C...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
20558 C...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
20583 C...g + Z -> f + fbar (g + Z -> q + qbar only)
20584 
20585  ELSEIF(isub.EQ.56) THEN
20586 C...g + W -> f + f'bar (g + W -> q + q'bar only)
20587 
20588  ELSEIF(isub.EQ.57) THEN
20589 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
20590 
20591  ELSEIF(isub.EQ.58) THEN
20592 C...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
20611 C...gamma + Z0 -> f + fbar
20612 
20613  ELSEIF(isub.EQ.60) THEN
20614 C...gamma + W+/- -> f + fbar'
20615  ENDIF
20616 
20617  ELSEIF(isub.LE.70) THEN
20618  IF(isub.EQ.61) THEN
20619 C...gamma + h0 -> f + fbar
20620 
20621  ELSEIF(isub.EQ.62) THEN
20622 C...Z0 + Z0 -> f + fbar
20623 
20624  ELSEIF(isub.EQ.63) THEN
20625 C...Z0 + W+/- -> f + fbar'
20626 
20627  ELSEIF(isub.EQ.64) THEN
20628 C...Z0 + h0 -> f + fbar
20629 
20630  ELSEIF(isub.EQ.65) THEN
20631 C...W+ + W- -> f + fbar
20632 
20633  ELSEIF(isub.EQ.66) THEN
20634 C...W+/- + h0 -> f + fbar'
20635 
20636  ELSEIF(isub.EQ.67) THEN
20637 C...h0 + h0 -> f + fbar
20638 
20639  ELSEIF(isub.EQ.68) THEN
20640 C...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
20666 C...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
20680 C...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
20700 C...Z0 + Z0 -> Z0 + Z0
20701  IF(sh.LE.4.01d0*sqmz) GOTO 840
20702 
20703  IF(mstp(46).LE.2) THEN
20704 C...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
20726 C...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
20754 C...Z0 + Z0 -> W+ + W-
20755  IF(sh.LE.4.01d0*sqmz) GOTO 870
20756 
20757  IF(mstp(46).LE.2) THEN
20758 C...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
20791 C...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
20819 C...Z0 + W+/- -> Z0 + W+/-
20820  IF(sh.LE.2d0*sqmz+2d0*sqmw) GOTO 900
20821 
20822  IF(mstp(46).LE.2) THEN
20823 C...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
20863 C...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
20898 C...W+ + W- -> gamma + gamma
20899 
20900  ELSEIF(isub.EQ.76) THEN
20901 C...W+ + W- -> Z0 + Z0
20902  IF(sh.LE.4.01d0*sqmz) GOTO 930
20903 
20904  IF(mstp(46).LE.2) THEN
20905 C...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
20938 C...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
20961 C...W+/- + W+/- -> W+/- + W+/-
20962  IF(sh.LE.4.01d0*sqmw) GOTO 960
20963 
20964  IF(mstp(46).LE.2) THEN
20965 C...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
21025 C...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
21038 C...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
21043 C...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
21061 C...W+/- + h0 -> W+/- + h0
21062 
21063  ELSEIF(isub.EQ.79) THEN
21064 C...h0 + h0 -> h0 + h0
21065 
21066  ELSEIF(isub.EQ.80) THEN
21067 C...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 
21092 C...C: 2 -> 2, tree diagrams with masses
21093 
21094  ELSEIF(isub.LE.90) THEN
21095  IF(isub.EQ.81) THEN
21096 C...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
21116 C...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
21159 C...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
21217 C...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
21243 C...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
21265 C...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
21278 C...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
21297 C...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
21314 C...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 
21333 C...D: Mimimum bias processes
21334 
21335  ELSEIF(isub.LE.100) THEN
21336  IF(isub.EQ.91) THEN
21337 C...Elastic scattering
21338  sigs=vint(315)*vint(316)*sigt(0,0,1)
21339 
21340  ELSEIF(isub.EQ.92) THEN
21341 C...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
21345 C...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
21349 C...Double diffractive scattering
21350  sigs=vint(315)*vint(316)*sigt(0,0,4)
21351 
21352  ELSEIF(isub.EQ.95) THEN
21353 C...Low-pT scattering
21354  sigs=vint(315)*vint(316)*sigt(0,0,5)
21355 
21356  ELSEIF(isub.EQ.96) THEN
21357 C...Multiple interactions: sum of QCD processes
21358  CALL pywidt(21,sh,wdtp,wdte)
21359 
21360 C...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 
21388 C...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 
21414 C...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 
21435 C...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
21473 C...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 
21518 C...E: 2 -> 1, loop diagrams
21519 
21520  ELSEIF(isub.LE.110) THEN
21521  IF(isub.EQ.101) THEN
21522 C...g + g -> gamma*/Z0
21523 
21524  ELSEIF(isub.EQ.102) THEN
21525 C...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
21542 C...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
21559 C...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
21573 C...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 
21586 C...Continuation C: 2 -> 2, tree diagrams with masses.
21587 
21588  ELSEIF(isub.EQ.106) THEN
21589 C...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
21603 C...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
21624 C...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 
21637 C...F: 2 -> 2, box diagrams
21638 
21639  ELSEIF(isub.EQ.110) THEN
21640 C...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)
21644 C...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))
21705 C...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
21725 C...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
21755 C...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
21788 C...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
21927 C...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
22052 C...g + g -> gamma + Z0
22053 
22054  ELSEIF(isub.EQ.117) THEN
22055 C...g + g -> Z0 + Z0
22056 
22057  ELSEIF(isub.EQ.118) THEN
22058 C...g + g -> W+ + W-
22059 
22060  ENDIF
22061 
22062 C...G: 2 -> 3, tree diagrams
22063 
22064  ELSEIF(isub.LE.140) THEN
22065  IF(isub.EQ.121) THEN
22066 C...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
22096 C...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
22128 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
22129 C...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
22166 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
22167 C...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
22197 C...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
22225 C...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
22253 C...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
22288 C...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 
22329 C...H: 2 -> 1, tree diagrams, non-standard model processes
22330 
22331  ELSEIF(isub.LE.160) THEN
22332  IF(isub.EQ.141) THEN
22333 C...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
22393 C...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
22422 C...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
22461 C...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
22486 C...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
22518 C...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
22546 C...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
22573 C...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 
22591 C...I: 2 -> 2, tree diagrams, non-standard model processes
22592 
22593  ELSEIF(isub.LE.200) THEN
22594  IF(isub.EQ.161) THEN
22595 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
22596 C...(choice of only b and t to avoid kinematics problems)
22597  fhcq=comfac*faca*as*aem/xw*1d0/24
22598 C...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
22629 C...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
22649 C...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
22659 C...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
22665 C...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
22685 C...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
22730 C...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
22769 C...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)
22776 C...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
22842 C...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)
22848 C...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
22874 C...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
22905 C...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
22936 C...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
22967 C...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
23034 C...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 
23073 CMRENNA++
23074 C...J: 2 -> 2, tree diagrams, SUSY processes
23075 
23076  ELSEIF(isub.LE.210) THEN
23077  IF(isub.EQ.201) THEN
23078 C...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
23088 C...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
23152 C...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
23161 C...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
23218 C...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
23251 C...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
23267 C...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
23290 C...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
23317 C...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
23349 C...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
23377 C...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
23381 C...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
23415 C...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
23473 C...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
23508 C...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
23549 C...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
23572 C...1/2 for identical particles
23573  sigh(nchn)=0.25d0*(facgg1+facgg2)
23574  1770 CONTINUE
23575 
23576  ELSEIF(isub.EQ.244) THEN
23577 C...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
23608 C...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
23647 C...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
23691 C...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
23736 C...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
23768 C...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
23777 C...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)
23786 C...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
23804 C...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
23827 C...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
23890 C...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
23895 C...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
23930 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
23931 C...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
23976 C...g + g -> ~q_j + ~q_jbar
23977  xsu=sqm3-uh
23978  xst=sqm3-th
23979 C...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
23997 CMRENNA--
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
24004 C...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
24030 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
24031  kfres=kfpr(isub,1)
24032 C...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
24075 C...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)
24079 C...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)
24088 C...Kinematical and coupling functions
24089  fachh=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*(th*uh-sqm3*sqm4)
24090  xwhh=(1d0-2d0*xwv)/(8d0*xwv*(1d0-xwv))
24091 C...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
24135 C...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
24179 C...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
24231 C...f + fbar -> gamma pi_tech, gamma pi_tech', Z pi_tech, Z pi_tech',
24232 C...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
24296 C...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
24332 C...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 
24371 C...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 
24389 C*********************************************************************
24390 
24391 C...PYPDFU
24392 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
24393 C...parton distributions according to a few different parametrizations.
24394 C...Note that what is coded is x times the probability distribution,
24395 C...i.e. xq(x,Q2) etc.
24396 
24397  SUBROUTINE pypdfu(KF,X,Q2,XPQ)
24398 
24399 C...Double precision and integer declarations.
24400  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24401  IMPLICIT INTEGER(I-N)
24402  INTEGER PYK,PYCHGE,PYCOMP
24403 C...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/
24411 C...Local arrays.
24412  dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),
24413  &xppi(-6:6),xppr(-6:6)
24414 
24415 C...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 
24423 C...Data related to Schuler-Sjostrand photon distributions.
24424  DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/
24425 
24426 C...Reset parton distributions.
24427  mint(92)=0
24428  DO 100 kfl=-25,25
24429  xpq(kfl)=0d0
24430  100 CONTINUE
24431 
24432 C...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 
24446 C...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 
24453 C...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
24485 C...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 
24554 C...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
24577 C...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 
24610 C...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 
24667 C...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
24675 C...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 
24709 C...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 
24744 C...Rescale for gammaVDM by effective gamma -> rho coupling.
24745 C+++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 
24754 C...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 
24763 C...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 
24777 C...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 
24787 C...Allow gluon also in position 21.
24788  xpq(21)=xpq(0)
24789 
24790 C...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 
24796 C...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 
24806 C*********************************************************************
24807 
24808 C...PYPDFL
24809 C...Gives proton parton distribution at small x and/or Q^2 according to
24810 C...correct limiting behaviour.
24811 
24812  SUBROUTINE pypdfl(KF,X,Q2,XPQ)
24813 
24814 C...Double precision and integer declarations.
24815  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24816  IMPLICIT INTEGER(I-N)
24817  INTEGER PYK,PYCHGE,PYCOMP
24818 C...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/
24824 C...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 
24828 C...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 
24840 C...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 
24849 C...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 
24890 C...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 
24896 C...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 
24903 C...Small Q2 and large x: dampen boundary value.
24904  ELSEIF(x.GT.xmn) THEN
24905 
24906 C...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 
24911 C...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 
24924 C...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 
24939 C...Large Q2 and small x: interpolate behaviour.
24940  ELSEIF(q2.GT.q2mn) THEN
24941 
24942 C...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 
24952 C...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 
24973 C...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 
24988 C...Small Q2 and small x: dampen boundary value and add term.
24989  ELSE
24990 
24991 C...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 
25002 C...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 
25015 C...Dampen valence and sea separately. Add constant terms.
25016 C...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 
25039 C...Format for error printout.
25040  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
25041 
25042  RETURN
25043  END
25044 
25045 C*********************************************************************
25046 
25047 C...PYPDEL
25048 C...Gives electron (or muon, or tau) parton distribution.
25049 
25050  SUBROUTINE pypdel(KFA,X,Q2,XPEL)
25051 
25052 C...Double precision and integer declarations.
25053  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25054  IMPLICIT INTEGER(I-N)
25055  INTEGER PYK,PYCHGE,PYCOMP
25056 C...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/
25062 C...Local arrays.
25063  dimension xpel(-25:25),xpga(-6:6),sxp(0:6)
25064 
25065 C...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 
25073 C...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 
25086 C...Electron inside electron, see R. Kleiss et al., in Z physics at
25087 C...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
25099 C...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 
25107 C...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 
25118 C...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 
25125 C...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 
25139 C...Quarks and gluons inside photon inside electron:
25140 C...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
25155 C...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)
25164 C...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
25171 C...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
25178 C...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 
25196 C...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 
25208 C*********************************************************************
25209 
25210 C...PYPDGA
25211 C...Gives photon parton distribution.
25212 
25213  SUBROUTINE pypdga(X,Q2,XPGA)
25214 
25215 C...Double precision and integer declarations.
25216  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25217  IMPLICIT INTEGER(I-N)
25218  INTEGER PYK,PYCHGE,PYCOMP
25219 C...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/
25224 C...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 
25229 C...The following data lines are coefficients needed in the
25230 C...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 
25258 C...Photon parton distribution from Drees and Grassie.
25259 C...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 
25276 C...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 
25282 C...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 
25309 C...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 
25323 C*********************************************************************
25324 
25325 C...PYGGAM
25326 C...Constructs the F2 and parton distributions of the photon
25327 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
25328 C...For F2, c and b are included by the Bethe-Heitler formula;
25329 C...in the 'MSbar' scheme additionally a Cgamma term is added.
25330 C...Contains the SaS sets 1D, 1M, 2D and 2M.
25331 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25332 
25333  SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
25334 
25335 C...Double precision and integer declarations.
25336  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25337  IMPLICIT INTEGER(I-N)
25338  INTEGER PYK,PYCHGE,PYCOMP
25339 C...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/
25344 C...Local arrays.
25345  dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)
25346 C...Charm and bottom masses (low to compensate for J/psi etc.).
25347  DATA pmc/1.3d0/, pmb/4.6d0/
25348 C...alpha_em and alpha_em/(2*pi).
25349  DATA aem/0.007297d0/, aem2pi/0.0011614d0/
25350 C...Lambda value for 4 flavours.
25351  DATA alam/0.20d0/
25352 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
25353  DATA fracu/0.8d0/
25354 C...VMD couplings f_V**2/(4*pi).
25355  DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/
25356 C...Masses for rho (=omega) and phi.
25357  DATA pmrho/0.770d0/, pmphi/1.020d0/
25358 C...Number of points in integration for IP2=1.
25359  DATA nstep/100/
25360 
25361 C...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 
25376 C...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 
25384 C...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 
25424 C...Call VMD parametrization for d quark and use to give rho, omega,
25425 C...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
25449 C...Anomalous parametrizations for different strategies
25450 C...for off-shell photons; except full integration.
25451 
25452 C...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 
25459 C...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
25472 C...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 
25492 C...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 
25500 C...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 
25508 C...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 
25521 C*********************************************************************
25522 
25523 C...PYGVMD
25524 C...Evaluates the VMD parton distributions of a photon,
25525 C...evolved homogeneously from an initial scale P2 to Q2.
25526 C...Does not include dipole suppression factor.
25527 C...ISET is parton distribution set, see above;
25528 C...additionally ISET=0 is used for the evolution of an anomalous photon
25529 C...which branched at a scale P2 and then evolved homogeneously to Q2.
25530 C...ALAM is the 4-flavour Lambda, which is automatically converted
25531 C...to 3- and 5-flavour equivalents as needed.
25532 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25533 
25534  SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25535 
25536 C...Double precision and integer declarations.
25537  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25538  IMPLICIT INTEGER(I-N)
25539  INTEGER PYK,PYCHGE,PYCOMP
25540 C...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 
25544 C...Reset output.
25545  DO 100 kfl=-6,6
25546  xpga(kfl)=0d0
25547  vxpga(kfl)=0d0
25548  100 CONTINUE
25549  kfa=iabs(kf)
25550 
25551 C...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 
25559 C...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 
25567 C...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 
25587 C...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 
25594 C...Evaluate homogeneous anomalous parton distributions below or
25595 C...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 
25616 C...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 
25636 C...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 
25656 C...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 
25679 C...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 
25703 C...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 
25724 C...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 
25741 C*********************************************************************
25742 
25743 C...PYGANO
25744 C...Evaluates the parton distributions of the anomalous photon,
25745 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
25746 C...KF=0 gives the sum over (up to) 5 flavours,
25747 C...KF<0 limits to flavours up to abs(KF),
25748 C...KF>0 is for flavour KF only.
25749 C...ALAM is the 4-flavour Lambda, which is automatically converted
25750 C...to 3- and 5-flavour equivalents as needed.
25751 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25752 
25753  SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
25754 
25755 C...Double precision and integer declarations.
25756  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25757  IMPLICIT INTEGER(I-N)
25758  INTEGER PYK,PYCHGE,PYCOMP
25759 C...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 
25763 C...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 
25771 C...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 
25781 C...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 
25789 C...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 
25801 C...Loop over flavours the photon can branch into.
25802  DO 110 kfl=kflmn,kflmx
25803 
25804 C...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 
25827 C...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 
25830 C...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 
25847 C...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 
25857 C...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 
25862 C...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 
25876 C...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 
25890 C...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 
25908 C*********************************************************************
25909 
25910 C...PYGBEH
25911 C...Evaluates the Bethe-Heitler cross section for heavy flavour
25912 C...production.
25913 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25914 
25915  SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)
25916 
25917 C...Double precision and integer declarations.
25918  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25919  IMPLICIT INTEGER(I-N)
25920  INTEGER PYK,PYCHGE,PYCOMP
25921 
25922 C...Local data.
25923  DATA aem2pi/0.0011614d0/
25924 
25925 C...Reset output.
25926  xpbh=0d0
25927  sigbh=0d0
25928 
25929 C...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 
25937 C...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 
25947 C...Complicated case: P2 > 0, based on approximation of
25948 C...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 
25967 C...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 
25975 C*********************************************************************
25976 
25977 C...PYGDIR
25978 C...Evaluates the direct contribution, i.e. the C^gamma term,
25979 C...as needed in MSbar parametrizations.
25980 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
25981 
25982  SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)
25983 
25984 C...Double precision and integer declarations.
25985  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25986  IMPLICIT INTEGER(I-N)
25987  INTEGER PYK,PYCHGE,PYCOMP
25988 C...Local array and data.
25989  dimension xpga(-6:6)
25990  DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/
25991 
25992 C...Reset output.
25993  DO 100 kfl=-6,6
25994  xpga(kfl)=0d0
25995  100 CONTINUE
25996 
25997 C...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 
26001 C...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 
26006 C...Also fill for antiquarks.
26007  DO 110 kf=1,5
26008  xpga(-kf)=xpga(kf)
26009  110 CONTINUE
26010 
26011  RETURN
26012  END
26013 
26014 C*********************************************************************
26015 
26016 C...PYPDPI
26017 C...Gives pi+ parton distribution according to two different
26018 C...parametrizations.
26019 
26020  SUBROUTINE pypdpi(X,Q2,XPPI)
26021 
26022 C...Double precision and integer declarations.
26023  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26024  IMPLICIT INTEGER(I-N)
26025  INTEGER PYK,PYCHGE,PYCOMP
26026 C...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/
26031 C...Local arrays.
26032  dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)
26033 
26034 C...The following data lines are coefficients needed in the
26035 C...Owens pion parton distribution parametrizations, see below.
26036 C...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/
26045 C...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/
26054 C...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/
26063 C...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 
26073 C...Euler's beta function, requires ordinary Gamma function
26074  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
26075 
26076 C...Reset output array.
26077  DO 100 kfl=-6,6
26078  xppi(kfl)=0d0
26079  100 CONTINUE
26080 
26081  IF(mstp(53).LE.2) THEN
26082 C...Pion parton distributions from Owens.
26083 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
26084 
26085 C...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 
26097 C...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 
26111 C...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 
26122 C...Leading order pion parton distributions from Gluck, Reya and Vogt.
26123 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
26124 C...10^-5 < x < 1.
26125  ELSE
26126 
26127 C...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 
26139 C...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 
26169 C...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 
26186 C*********************************************************************
26187 
26188 C...PYPDPR
26189 C...Gives proton parton distributions according to a few different
26190 C...parametrizations.
26191 
26192  SUBROUTINE pypdpr(X,Q2,XPPR)
26193 
26194 C...Double precision and integer declarations.
26195  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26196  IMPLICIT INTEGER(I-N)
26197  INTEGER PYK,PYCHGE,PYCOMP
26198 C...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/
26204 C...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 
26209 C...Reset output array.
26210  DO 100 kfl=-6,6
26211  xppr(kfl)=0d0
26212  100 CONTINUE
26213 
26214 C...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
26225 C...Interface to the CTEQ 3 parton distributions.
26226  qrt=sqrt(max(1d0,q2l))
26227 
26228 C...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
26240 C...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 
26249 C...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
26263 C...Interface to the CTEQ 5L parton distributions.
26264 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
26265 C...freezing x*f(x,Q2) at borders.
26266  qrt=sqrt(max(1d0,min(1d4,q2l)))
26267  xin=max(1d-6,min(1d0,x))
26268 
26269 C...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
26288 C...Interface to the CTEQ 5M1 parton distributions.
26289  qrt=sqrt(max(1d0,min(1d4,q2l)))
26290  xin=max(1d-6,min(1d0,x))
26291 
26292 C...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
26311 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
26312 C...obsolete but offers backwards compatibility.
26313  CALL pypdpo(x,q2l,xppr)
26314 
26315 C...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 
26334 C*********************************************************************
26335 
26336 C...PYCTEQ
26337 C...Gives the CTEQ 3 parton distribution function sets in
26338 C...parametrized form, of October 24, 1994.
26339 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
26340 C...J. Qiu, W.K. Tung and H. Weerts.
26341 
26342  FUNCTION pycteq (ISET, IPRT, X, Q)
26343 
26344 C...Double precision declaration.
26345  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26346  IMPLICIT INTEGER(I-N)
26347 
26348 C...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 
26353 C....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 
26365 C...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 
26372 C...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 
26448 C...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 
26524 C...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 
26601 C...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 
26608 C*********************************************************************
26609 
26610 C...PYGRVL
26611 C...Gives the GRV 94 L (leading order) parton distribution function set
26612 C...in parametrized form.
26613 C...Authors: M. Glueck, E. Reya and A. Vogt.
26614 
26615  SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26616 
26617 C...Double precision declaration.
26618  IMPLICIT DOUBLE PRECISION (a - z)
26619 
26620 C...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 
26628 C...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 
26638 C...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 
26648 C...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 
26658 C...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 
26672 C...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 
26684 C...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 
26696 C...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 
26708 C...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 
26725 C*********************************************************************
26726 
26727 C...PYGRVM
26728 C...Gives the GRV 94 M (MSbar) parton distribution function set
26729 C...in parametrized form.
26730 C...Authors: M. Glueck, E. Reya and A. Vogt.
26731 
26732  SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26733 
26734 C...Double precision declaration.
26735  IMPLICIT DOUBLE PRECISION (a - z)
26736 
26737 C...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 
26745 C...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 
26755 C...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 
26765 C...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 
26775 C...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 
26789 C...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 
26801 C...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 
26813 C...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 
26825 C...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 
26841 C*********************************************************************
26842 
26843 C...PYGRVD
26844 C...Gives the GRV 94 D (DIS) parton distribution function set
26845 C...in parametrized form.
26846 C...Authors: M. Glueck, E. Reya and A. Vogt.
26847 
26848  SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
26849 
26850 C...Double precision declaration.
26851  IMPLICIT DOUBLE PRECISION (a - z)
26852 
26853 C...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 
26861 C...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 
26871 C...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 
26881 C...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 
26891 C...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 
26905 C...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 
26917 C...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 
26929 C...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 
26941 C...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 
26957 C*********************************************************************
26958 
26959 C...PYGRVV
26960 C...Auxiliary for the GRV 94 parton distribution functions
26961 C...for u and d valence and d-u sea.
26962 C...Authors: M. Glueck, E. Reya and A. Vogt.
26963 
26964  FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)
26965 
26966 C...Double precision declaration.
26967  IMPLICIT DOUBLE PRECISION (a - z)
26968 
26969 C...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 
26977 C*********************************************************************
26978 
26979 C...PYGRVW
26980 C...Auxiliary for the GRV 94 parton distribution functions
26981 C...for d+u sea and gluon.
26982 C...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 
26986 C...Double precision declaration.
26987  IMPLICIT DOUBLE PRECISION (a - z)
26988 
26989 C...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 
26997 C*********************************************************************
26998 
26999 C...PYGRVS
27000 C...Auxiliary for the GRV 94 parton distribution functions
27001 C...for s, c and b sea.
27002 C...Authors: M. Glueck, E. Reya and A. Vogt.
27003 
27004  FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
27005 
27006 C...Double precision declaration.
27007  IMPLICIT DOUBLE PRECISION (a - z)
27008 
27009 C...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 
27022 C*********************************************************************
27023 
27024 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
27025 C...in Parametrized Form
27026 C... September 15, 1999
27027 C
27028 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
27029 C... CTEQ5 PPARTON DISTRIBUTIONS"
27030 C...hep-ph/9903282
27031 
27032 C...The CTEQ5M1 set given here is an updated version of the original
27033 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
27034 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
27035 C...almost all applications.
27036 C...The improvement is in the QCD evolution which is now more
27037 C...accurate, and which agrees completely with the benchmark work
27038 C...of the HERA 96/97 Workshop.
27039 C...The differences between the parametrized and the corresponding
27040 C...table versions (on which it is based) are of similar order as
27041 C...between the two version.
27042 
27043 C...!! Because accurate parametrizations over a wide range of (x,Q)
27044 C...is hard to obtain, only the most widely used sets CTEQ5M and
27045 C...CTEQ5L are available in parametrized form for now.
27046 
27047 C...These parametrizations were obtained by Jon Pumplin.
27048 
27049 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
27050 C -------------------------------------------------------------------
27051 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
27052 C 3 CTEQ5L Leading Order 0.127 192 146
27053 C -------------------------------------------------------------------
27054 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
27055 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
27056 C...calibration.
27057 
27058 C...The two Iset value are adopted to agree with the standard table
27059 C...versions.
27060 
27061 C...Range of validity:
27062 C...The range of (x, Q) covered by this parametrization of the QCD
27063 C...evolved parton distributions is 1E-6 < x < 1 ;
27064 C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
27065 C...data only in a subset of that region; and the assumed DGLAP
27066 C...evolution is unlikely to be valid for all of it either.
27067 
27068 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
27069 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
27070 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
27071 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
27072 
27073 C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
27074 
27075 C...PYCT5L
27076 C...Auxiliary function for parametrization of CTEQ5L.
27077 C...Author: J. Pumplin 9/99.
27078 
27079  FUNCTION pyct5l(IFL,X,Q)
27080 
27081 C...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 
27322 C...Include threshold factor.
27323  pyct5l = pyct5l * (1.d0 - qmavec(ifl)/q)
27324 
27325  RETURN
27326  END
27327 
27328 C*********************************************************************
27329 
27330 C...PYCT5M
27331 C...Auxiliary function for parametrization of CTEQ5M1.
27332 C...Author: J. Pumplin 9/99.
27333 
27334  FUNCTION pyct5m(IFL,X,Q)
27335 
27336 C...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 
27577 C...Include threshold factor.
27578  pyct5m = pyct5m * (1.d0 - qmavec(ifl)/q)
27579 
27580  RETURN
27581  END
27582 
27583 C*********************************************************************
27584 
27585 C...PYPDPO
27586 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
27587 C...a few older parametrizations, now obsolete but convenient for
27588 C...backwards checks.
27589 
27590  SUBROUTINE pypdpo(X,Q2,XPPR)
27591 
27592 C...Double precision and integer declarations.
27593  IMPLICIT DOUBLE PRECISION(a-h, o-z)
27594  IMPLICIT INTEGER(I-N)
27595  INTEGER PYK,PYCHGE,PYCOMP
27596 C...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 
27606 C...The following data lines are coefficients needed in the
27607 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
27608 C...parametrizations, see below.
27609 C...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/
27611 C...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/
27638 C...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/
27665 C...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/
27692 C...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/
27719 C...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/
27746 C...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/
27773 C...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/
27800 C...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 
27828 C...The following data lines are coefficients needed in the
27829 C...Duke, Owens proton structure function parametrizations, see below.
27830 C...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/
27839 C...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/
27848 C...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/
27857 C...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/
27866 C...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 
27876 C...Euler's beta function, requires ordinary Gamma function
27877  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
27878 
27879 C...Leading order proton parton distributions from Gluck, Reya and Vogt.
27880 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
27881 C...10^-5 < x < 1.
27882  IF(mstp(51).EQ.11) THEN
27883 
27884 C...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 
27891 C...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 
27927 C...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 
27940 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
27941 C...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 
27944 C...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 
27957 C...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 
27971 C...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 
27982 C...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 
27993 C...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 
28016 C...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 
28041 C...Proton parton distributions from Duke, Owens.
28042 C...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 
28045 C...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 
28052 C...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 
28067 C...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 
28083 C*********************************************************************
28084 
28085 C...PYHFTH
28086 C...Gives threshold attractive/repulsive factor for heavy flavour
28087 C...production.
28088 
28089  FUNCTION pyhfth(SH,SQM,FRATT)
28090 
28091 C...Double precision and integer declarations.
28092  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28093  IMPLICIT INTEGER(I-N)
28094  INTEGER PYK,PYCHGE,PYCOMP
28095 C...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 
28101 C...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 
28113 C...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 
28124 C*********************************************************************
28125 
28126 C...PYSPLI
28127 C...Splits a hadron remnant into two (partons or hadron + parton)
28128 C...in case it is more complicated than just a quark or a diquark.
28129 
28130  SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
28131 
28132 C...Double precision and integer declarations.
28133  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28134  IMPLICIT INTEGER(I-N)
28135  INTEGER PYK,PYCHGE,PYCOMP
28136 C...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/
28141 C...Local array.
28142  dimension kfl(3)
28143 
28144 C...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 
28169 C...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 
28187 C...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 
28200 C...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 
28208 C...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 
28248 C...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 
28306 C...Add on correct sign for result.
28307  kflch=kflch*kfs
28308  kflsp=kflsp*kfs
28309 
28310  RETURN
28311  END
28312 
28313 C*********************************************************************
28314 
28315 C...PYGAMM
28316 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
28317 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
28318 C...(Dover, 1965) 6.1.36.
28319 
28320  FUNCTION pygamm(X)
28321 
28322 C...Double precision and integer declarations.
28323  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28324  IMPLICIT INTEGER(I-N)
28325  INTEGER PYK,PYCHGE,PYCOMP
28326 C...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 
28351 C***********************************************************************
28352 
28353 C...PYWAUX
28354 C...Calculates real and imaginary parts of the auxiliary functions W1
28355 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
28356 C...der Bij, Nucl. Phys. B297 (1988) 221.
28357 
28358  SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)
28359 
28360 C...Double precision and integer declarations.
28361  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28362  IMPLICIT INTEGER(I-N)
28363  INTEGER PYK,PYCHGE,PYCOMP
28364 C...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 
28389 C***********************************************************************
28390 
28391 C...PYI3AU
28392 C...Calculates real and imaginary parts of the auxiliary function I3;
28393 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
28394 C...Nucl. Phys. B297 (1988) 221.
28395 
28396  SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)
28397 
28398 C...Double precision and integer declarations.
28399  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28400  IMPLICIT INTEGER(I-N)
28401  INTEGER PYK,PYCHGE,PYCOMP
28402 C...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 
28499 C***********************************************************************
28500 
28501 C...PYSPEN
28502 C...Calculates real and imaginary part of Spence function; see
28503 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
28504 
28505  FUNCTION pyspen(XREIN,XIMIN,IREIM)
28506 
28507 C...Double precision and integer declarations.
28508  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28509  IMPLICIT INTEGER(I-N)
28510  INTEGER PYK,PYCHGE,PYCOMP
28511 C...Commonblocks.
28512  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28513  SAVE /pydat1/
28514 C...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 
28594 C***********************************************************************
28595 
28596 C...PYQQBH
28597 C...Calculates the matrix element for the processes
28598 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
28599 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
28600 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
28601 
28602  SUBROUTINE pyqqbh(WTQQBH)
28603 
28604 C...Double precision and integer declarations.
28605  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28606  IMPLICIT INTEGER(I-N)
28607  INTEGER PYK,PYCHGE,PYCOMP
28608 C...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/
28615 C...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 
28620 C...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 
28629 C...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 
28650 C...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 
28668 C...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 
28680 C...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 
28697 C...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 
28721 C...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 
28962 C...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 
28972 C...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
28983 C...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 
28995 C...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 
29005 C*********************************************************************
29006 
29007 C...PYMSIN
29008 C...Initializes supersymmetry: finds sparticle masses and
29009 C...branching ratios and stores this information.
29010 C...AUTHOR: STEPHEN MRENNA
29011 
29012  SUBROUTINE pymsin
29013 
29014 C...Double precision and integer declarations.
29015  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29016  IMPLICIT INTEGER(I-N)
29017  INTEGER PYK,PYCHGE,PYCOMP
29018 C...Parameter statement to help give large particle numbers.
29019  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29020 C...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 
29033 C...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 
29062 C...Do nothing if SUSY not requested.
29063  imssm=imss(1)
29064  IF(imssm.EQ.0) RETURN
29065 
29066 C...Save copy of MWID(KC) and MDCY(KC,1) values before
29067 C...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 
29078 C...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 
29088 C...First part of routine: set masses and couplings.
29089 
29090 C...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 
29098 C...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 
29109 C...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 
29142 C...Alternatively derive masses from SUGRA relations.
29143  ELSEIF(imssm.EQ.2) THEN
29144  CALL pyapps
29145  ENDIF
29146 
29147 C...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 
29221 C...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 
29233 C...Fix the neutralino--chargino--gluino sector.
29234  CALL pyinom
29235 
29236 C...Fix the Higgs sector.
29237  CALL pyhggm(alfa)
29238 
29239 C...Choose the Gunion-Haber convention.
29240  alfa=-alfa
29241  rmss(18)=alfa
29242 
29243 C...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 
29271 C...Set up the Higgs couplings - needed here since initialization
29272 C...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
29286 C...tanb (used for H+)
29287  paru(141)=tanb
29288 
29289 C...Firstly: h
29290 C...Coupling to d-type quarks
29291  paru(161)=sina/cosb
29292 C...Coupling to u-type quarks
29293  paru(162)=-cosa/sinb
29294 C...Coupling to leptons
29295  paru(163)=paru(161)
29296 C...Coupling to Z
29297  paru(164)=sbma
29298 C...Coupling to W
29299  paru(165)=paru(164)
29300 
29301 C...Secondly: H
29302 C...Coupling to d-type quarks
29303  paru(171)=-cosa/cosb
29304 C...Coupling to u-type quarks
29305  paru(172)=-sina/sinb
29306 C...Coupling to leptons
29307  paru(173)=paru(171)
29308 C...Coupling to Z
29309  paru(174)=cbma
29310 C...Coupling to W
29311  paru(175)=paru(174)
29312 C...Coupling to h
29313 C 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))
29319 C...Coupling to H+
29320 C...Define later
29321 C 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)
29326 C...Coupling to A
29327 C 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))
29332 C...Coupling to H+
29333  paru(178)=paru(177)-(hhh(5)-hhh(4))/hhh(1)*cbma
29334 C...Thirdly, A
29335 C...Coupling to d-type quarks
29336  paru(181)=tanb
29337 C...Coupling to u-type quarks
29338  paru(182)=1d0/paru(181)
29339 C...Coupling to leptons
29340  paru(183)=paru(181)
29341  paru(184)=0d0
29342  paru(185)=0d0
29343 C...Coupling to Z h
29344  paru(186)=cos(be-al)
29345 C...Coupling to Z H
29346  paru(187)=sin(be-al)
29347  paru(188)=0d0
29348  paru(189)=0d0
29349  paru(190)=0d0
29350 
29351 C...Finally: H+
29352 C...Coupling to W h
29353  paru(195)=cos(be-al)
29354 
29355 C...Tell that all Higgs couplings have been set.
29356  mstp(4)=1
29357 
29358 C...Second part of routine: set decay modes and branching ratios.
29359 
29360 C...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 
29372 C...Loop over sparticle and Higgs species.
29373  pmchi1=pmas(pycomp(ksusy1+22),1)
29374 C...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 
29391 C...Sfermion decays.
29392  IF(i.LE.24) THEN
29393 C...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 
29400 C...Gluino decays.
29401  ELSEIF(i.EQ.25) THEN
29402  CALL pyglui(kf,xlam,idlam,lknt)
29403  IF(i.EQ.ilsp) lknt=0
29404 
29405 C...Neutralino decays.
29406  ELSEIF(i.GE.26.AND.i.LE.29) THEN
29407  CALL pynjdc(kf,xlam,idlam,lknt)
29408 C...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 
29415 C...Chargino decays.
29416  ELSEIF(i.GE.30.AND.i.LE.31) THEN
29417  CALL pycjdc(kf,xlam,idlam,lknt)
29418 
29419 C...Gravitino is stable.
29420  ELSEIF(i.EQ.32) THEN
29421  mdcy(kc,1)=0
29422  mwid(kc)=0
29423 
29424 C...Higgs decays.
29425  ELSEIF(i.GE.33.AND.i.LE.36) THEN
29426 C...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
29443 C...Add the decays to SUSY particles.
29444  CALL pyhext(kf,xlam,idlam,lknt)
29445  ENDIF
29446 C...Zero the branching ratios for use in loop mode
29447 C...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 
29452 C...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 
29460 C...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 
29499 C...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 
29515 C*********************************************************************
29516 
29517 C...PYAPPS
29518 C...Uses approximate analytical formulae to determine the full set of
29519 C...MSSM parameters from SUGRA input.
29520 C...See M. Drees and S.P. Martin, hep-ph/9504124
29521 
29522  SUBROUTINE pyapps
29523 
29524 C...Double precision and integer declarations.
29525  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29526  IMPLICIT INTEGER(I-N)
29527  INTEGER PYK,PYCHGE,PYCOMP
29528 C...Parameter statement to help give large particle numbers.
29529  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29530 C...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
29596 C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
29597 C.....
29598  xmu2=-.5d0*xmz2+(sinb**2*(xm02+.52d0*xmg2-xtop)-
29599  &cosb**2*(xm02+.52d0*xmg2-xbot-xtau/3d0))/(cosb**2-sinb**2)
29600 C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
29601 C.....
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 
29642 C*********************************************************************
29643 
29644 C...PYRNMQ
29645 C...Determines the running mass of quarks.
29646 
29647  FUNCTION pyrnmq(ID,DTERM)
29648 
29649 C...Double precision and integer declarations.
29650  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29651  IMPLICIT INTEGER(I-N)
29652  INTEGER PYK,PYCHGE,PYCOMP
29653 C...Commonblock.
29654  common/pymssm/imss(0:99),rmss(0:99)
29655  SAVE /pymssm/
29656 
29657 C...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 
29728 C*********************************************************************
29729 
29730 C...PYRNMT
29731 C...Determines the running mass of the top quark.
29732 
29733  FUNCTION pyrnmt(XMT)
29734 
29735 C...Double precision and integer declarations.
29736  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29737  IMPLICIT INTEGER(I-N)
29738  INTEGER PYK,PYCHGE,PYCOMP
29739 C...Commonblock.
29740  common/pymssm/imss(0:99),rmss(0:99)
29741  SAVE /pymssm/
29742 
29743 C...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 
29800 C*********************************************************************
29801 
29802 C...PYTHRG
29803 C...Calculates the mass eigenstates of the third generation sfermions.
29804 C...Created: 5-31-96
29805 
29806  SUBROUTINE pythrg
29807 
29808 C...Double precision and integer declarations.
29809  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29810  IMPLICIT INTEGER(I-N)
29811  INTEGER PYK,PYCHGE,PYCOMP
29812 C...Parameter statement to help give large particle numbers.
29813  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29814 C...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 
29822 C...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 
29846 C...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
29868 C......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
29881 C 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
29909 C......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
29916 C 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
29935 C......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
30050 C...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 
30067 C*********************************************************************
30068 
30069 C...PYINOM
30070 C...Finds the mass eigenstates and mixing matrices for neutralinos
30071 C...and charginos.
30072 
30073  SUBROUTINE pyinom
30074 
30075 C...Double precision and integer declarations.
30076  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30077  IMPLICIT INTEGER(I-N)
30078  INTEGER PYK,PYCHGE,PYCOMP
30079 C...Parameter statement to help give large particle numbers.
30080  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30081 C...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 
30089 C...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
30113 C...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 
30141 C...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 
30214 C...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 
30250 C...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 
30305 C*********************************************************************
30306 
30307 C...PYRNM3
30308 C...Calculates the running of M3, the SU(3) gluino mass parameter.
30309 
30310  FUNCTION pyrnm3(RGUT)
30311 
30312 C...Double precision and integer declarations.
30313  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30314  IMPLICIT INTEGER(I-N)
30315  INTEGER PYK,PYCHGE,PYCOMP
30316 
30317 C...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 
30373 C*********************************************************************
30374 
30375 C...PYEIG4
30376 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
30377 C...Specific application: mixing in neutralino sector.
30378 
30379  SUBROUTINE pyeig4(A,W,Z)
30380 
30381 C...Double precision and integer declarations.
30382  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30383  IMPLICIT INTEGER(I-N)
30384  INTEGER PYK,PYCHGE,PYCOMP
30385 
30386 C...Arrays: in call and local.
30387  dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)
30388 
30389 C...Coefficients of fourth-degree equation from matrix.
30390 C...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 
30413 C...Coefficients of third-degree equation needed for
30414 C...separation into two second-degree equations.
30415 C...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 
30423 C...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 
30435 C...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 
30450 C...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 
30460 C...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 
30470 C...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 
30481 C...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 
30495 C...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 
30510 C...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 
30521 C...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 
30532 C*********************************************************************
30533 
30534 C...PYHGGM
30535 C...Determines the Higgs boson mass spectrum using several inputs.
30536 
30537  SUBROUTINE pyhggm(ALPHA)
30538 
30539 C...Double precision and integer declarations.
30540  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30541  IMPLICIT INTEGER(I-N)
30542  INTEGER PYK,PYCHGE,PYCOMP
30543 C...Parameter statement to help give large particle numbers.
30544  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30545 C...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 
30552 C...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 
30627 C*********************************************************************
30628 
30629 C...PYSUBH
30630 C...This routine computes the renormalization group improved
30631 C...values of Higgs masses and couplings in the MSSM.
30632 
30633 C...Program based on the work by M. Carena, J.R. Espinosa,
30634 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
30635 
30636 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
30637 C...All masses in GeV units. MA is the CP-odd Higgs mass,
30638 C...MTOP is the physical top mass, MQ and MUR are the soft
30639 C...supersymmetry breaking mass parameters of left handed
30640 C...and right handed stops respectively, AU and AD are the
30641 C...stop and sbottom trilinear soft breaking terms,
30642 C...respectively, and MU is the supersymmetric
30643 C...Higgs mass parameter. We use the conventions from
30644 C...the physics report of Haber and Kane: left right
30645 C...stop mixing term proportional to (AU - MU/TANB)
30646 C...We use as input TANB defined at the scale MTOP
30647 
30648 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
30649 C...where MH and HM are the lightest and heaviest CP-even
30650 C...Higgs masses, MHCH is the charged Higgs mass and
30651 C...ALPHA is the Higgs mixing angle
30652 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
30653 
30654 C...Range of validity:
30655 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
30656 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
30657 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
30658 C...are the sbottom mass eigenvalues, respectively. This
30659 C...range automatically excludes the existence of tachyons.
30660 C...For the charged Higgs mass computation, the method is
30661 C...valid if
30662 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
30663 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
30664 C...where M_SUSY**2 is the average of the squared stop mass
30665 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
30666 C...masses have been assumed to be of order of the stop ones
30667 C...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 
30672 C...Double precision and integer declarations.
30673  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30674  IMPLICIT INTEGER(I-N)
30675  INTEGER PYK,PYCHGE,PYCOMP
30676 C...Parameter statement to help give large particle numbers.
30677  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30678 C...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 
30684 C...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 
30715 C...MBOTTOM(MTOP) = 3. GEV
30716  xmb = 3d0
30717  alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*
30718  &log(xmtop**2/xmz**2))
30719 
30720 C...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
30726 C...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 
30858 C*********************************************************************
30859 
30860 C...PYPOLE
30861 C...This subroutine computes the CP-even higgs and CP-odd pole
30862 c...Higgs masses and mixing angles.
30863 
30864 C...Program based on the work by M. Carena, M. Quiros
30865 C...and C.E.M. Wagner, "Effective potential methods and
30866 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
30867 
30868 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
30869 C...AT,AB,MU
30870 C...where MCHI is the largest chargino mass, MA is the running
30871 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
30872 C...expectaion values at the scale MTOP, MQ is the third generation
30873 C...left handed squark mass parameter, MUR is the third generation
30874 C...right handed stop mass parameter, MDR is the third generation
30875 C...right handed sbottom mass parameter, MTOP is the pole top quark
30876 C...mass; AT,AB are the soft supersymmetry breaking trilinear
30877 C...couplings of the stop and sbottoms, respectively, and MU is the
30878 C...supersymmetric mass parameter
30879 
30880 C...The parameter IHIGGS=0,1,2,3 corresponds to the
30881 c...number of Higgses whose pole mass is computed
30882 c...by the subroutine PYVACU(...). If IHIGGS=0 only running
30883 c...masses are given, what makes the running of the program
30884 c...much faster and it is quite generally a good approximation
30885 c...(for a theoretical discussion see ref. below).
30886 c...If IHIGGS=1, only the pole
30887 c...mass for H is computed. If IHIGGS=2, then h and H, and
30888 c...if IHIGGS=3, then h,H,A polarizations are computed
30889 
30890 C...Output: MH and MHP which are the lightest CP-even Higgs running
30891 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
30892 C...Higgs running and pole masses, repectively; SA and CA are the
30893 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
30894 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
30895 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
30896 C...the value of TANB at the CP-odd Higgs mass scale
30897 
30898 C...This subroutine makes use of CERN library subroutine
30899 C...integration package, which makes the computation of the
30900 C...pole Higgs masses somewhat faster. We thank P. Janot for this
30901 C...improvement. Those who are not able to call the CERN
30902 C...libraries, please use the subroutine SUBHPOLE2.F, which
30903 C...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 
30908 C...Double precision and integer declarations.
30909  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30910  IMPLICIT INTEGER(I-N)
30911 
30912 C...Parameters.
30913  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30914  INTEGER PYK,PYCHGE,PYCOMP
30915 
30916 C...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 
30932 C 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 
30961 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30962 C...STOP EIGENVALUES CALCULATION
30963 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31032 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31033 C...STARTING OF LIGHT HIGGS
31034 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31105 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31106 C...END OF LIGHT HIGGS
31107 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31108 
31109  250 IF(ihiggs.EQ.1) GOTO 490
31110 
31111 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31112 C... STARTING OF HEAVY HIGGS
31113 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31186 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31187 C... END OF HEAVY HIGGS
31188 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31189 
31190  IF(ihiggs.EQ.2) GOTO 490
31191 
31192 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31193 C...BEGINNING OF PSEUDOSCALAR HIGGS
31194 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31253 C...END OF PSEUDOSCALAR HIGGS
31254 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31268 C*********************************************************************
31269 
31270 C...PYVACU
31271 C...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 
31277 C...Double precision and integer declarations.
31278  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31279  IMPLICIT INTEGER(I-N)
31280 C...Parameters.
31281  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31282  INTEGER PYK,PYCHGE,PYCOMP
31283 
31284 C...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 
31300 C 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 
31329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31330 C...STOP EIGENVALUES CALCULATION
31331 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31400 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31401 C...STARTING OF LIGHT HIGGS
31402 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31474 C...END OF LIGHT HIGGS
31475 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31476 
31477  250 IF(ihiggs.EQ.1) GOTO 490
31478 
31479 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31480 C... STARTING OF HEAVY HIGGS
31481 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31555 C... END OF HEAVY HIGGS
31556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31557 
31558  IF(ihiggs.EQ.2) GOTO 490
31559 
31560 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31561 C...BEGINNING OF PSEUDOSCALAR HIGGS
31562 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31620 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31621 C...END OF PSEUDOSCALAR HIGGS
31622 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31636 C*********************************************************************
31637 
31638 C...PYRGHM
31639 C...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 
31644 C...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 
31650 C...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 
31662 C...MBOTTOM(XMT) = 3. GEV
31663  xmb = 3d0
31664  alp3 = alp3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alp3z*
31665  &log(xmt**2/xmz**2))
31666 
31667 C...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 
31749 C...Defined now in PYSUBH
31750 C HHH(1)=XLAM1
31751 C HHH(2)=XLAM2
31752 C HHH(3)=XLAM3
31753 C HHH(4)=XLAM4
31754 C HHH(5)=XLAM5
31755 C HHH(6)=XLAM6
31756 C 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 
31768 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31769 C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
31770 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31794 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31795 C...END OF CHARGINOS/NEUTRALINOS
31796 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
31825 C*********************************************************************
31826 
31827 C...PYGFXX
31828 C...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 
31833 C...Double precision and integer declarations.
31834  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31835  IMPLICIT INTEGER(I-N)
31836  INTEGER PYK,PYCHGE,PYCOMP
31837 
31838 C...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 
31843 C...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 
31962 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
31963 C...D-TERMS
31964 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 
32068 C*********************************************************************
32069 
32070 C...PYFINT
32071 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
32072 
32073  FUNCTION pyfint(A,B,C)
32074 
32075 C...Double precision and integer declarations.
32076  IMPLICIT DOUBLE PRECISION(a-h, o-z)
32077  IMPLICIT INTEGER(I-N)
32078  INTEGER PYK,PYCHGE,PYCOMP
32079 C...Commonblock.
32080  common/pyints/xxm(20)
32081  SAVE/pyints/
32082 
32083 C...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 
32097 C*********************************************************************
32098 
32099 C...PYFISB
32100 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
32101 
32102  FUNCTION pyfisb(X)
32103 
32104 C...Double precision and integer declarations.
32105  IMPLICIT DOUBLE PRECISION(a-h, o-z)
32106  IMPLICIT INTEGER(I-N)
32107  INTEGER PYK,PYCHGE,PYCOMP
32108 C...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 
32118 C*********************************************************************
32119 
32120 C...PYSFDC
32121 C...Calculates decays of sfermions.
32122 
32123  SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)
32124 
32125 C...Double precision and integer declarations.
32126  IMPLICIT DOUBLE PRECISION(a-h, o-z)
32127  IMPLICIT INTEGER(I-N)
32128  INTEGER PYK,PYCHGE,PYCOMP
32129 C...Parameter statement to help give large particle numbers.
32130  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
32131 C...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 
32139 C...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 
32167 C...COUNT THE NUMBER OF DECAY MODES
32168  lknt=0
32169 
32170 C...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 
32182 C...KCIN
32183  kcin=pycomp(kfin)
32184 C...ILR is 1 for left and 2 for right.
32185  ilr=kfin/ksusy1
32186 C...IFL is matching non-SUSY flavour.
32187  ifl=mod(kfin,ksusy1)
32188 C...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 
32215 C...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 
32238 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
32239 
32240 C...CHARGED DECAYS:
32241  DO 100 ix=1,2
32242 C...DI -> U CHI1-,CHI2-
32243  IF(idu.EQ.1) THEN
32244  xmfp=pmas(ifl+1,1)
32245  xmf =pmas(ifl,1)
32246 C...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 
32291 C...F1 -> F` CHI
32292  IF(ilr.EQ.1) THEN
32293  ca=al
32294  cb=bl
32295 C...F2 -> F` CHI
32296  ELSE
32297  ca=ar
32298  cb=br
32299  ENDIF
32300  lknt=lknt+1
32301  xl=pylamf(xmi2,xma2,xmb2)
32302 C...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 
32316 C...NEUTRAL DECAYS
32317  DO 110 ix=1,4
32318 C...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 
32356 C...F1 -> F CHI
32357  IF(ilr.EQ.1) THEN
32358  ca=al
32359  cb=bl
32360 C...F2 -> F CHI
32361  ELSE
32362  ca=ar
32363  cb=br
32364  ENDIF
32365  lknt=lknt+1
32366  xl=pylamf(xmi2,xma2,xmb2)
32367 C...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 
32376 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
32377 C...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 
32513 C...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 
32566 C...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
32582 C...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)
32588 C...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
32602 C...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)
32608 C...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
32638 C...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)
32644 C...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
32658 C...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)
32664 C...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 
32689 C...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)
32703 C...F1 -> F CHI
32704  IF(ilr.EQ.1) THEN
32705  ca=al
32706  cb=bl
32707 C...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 
32724 C...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
32727 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
32728 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
32729 C...M*M = C1**2 * G**2/(16PI**2)
32730 C...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 
32751 C*********************************************************************
32752 
32753 C...PYGLUI
32754 C...Calculates gluino decay modes.
32755 
32756  SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)
32757 
32758 C...Double precision and integer declarations.
32759  IMPLICIT DOUBLE PRECISION(a-h, o-z)
32760  IMPLICIT INTEGER(I-N)
32761  INTEGER PYK,PYCHGE,PYCOMP
32762 C...Parameter statement to help give large particle numbers.
32763  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
32764 C...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 
32773 C...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 
32801 C...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 
32822 C...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 
32838 C...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
32847 C...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)
32852 C...F1 -> F CHI
32853  IF(ilr.EQ.1) THEN
32854  ca=al
32855  cb=bl
32856 C...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 
32879 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
32880 C...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
32897 C...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
32930 C...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
32955 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
32956 C...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 
32971 C...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 
33050 C*********************************************************************
33051 
33052 C...PYTECM
33053 C...Finds the s-hat dependent eigenvalues of the inverse propagator
33054 C...matrix for gamma, Z, technirho, and techniomega to optimize the
33055 C...phase space generation.
33056 
33057  SUBROUTINE pytecm(S1,S2)
33058 
33059 C...Double precision and integer declarations.
33060  IMPLICIT DOUBLE PRECISION(a-h, o-z)
33061  IMPLICIT INTEGER(I-N)
33062  INTEGER PYK,PYCHGE,PYCOMP
33063 C...Parameter statement to help give large particle numbers.
33064  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
33065 C...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 
33071 C...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
33106 CCCCCCCC
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
33119 CCCC
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 
33146 C*********************************************************************
33147 
33148 C...PYEIGC
33149 C...Finds eigenvalues of a general complex matrix
33150 
33151  SUBROUTINE pyeicg(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
33152 C
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)
33156 C
33157 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
33158 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
33159 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
33160 C OF A COMPLEX GENERAL MATRIX.
33161 C
33162 C ON INPUT
33163 C
33164 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
33165 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33166 C DIMENSION STATEMENT.
33167 C
33168 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
33169 C
33170 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33171 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
33172 C
33173 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
33174 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
33175 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
33176 C
33177 C ON OUTPUT
33178 C
33179 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33180 C RESPECTIVELY, OF THE EIGENVALUES.
33181 C
33182 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33183 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
33184 C
33185 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
33186 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
33187 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
33188 C
33189 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
33190 C
33191 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33192 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33193 C
33194 C THIS VERSION DATED AUGUST 1983.
33195 C
33196 C ------------------------------------------------------------------
33197 C
33198  IF (n .LE. nm) GO TO 10
33199  ierr = 10 * n
33200  GO TO 50
33201 C
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
33205 C .......... FIND EIGENVALUES ONLY ..........
33206  CALL comqr(nm,n,is1,is2,ar,ai,wr,wi,ierr)
33207  GO TO 50
33208 C .......... 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)
33215 C
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
33219 C
33220 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33221 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
33222 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33223 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33224 C
33225 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
33226 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
33227 C BALANCED MATRIX DETERMINED BY CBAL.
33228 C
33229 C ON INPUT
33230 C
33231 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33232 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33233 C DIMENSION STATEMENT.
33234 C
33235 C N IS THE ORDER OF THE MATRIX.
33236 C
33237 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
33238 C
33239 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
33240 C AND SCALING FACTORS USED BY CBAL.
33241 C
33242 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
33243 C
33244 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33245 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
33246 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
33247 C
33248 C ON OUTPUT
33249 C
33250 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33251 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
33252 C IN THEIR FIRST M COLUMNS.
33253 C
33254 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33255 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33256 C
33257 C THIS VERSION DATED AUGUST 1983.
33258 C
33259 C ------------------------------------------------------------------
33260 C
33261  IF (m .EQ. 0) GO TO 200
33262  IF (igh .EQ. low) GO TO 120
33263 C
33264  DO 110 i = low, igh
33265  s = scale(i)
33266 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
33267 C IF THE FOREGOING STATEMENT IS REPLACED BY
33268 C 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
33273 C
33274  110 CONTINUE
33275 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
33276 C 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
33283 C
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
33292 C
33293  140 CONTINUE
33294 C
33295  200 RETURN
33296  END
33297  SUBROUTINE cbal(NM,N,AR,AI,LOW,IGH,SCALE)
33298 C
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
33303 C
33304 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
33305 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
33306 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
33307 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
33308 C
33309 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
33310 C EIGENVALUES WHENEVER POSSIBLE.
33311 C
33312 C ON INPUT
33313 C
33314 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33315 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33316 C DIMENSION STATEMENT.
33317 C
33318 C N IS THE ORDER OF THE MATRIX.
33319 C
33320 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33321 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
33322 C
33323 C ON OUTPUT
33324 C
33325 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
33326 C RESPECTIVELY, OF THE BALANCED MATRIX.
33327 C
33328 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
33329 C ARE EQUAL TO ZERO IF
33330 C (1) I IS GREATER THAN J AND
33331 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
33332 C
33333 C SCALE CONTAINS INFORMATION DETERMINING THE
33334 C PERMUTATIONS AND SCALING FACTORS USED.
33335 C
33336 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
33337 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
33338 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
33339 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
33340 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
33341 C = D(J,J) J = LOW,...,IGH
33342 C = P(J) J = IGH+1,...,N.
33343 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
33344 C THEN 1 TO LOW-1.
33345 C
33346 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
33347 C
33348 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
33349 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
33350 C K,L HAVE BEEN REVERSED.)
33351 C
33352 C ARITHMETIC IS REAL THROUGHOUT.
33353 C
33354 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33355 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33356 C
33357 C THIS VERSION DATED AUGUST 1983.
33358 C
33359 C ------------------------------------------------------------------
33360 C
33361  radix = 16.0d0
33362 C
33363  b2 = radix * radix
33364  k = 1
33365  l = n
33366  GO TO 100
33367 C .......... IN-LINE PROCEDURE FOR ROW AND
33368 C COLUMN EXCHANGE ..........
33369  20 scale(m) = j
33370  IF (j .EQ. m) GO TO 50
33371 C
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
33380 C
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
33389 C
33390  50 GO TO (80,130), iexc
33391 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
33392 C AND PUSH THEM DOWN ..........
33393  80 IF (l .EQ. 1) GO TO 280
33394  l = l - 1
33395 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
33396  100 DO 120 jj = 1, l
33397  j = l + 1 - jj
33398 C
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
33403 C
33404  m = l
33405  iexc = 1
33406  GO TO 20
33407  120 CONTINUE
33408 C
33409  GO TO 140
33410 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
33411 C AND PUSH THEM LEFT ..........
33412  130 k = k + 1
33413 C
33414  140 DO 170 j = k, l
33415 C
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
33420 C
33421  m = k
33422  iexc = 2
33423  GO TO 20
33424  170 CONTINUE
33425 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
33426  DO 180 i = k, l
33427  180 scale(i) = 1.0d0
33428 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
33429  190 noconv = .false.
33430 C
33431  DO 270 i = k, l
33432  c = 0.0d0
33433  r = 0.0d0
33434 C
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
33440 C .......... 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
33454 C .......... 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.
33459 C
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
33464 C
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
33469 C
33470  270 CONTINUE
33471 C
33472  IF (noconv) GO TO 190
33473 C
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
33480 C
33481 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
33482 C
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)
33495 C
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
33500 C
33501 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33502 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
33503 C AND WILKINSON.
33504 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
33505 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33506 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33507 C
33508 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
33509 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
33510 C
33511 C ON INPUT
33512 C
33513 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33514 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33515 C DIMENSION STATEMENT.
33516 C
33517 C N IS THE ORDER OF THE MATRIX.
33518 C
33519 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33520 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33521 C SET LOW=1, IGH=N.
33522 C
33523 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33524 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33525 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
33526 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
33527 C THE REDUCTION BY CORTH, IF PERFORMED.
33528 C
33529 C ON OUTPUT
33530 C
33531 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
33532 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
33533 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
33534 C EIGENVECTORS IS TO BE PERFORMED.
33535 C
33536 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33537 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33538 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33539 C FOR INDICES IERR+1,...,N.
33540 C
33541 C IERR IS SET TO
33542 C ZERO FOR NORMAL RETURN,
33543 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33544 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33545 C
33546 C CALLS CDIV FOR COMPLEX DIVISION.
33547 C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33548 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33549 C
33550 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33551 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33552 C
33553 C THIS VERSION DATED AUGUST 1983.
33554 C
33555 C ------------------------------------------------------------------
33556 C
33557  ierr = 0
33558  IF (low .EQ. igh) GO TO 180
33559 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33560  l = low + 1
33561 C
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
33570 C
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
33576 C
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
33582 C
33583  170 CONTINUE
33584 C .......... 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
33590 C
33591  en = igh
33592  tr = 0.0d0
33593  ti = 0.0d0
33594  itn = 30*n
33595 C .......... SEARCH FOR NEXT EIGENVALUE ..........
33596  220 IF (en .LT. low) GO TO 1001
33597  its = 0
33598  enm1 = en - 1
33599 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33600 C 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
33609 C .......... 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
33628 C .......... FORM EXCEPTIONAL SHIFT ..........
33629  320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
33630  si = 0.0d0
33631 C
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
33636 C
33637  tr = tr + sr
33638  ti = ti + si
33639  its = its + 1
33640  itn = itn - 1
33641 C .......... REDUCE TO TRIANGLE (ROWS) ..........
33642  lp1 = l + 1
33643 C
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
33655 C
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
33666 C
33667  500 CONTINUE
33668 C
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
33676 C .......... INVERSE OPERATION (COLUMNS) ..........
33677  540 DO 600 j = lp1, en
33678  xr = wr(j-1)
33679  xi = wi(j-1)
33680 C
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
33693 C
33694  600 CONTINUE
33695 C
33696  IF (si .EQ. 0.0d0) GO TO 240
33697 C
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
33704 C
33705  GO TO 240
33706 C .......... 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
33711 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
33712 C 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)
33717 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
33718 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
33719 C
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
33726 C
33727 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
33728 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
33729 C AND WILKINSON.
33730 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
33731 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
33732 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
33733 C
33734 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
33735 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
33736 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
33737 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
33738 C THIS GENERAL MATRIX TO HESSENBERG FORM.
33739 C
33740 C ON INPUT
33741 C
33742 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
33743 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
33744 C DIMENSION STATEMENT.
33745 C
33746 C N IS THE ORDER OF THE MATRIX.
33747 C
33748 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
33749 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
33750 C SET LOW=1, IGH=N.
33751 C
33752 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
33753 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
33754 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
33755 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
33756 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
33757 C
33758 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
33759 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
33760 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
33761 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
33762 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
33763 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
33764 C ARBITRARY.
33765 C
33766 C ON OUTPUT
33767 C
33768 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
33769 C HAVE BEEN DESTROYED.
33770 C
33771 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
33772 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
33773 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
33774 C FOR INDICES IERR+1,...,N.
33775 C
33776 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
33777 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
33778 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
33779 C THE EIGENVECTORS HAS BEEN FOUND.
33780 C
33781 C IERR IS SET TO
33782 C ZERO FOR NORMAL RETURN,
33783 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
33784 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
33785 C
33786 C CALLS CDIV FOR COMPLEX DIVISION.
33787 C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
33788 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
33789 C
33790 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
33791 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
33792 C
33793 C THIS VERSION DATED OCTOBER 1989.
33794 C
33795 C ------------------------------------------------------------------
33796 C
33797  ierr = 0
33798 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
33799  DO 101 j = 1, n
33800 C
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
33807 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
33808 C FROM THE INFORMATION LEFT BY CORTH ..........
33809  iend = igh - low - 1
33810  IF (iend) 180, 150, 105
33811 C .......... 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
33816 C .......... 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
33819 C
33820  DO 110 k = ip1, igh
33821  ortr(k) = hr(k,i-1)
33822  orti(k) = hi(k,i-1)
33823  110 CONTINUE
33824 C
33825  DO 130 j = i, igh
33826  sr = 0.0d0
33827  si = 0.0d0
33828 C
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
33833 C
33834  sr = sr / norm
33835  si = si / norm
33836 C
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
33841 C
33842  130 CONTINUE
33843 C
33844  140 CONTINUE
33845 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
33846  150 l = low + 1
33847 C
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
33856 C
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
33862 C
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
33868 C
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
33874 C
33875  170 CONTINUE
33876 C .......... 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
33882 C
33883  en = igh
33884  tr = 0.0d0
33885  ti = 0.0d0
33886  itn = 30*n
33887 C .......... SEARCH FOR NEXT EIGENVALUE ..........
33888  220 IF (en .LT. low) GO TO 680
33889  its = 0
33890  enm1 = en - 1
33891 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
33892 C 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
33901 C .......... 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
33920 C .......... FORM EXCEPTIONAL SHIFT ..........
33921  320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
33922  si = 0.0d0
33923 C
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
33928 C
33929  tr = tr + sr
33930  ti = ti + si
33931  its = its + 1
33932  itn = itn - 1
33933 C .......... REDUCE TO TRIANGLE (ROWS) ..........
33934  lp1 = l + 1
33935 C
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
33947 C
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
33958 C
33959  500 CONTINUE
33960 C
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
33970 C
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
33977 C .......... INVERSE OPERATION (COLUMNS) ..........
33978  540 DO 600 j = lp1, en
33979  xr = wr(j-1)
33980  xi = wi(j-1)
33981 C
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
33994 C
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
34005 C
34006  600 CONTINUE
34007 C
34008  IF (si .EQ. 0.0d0) GO TO 240
34009 C
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
34016 C
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
34023 C
34024  GO TO 240
34025 C .......... 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
34032 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
34033 C VECTORS OF UPPER TRIANGULAR FORM ..........
34034  680 norm = 0.0d0
34035 C
34036  DO 720 i = 1, n
34037 C
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
34042 C
34043  IF (n .EQ. 1 .OR. norm .EQ. 0.0d0) GO TO 1001
34044 C .......... 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
34052 C .......... 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
34058 C
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
34063 C
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))
34074 C .......... 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
34084 C
34085  780 CONTINUE
34086 C
34087  800 CONTINUE
34088 C .......... END BACKSUBSTITUTION ..........
34089 C .......... VECTORS OF ISOLATED ROOTS ..........
34090  DO 840 i = 1, n
34091  IF (i .GE. low .AND. i .LE. igh) GO TO 840
34092 C
34093  DO 820 j = i, n
34094  zr(i,j) = hr(i,j)
34095  zi(i,j) = hi(i,j)
34096  820 CONTINUE
34097 C
34098  840 CONTINUE
34099 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
34100 C VECTORS OF ORIGINAL FULL MATRIX.
34101 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
34102  DO 880 jj = low, n
34103  j = n + low - jj
34104  m = min0(j,igh)
34105 C
34106  DO 880 i = low, igh
34107  zzr = 0.0d0
34108  zzi = 0.0d0
34109 C
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
34114 C
34115  zr(i,j) = zzr
34116  zi(i,j) = zzi
34117  880 CONTINUE
34118 C
34119  GO TO 1001
34120 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
34121 C 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)
34126 C
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
34130 C
34131 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
34132 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
34133 C BY MARTIN AND WILKINSON.
34134 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
34135 C
34136 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
34137 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
34138 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
34139 C UNITARY SIMILARITY TRANSFORMATIONS.
34140 C
34141 C ON INPUT
34142 C
34143 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
34144 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
34145 C DIMENSION STATEMENT.
34146 C
34147 C N IS THE ORDER OF THE MATRIX.
34148 C
34149 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
34150 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
34151 C SET LOW=1, IGH=N.
34152 C
34153 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34154 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
34155 C
34156 C ON OUTPUT
34157 C
34158 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
34159 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
34160 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
34161 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
34162 C HESSENBERG MATRIX.
34163 C
34164 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
34165 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
34166 C
34167 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
34168 C
34169 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
34170 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
34171 C
34172 C THIS VERSION DATED AUGUST 1983.
34173 C
34174 C ------------------------------------------------------------------
34175 C
34176  la = igh - 1
34177  kp1 = low + 1
34178  IF (la .LT. kp1) GO TO 200
34179 C
34180  DO 180 m = kp1, la
34181  h = 0.0d0
34182  ortr(m) = 0.0d0
34183  orti(m) = 0.0d0
34184  scale = 0.0d0
34185 C .......... 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))
34188 C
34189  IF (scale .EQ. 0.0d0) GO TO 180
34190  mp = m + igh
34191 C .......... 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
34198 C
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
34207 C
34208  103 ortr(m) = g
34209  ar(m,m-1) = scale
34210 C .......... FORM (I-(U*UT)/H) * A ..........
34211  105 DO 130 j = m, n
34212  fr = 0.0d0
34213  fi = 0.0d0
34214 C .......... 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
34220 C
34221  fr = fr / h
34222  fi = fi / h
34223 C
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
34228 C
34229  130 CONTINUE
34230 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
34231  DO 160 i = 1, igh
34232  fr = 0.0d0
34233  fi = 0.0d0
34234 C .......... 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
34240 C
34241  fr = fr / h
34242  fi = fi / h
34243 C
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
34248 C
34249  160 CONTINUE
34250 C
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
34256 C
34257  200 RETURN
34258  END
34259  SUBROUTINE csroot(XR,XI,YR,YI)
34260  DOUBLE PRECISION XR,XI,YR,YI
34261 C
34262 C (YR,YI) = COMPLEX DSQRT(XR,XI)
34263 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
34264 C
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
34278 C
34279 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
34280 C
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 
34297 C*********************************************************************
34298 
34299 C...PYTBBN
34300 C...Calculates the three-body decay of gluinos into
34301 C...neutralinos and third generation fermions.
34302 
34303  SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)
34304 
34305 C...Double precision and integer declarations.
34306  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34307  IMPLICIT INTEGER(I-N)
34308  INTEGER PYK,PYCHGE,PYCOMP
34309 C...Parameter statement to help give large particle numbers.
34310  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
34311 C...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 
34319 C...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 
34520 C*********************************************************************
34521 
34522 C...PYTBBC
34523 C...Calculates the three-body decay of gluinos into
34524 C...charginos and third generation fermions.
34525 
34526  SUBROUTINE pytbbc(I,NN,XMGLU,GAM)
34527 
34528 C...Double precision and integer declarations.
34529  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34530  IMPLICIT INTEGER(I-N)
34531  INTEGER PYK,PYCHGE,PYCOMP
34532 C...Parameter statement to help give large particle numbers.
34533  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
34534 C...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 
34542 C...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 
34752 C*********************************************************************
34753 
34754 C...PYNJDC
34755 C...Calculates decay widths for the neutralinos (admixtures of
34756 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
34757 
34758 C...Input: KCIN = KF code for particle
34759 C...Output: XLAM = widths
34760 C... IDLAM = KF codes for decay particles
34761 C... IKNT = number of decay channels defined
34762 C...AUTHOR: STEPHEN MRENNA
34763 C...Last change:
34764 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
34765 C...when CHIGAMMA .NE. 0
34766 C...10 FEB 96: Calculate this decay for small tan(beta)
34767 
34768  SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)
34769 
34770 C...Double precision and integer declarations.
34771  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34772  IMPLICIT INTEGER(I-N)
34773  INTEGER PYK,PYCHGE,PYCOMP
34774 C...Parameter statement to help give large particle numbers.
34775  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
34776 C...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 
34785 C...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 
34823 C...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 
34833 C...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 
34856 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
34857  IF(ix.EQ.1.AND.imss(11).EQ.0) GOTO 260
34858 
34859 C...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 
34875 C...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 
34931 C...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 
34950 C...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 
34982 C...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 
35028 C...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 
35069 C...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 
35128 C...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 
35167 C...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
35188 C...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 
35199 C...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 
35223 C...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 
35302 C...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 
35351 C...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 
35378 C...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 
35407 C...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 
35427 C...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
35448 C...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
35464 C...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
35504 C...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 
35542 C*********************************************************************
35543 
35544 C...PYCJDC
35545 C...Calculate decay widths for the charginos (admixtures of
35546 C...charged Wino and charged Higgsino.
35547 
35548 C...Input: KCIN = KF code for particle
35549 C...Output: XLAM = widths
35550 C... IDLAM = KF codes for decay particles
35551 C... IKNT = number of decay channels defined
35552 C...AUTHOR: STEPHEN MRENNA
35553 C...Last change:
35554 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
35555 C...when CHIENU .NE. 0
35556 
35557  SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)
35558 
35559 C...Double precision and integer declarations.
35560  IMPLICIT DOUBLE PRECISION(a-h, o-z)
35561  IMPLICIT INTEGER(I-N)
35562  INTEGER PYK,PYCHGE,PYCOMP
35563 C...Parameter statement to help give large particle numbers.
35564  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
35565 C...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 
35574 C...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 
35612 C...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 
35621 C...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 
35639 C...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 
35668 C...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 
35674 C...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 
35684 C...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 
35726 C...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 
35754 C...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 
35784 C...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 
35809 C...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
35819 C...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 
35835 C...CHI1 JUMPS TO HERE
35836  150 CONTINUE
35837 
35838 C...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 
35852 C...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 
35878 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
35879 C...--> 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 
35895 C...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 
35934 C...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 
35972 C...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 
35994 C...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 
36012 C...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 
36029 C...~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 
36049 C...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 
36070 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
36071 C...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 
36128 C*********************************************************************
36129 
36130 C...PYXXZ5
36131 C...Calculates chi0 -> chi0 + f + ~f.
36132 
36133  FUNCTION pyxxz5(X)
36134 
36135 C...Double precision and integer declarations.
36136  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36137  IMPLICIT INTEGER(I-N)
36138  INTEGER PYK,PYCHGE,PYCOMP
36139 C...Parameter statement to help give large particle numbers.
36140  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36141 C...Commonblocks.
36142  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36143  common/pyints/xxm(20)
36144  SAVE /pydat1/,/pyints/
36145 
36146 C...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 
36157 C...Statement functions.
36158 C...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)
36160 C...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)
36163 C...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)))
36166 C...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)
36168 C...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 
36239 C...WFL1=0.0
36240 C...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 
36256 C*********************************************************************
36257 
36258 C...PYXXW5
36259 C...Calculates chi0(+) -> chi+(0) + f + ~f'.
36260 
36261  FUNCTION pyxxw5(X)
36262 
36263 C...Double precision and integer declarations.
36264  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36265  IMPLICIT INTEGER(I-N)
36266  INTEGER PYK,PYCHGE,PYCOMP
36267 C...Parameter statement to help give large particle numbers.
36268  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36269 C...Commonblocks.
36270  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36271  common/pyints/xxm(20)
36272  SAVE /pydat1/,/pyints/
36273 
36274 C...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 
36286 C...Statement functions.
36287 C...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)
36289 C...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)
36292 C...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)))
36295 C...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)
36297 C...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 
36388 C*********************************************************************
36389 
36390 C...PYXXGA
36391 C...Calculates chi0_i -> chi0_j + gamma.
36392 
36393  FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)
36394 
36395 C...Double precision and integer declarations.
36396  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36397  IMPLICIT INTEGER(I-N)
36398  INTEGER PYK,PYCHGE,PYCOMP
36399 
36400 C...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 
36412 C*********************************************************************
36413 
36414 C...PYX2XG
36415 C...Calculates the decay rate for ino -> ino + gauge boson.
36416 
36417  FUNCTION pyx2xg(C1,XM1,XM2,XM3,GL,GR)
36418 
36419 C...Double precision and integer declarations.
36420  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36421  IMPLICIT INTEGER(I-N)
36422  INTEGER PYK,PYCHGE,PYCOMP
36423 
36424 C...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 
36441 C*********************************************************************
36442 
36443 C...PYX2XH
36444 C...Calculates the decay rate for ino -> ino + H.
36445 
36446  FUNCTION pyx2xh(C1,XM1,XM2,XM3,GL,GR)
36447 
36448 C...Double precision and integer declarations.
36449  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36450  IMPLICIT INTEGER(I-N)
36451  INTEGER PYK,PYCHGE,PYCOMP
36452 
36453 C...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 
36470 C*********************************************************************
36471 
36472 C...PYXXZ2
36473 C...Calculates chi+ -> chi+ + f + ~f.
36474 
36475  FUNCTION pyxxz2(X)
36476 
36477 C...Double precision and integer declarations.
36478  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36479  IMPLICIT INTEGER(I-N)
36480  INTEGER PYK,PYCHGE,PYCOMP
36481 C...Parameter statement to help give large particle numbers.
36482  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36483 C...Commonblocks.
36484  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36485  common/pyints/xxm(20)
36486  SAVE /pydat1/,/pyints/
36487 
36488 C...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 
36499 C...Statement functions.
36500 C...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)
36502 C...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)
36505 C...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)))
36508 C...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 
36573 C*********************************************************************
36574 
36575 C...PYHEXT
36576 C...Calculates the non-standard decay modes of the Higgs boson.
36577 
36578  SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)
36579 
36580 C...Double precision and integer declarations.
36581  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36582  IMPLICIT INTEGER(I-N)
36583  INTEGER PYK,PYCHGE,PYCOMP
36584 C...Parameter statement to help give large particle numbers.
36585  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
36586 C...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 
36595 C...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 
36627 C...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 
36638 C...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 
36666 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36667 C...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)) )
36692 C...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 
36703 C...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 
36725 C...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 
36876 C...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 
36905 C...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 
36918 C...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 
36931 C...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 
36944 C...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 
36957 C...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 
36972 C...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 
36987 C...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 
36999 C...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 
37023 C*********************************************************************
37024 
37025 C...PYH2XX
37026 C...Calculates the decay rate for a Higgs to an ino pair.
37027 
37028  FUNCTION pyh2xx(C1,XM1,XM2,XM3,GL,GR)
37029 
37030 C...Double precision and integer declarations.
37031  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37032  IMPLICIT INTEGER(I-N)
37033  INTEGER PYK,PYCHGE,PYCOMP
37034 C...Commonblocks.
37035  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37036  SAVE /pydat1/
37037 
37038 C...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 
37060 C*********************************************************************
37061 
37062 C...PYGAUS
37063 C...Integration by adaptive Gaussian quadrature.
37064 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
37065 
37066  FUNCTION pygaus(F, A, B, EPS)
37067 
37068 C...Double precision and integer declarations.
37069  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37070  IMPLICIT INTEGER(I-N)
37071  INTEGER PYK,PYCHGE,PYCOMP
37072 
37073 C...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 
37089 C...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 
37127 C*********************************************************************
37128 
37129 C...PYSIMP
37130 C...Simpson formula for an integral.
37131 
37132  FUNCTION pysimp(Y,X0,X1,N)
37133 
37134 C...Double precision and integer declarations.
37135  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37136  IMPLICIT INTEGER(I-N)
37137  INTEGER PYK,PYCHGE,PYCOMP
37138 
37139 C...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 
37153 C*********************************************************************
37154 
37155 C...PYLAMF
37156 C...The standard lambda function.
37157 
37158  FUNCTION pylamf(X,Y,Z)
37159 
37160 C...Double precision and integer declarations.
37161  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37162  IMPLICIT INTEGER(I-N)
37163  INTEGER PYK,PYCHGE,PYCOMP
37164 
37165 C...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 
37174 C*********************************************************************
37175 
37176 C...PYTBDY
37177 C...Generates 3-body decays of gauginos.
37178 
37179  SUBROUTINE pytbdy(XM)
37180 
37181 C...Double precision and integer declarations.
37182  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37183  IMPLICIT INTEGER(I-N)
37184  INTEGER PYK,PYCHGE,PYCOMP
37185 C...Parameter statement to help give large particle numbers.
37186  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
37187 C...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 
37195 C...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 
37206 C...GENERATE S12
37207  s12min=(xm(1)+xm(2))**2
37208  s12max=(xm(5)-xm(3))**2
37209  yjaco1=s12max-s12min
37210 
37211 C...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 
37225 C...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
37273 C...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
37285 C...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 
37301 C...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 
37325 C...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 
37351 C*********************************************************************
37352 
37353 C...PY1ENT
37354 C...Stores one parton/particle in commonblock PYJETS.
37355 
37356  SUBROUTINE py1ent(IP,KF,PE,THE,PHI)
37357 
37358 C...Double precision and integer declarations.
37359  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37360  IMPLICIT INTEGER(I-N)
37361  INTEGER PYK,PYCHGE,PYCOMP
37362 C...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 
37368 C...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 
37377 C...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 
37387 C...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 
37398 C...Set N. Optionally fragment/decay.
37399  n=ipa
37400  IF(ip.EQ.0) CALL pyexec
37401 
37402  RETURN
37403  END
37404 
37405 C*********************************************************************
37406 
37407 C...PY2ENT
37408 C...Stores two partons/particles in their CM frame,
37409 C...with the first along the +z axis.
37410 
37411  SUBROUTINE py2ent(IP,KF1,KF2,PECM)
37412 
37413 C...Double precision and integer declarations.
37414  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37415  IMPLICIT INTEGER(I-N)
37416  INTEGER PYK,PYCHGE,PYCOMP
37417 C...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 
37423 C...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 
37434 C...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 
37449 C...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 
37461 C...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 
37467 C...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 
37477 C...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 
37489 C...Set N. Optionally fragment/decay.
37490  n=ipa+1
37491  IF(ip.EQ.0) CALL pyexec
37492 
37493  RETURN
37494  END
37495 
37496 C*********************************************************************
37497 
37498 C...PY3ENT
37499 C...Stores three partons or particles in their CM frame,
37500 C...with the first along the +z axis and the third in the (x,z)
37501 C...plane with x > 0.
37502 
37503  SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
37504 
37505 C...Double precision and integer declarations.
37506  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37507  IMPLICIT INTEGER(I-N)
37508  INTEGER PYK,PYCHGE,PYCOMP
37509 C...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 
37515 C...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 
37527 C...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 
37545 C...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 
37561 C...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 
37569 C...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 
37584 C...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 
37598 C...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 
37611 C...Set N. Optionally fragment/decay.
37612  n=ipa+2
37613  IF(ip.EQ.0) CALL pyexec
37614 
37615  RETURN
37616  END
37617 
37618 C*********************************************************************
37619 
37620 C...PY4ENT
37621 C...Stores four partons or particles in their CM frame, with
37622 C...the first along the +z axis, the last in the xz plane with x > 0
37623 C...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 
37627 C...Double precision and integer declarations.
37628  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37629  IMPLICIT INTEGER(I-N)
37630  INTEGER PYK,PYCHGE,PYCOMP
37631 C...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 
37637 C...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 
37650 C...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 
37671 C...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 
37691 C...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 
37702 C...Store partons for parton shower evolution from q-g-g-qbar or
37703 C...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 
37720 C...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 
37736 C...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 
37760 C...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 
37779 C...Set N. Optionally fragment/decay.
37780  n=ipa+3
37781  IF(ip.EQ.0) CALL pyexec
37782 
37783  RETURN
37784  END
37785 
37786 C*********************************************************************
37787 
37788 C...PY2FRM
37789 C...An interface from a two-fermion generator to include
37790 C...parton showers and hadronization.
37791 
37792  SUBROUTINE py2frm(IRAD,ITAU,ICOM)
37793 
37794 C...Double precision and integer declarations.
37795  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37796  IMPLICIT INTEGER(I-N)
37797  INTEGER PYK,PYCHGE,PYCOMP
37798 C...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/
37802 C...Local arrays.
37803  dimension ijoin(2),intau(2)
37804 
37805 C...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 
37811 C...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 
37834 C...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 
37842 C...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 
37851 C...Decide whether to allow or not photon radiation in showers.
37852  mstj(41)=2
37853  IF(irad.EQ.0) mstj(41)=1
37854 
37855 C...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 
37869 C...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 
37887 C...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 
37895 C*********************************************************************
37896 
37897 C...PY4FRM
37898 C...An interface from a four-fermion generator to include
37899 C...parton showers and hadronization.
37900 
37901  SUBROUTINE py4frm(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
37902 
37903 C...Double precision and integer declarations.
37904  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37905  IMPLICIT INTEGER(I-N)
37906  INTEGER PYK,PYCHGE,PYCOMP
37907 C...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/
37911 C...Local arrays.
37912  dimension ijoin(2),intau(4)
37913 
37914 C...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 
37920 C...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 
37949 C...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 
37957 C...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 
37973 C...Decide whether to allow or not photon radiation in showers.
37974  mstj(41)=2
37975  IF(irad.EQ.0) mstj(41)=1
37976 
37977 C...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 
37999 C...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 
38021 C...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 
38039 C...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 
38047 C*********************************************************************
38048 
38049 C...PY6FRM
38050 C...An interface from a six-fermion generator to include
38051 C...parton showers and hadronization.
38052 
38053  SUBROUTINE py6frm(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
38054 
38055 C...Double precision and integer declarations.
38056  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38057  IMPLICIT INTEGER(I-N)
38058  INTEGER PYK,PYCHGE,PYCOMP
38059 C...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/
38063 C...Local arrays.
38064  dimension ijoin(2),intau(6),beta(3),betao(3),betan(3)
38065 
38066 C...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 
38072 C...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 
38107 C...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 
38115 C...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 
38138 C...Decide whether to allow or not photon radiation in showers.
38139  mstj(41)=2
38140  IF(irad.EQ.0) mstj(41)=1
38141 
38142 C...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 
38155 C...Decide whether t+tbar.
38156  itop=0
38157  IF(pyr(0).LT.ptop) THEN
38158  itop=1
38159 
38160 C...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 
38181 C...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 
38189 C...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 
38197 C...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 
38215 C...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 
38221 C...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 
38240 C...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 
38256 C...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 
38265 C...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 
38272 C...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 
38280 C...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 
38305 C...If t+tbar: boost W decay products, first by effects of t shower,
38306 C...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 
38319 C...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 
38350 C...Do colour joinings and parton showers
38351 C...(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 
38385 C...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 
38403 C...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 
38411 C*********************************************************************
38412 
38413 C...PY4JET
38414 C...An interface from a four-parton generator to include
38415 C...parton showers and hadronization.
38416 
38417  SUBROUTINE py4jet(PMAX,IRAD,ICOM)
38418 
38419 C...Double precision and integer declarations.
38420  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38421  IMPLICIT INTEGER(I-N)
38422  INTEGER PYK,PYCHGE,PYCOMP
38423 C...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/
38427 C...Local arrays.
38428  dimension ijoin(2),ptot(4),beta(3)
38429 
38430 C...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 
38436 C...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 
38473 C...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 
38481 C...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 
38490 C...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 
38504 C...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 
38514 C...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 
38544 C...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 
38554 C...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 
38560 C...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 
38589 C...Decide whether to allow or not photon radiation in showers.
38590 C...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 
38597 C...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 
38605 C...Rotate and boost back system.
38606  CALL pyrobo(nsav+1,n,the,phi,beta(1),beta(2),beta(3))
38607 
38608 C...Do fragmentation and decays.
38609  CALL pyexec
38610 
38611 C...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 
38620 C*********************************************************************
38621 
38622 C...PY4JTW
38623 C...Auxiliary to PY4JET, to evaluate weight of configuration.
38624 
38625  FUNCTION py4jtw(IA1,IA2,IA3,IA4)
38626 
38627 C...Double precision and integer declarations.
38628  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38629  IMPLICIT INTEGER(I-N)
38630  INTEGER PYK,PYCHGE,PYCOMP
38631 C...Commonblocks.
38632  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38633  SAVE /pyjets/
38634 
38635 C...First case: when both original partons radiate.
38636 C...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 
38651 C...Second case: when one original parton radiates to three.
38652 C...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 
38682 C...Total weight.
38683  py4jtw=wt1*wt2
38684 
38685  RETURN
38686  END
38687 
38688 C*********************************************************************
38689 
38690 C...PY4JTS
38691 C...Auxiliary to PY4JET, to set up chosen configuration.
38692 
38693  SUBROUTINE py4jts(IA1,IA2,IA3,IA4,IA5,QMAX)
38694 
38695 C...Double precision and integer declarations.
38696  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38697  IMPLICIT INTEGER(I-N)
38698  INTEGER PYK,PYCHGE,PYCOMP
38699 C...Commonblocks.
38700  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38701  SAVE /pyjets/
38702 
38703 C...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 
38712 C...First case: when both original partons radiate.
38713 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
38714  IF(ia1.NE.0) THEN
38715 
38716 C...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 
38734 C...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 
38749 C...Second case: q radiates twice.
38750 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
38751 C...IA5=N+2 does not radiate.
38752  ELSEIF(k(ia2,2).EQ.21) THEN
38753 
38754 C...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 
38772 C...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 
38787 C...Third case: q radiates g, g branches.
38788 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
38789 C...IA5=N+2 does not radiate.
38790  ELSE
38791 
38792 C...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 
38810 C...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 
38831 C*********************************************************************
38832 
38833 C...PYJOIN
38834 C...Connects a sequence of partons with colour flow indices,
38835 C...as required for subsequent shower evolution (or other operations).
38836 
38837  SUBROUTINE pyjoin(NJOIN,IJOIN)
38838 
38839 C...Double precision and integer declarations.
38840  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38841  IMPLICIT INTEGER(I-N)
38842  INTEGER PYK,PYCHGE,PYCOMP
38843 C...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/
38848 C...Local array.
38849  dimension ijoin(*)
38850 
38851 C...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 
38868 C...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 
38884 C...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 
38892 C*********************************************************************
38893 
38894 C...PYGIVE
38895 C...Sets values of commonblock variables.
38896 
38897  SUBROUTINE pygive(CHIN)
38898 
38899 C...Double precision and integer declarations.
38900  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38901  IMPLICIT INTEGER(I-N)
38902  INTEGER PYK,PYCHGE,PYCOMP
38903 C...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/
38927 C...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 
38933 C...For each variable to be translated give: name,
38934 C...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 
38960 C...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 
38979 C...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 
39002 C...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 
39055 C...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 
39073 C...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 
39174 C...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 
39193 C...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 
39208 C...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 
39309 C...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 
39331 C...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 
39338 C*********************************************************************
39339 
39340 C...PYEXEC
39341 C...Administrates the fragmentation and decay chain.
39342 
39343  SUBROUTINE pyexec
39344 
39345 C...Double precision and integer declarations.
39346  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39347  IMPLICIT INTEGER(I-N)
39348  INTEGER PYK,PYCHGE,PYCOMP
39349 C...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/
39356 C...Local array.
39357  dimension ps(2,6),ijoin(100)
39358 
39359 C...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 
39369 C...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 
39385 C...Prepare system for subsequent fragmentation/decay.
39386  CALL pyprep(0)
39387 
39388 C...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 
39397 C...Deal with any remaining undecayed resonance
39398 C...(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 
39421 C...Particle decay if unstable and allowed. Save long-lived particle
39422 C...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 
39428 C...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 
39443 C...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 
39459 C...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 
39467 C...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 
39473 C...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 
39491 C*********************************************************************
39492 
39493 C...PYPREP
39494 C...Rearranges partons along strings.
39495 C...Allows small systems to collapse into one or two particles.
39496 C...Checks flavours and colour singlet invarient masses.
39497 
39498  SUBROUTINE pyprep(IP)
39499 
39500 C...Double precision and integer declarations.
39501  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39502  INTEGER PYK,PYCHGE,PYCOMP
39503 C...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/
39509 C...Local arrays.
39510  dimension dps(5),dpc(5),ue(3),pg(5),
39511  &e1(3),e2(3),e3(3),e4(3),ecl(3)
39512 
39513 C...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 
39516 C...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 
39526 C...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 
39537 C...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 
39558 C...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 
39592 C...Done if no checks on small-mass systems.
39593  IF(mstj(14).LT.0) RETURN
39594  IF(mstj(14).EQ.0) GOTO 540
39595 
39596 C...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 
39637 C...Done if lowest-mass system above threshold for string frag.
39638  IF(pdmin.GE.parj(32)) GOTO 540
39639 
39640 C...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 
39652 C...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 
39673 C...Form two particles from flavours of lowest-mass system, if feasible.
39674  ntry = 0
39675  200 ntry = ntry + 1
39676 C...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
39684 C...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
39691 C...Closed string.
39692  ELSE
39693  IF(iabs(k(ic2,2)).NE.21) GOTO 540
39694 C...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 
39704 C...If it does not work: try again (a number of times), give up
39705 C...(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 
39716 C...Perform two-particle decay of jet system.
39717 C...First step: find reference axis in decaying system rest frame.
39718 C...(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 
39736 C...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 
39763 C...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 
39774 C...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 
39782 C...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 
39794 C...Use old algorithm for E/p conservation? (EN)
39795  IF (mstj(16).LE.0) GOTO 480
39796 
39797 C...Find the string piece closest to the cluster by a loop
39798 C...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 
39811 C...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 
39820 C...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 
39832 C...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 
39843 C... Check if there are any strings to connect to the new gluon. (EN)
39844  IF (ibeg.EQ.0) GOTO 480
39845 
39846 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
39847  IF (p(n+1,5).GE.p(n+2,5)) THEN
39848 
39849 C...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 
39856 C... 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 
39885 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
39886 C...from string piece endpoints.
39887  ELSE
39888 
39889 C...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 
39909 C...Set initial Phad.
39910  DO 410 j=1,4
39911  p(nsav+2,j)=p(nsav+1,j)
39912  410 CONTINUE
39913 
39914 C...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 
39927 C..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 
39934 C...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 
39956 C...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 
39969 C... 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 
39978 C...Finished with string collapse in new scheme.
39979  GOTO 520
39980  ENDIF
39981 
39982 C... Use old algorithm; by choice or when in trouble.
39983  480 CONTINUE
39984 C...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 
40008 C...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 
40026 C...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 
40042 C...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 
40084 C*********************************************************************
40085 
40086 C...PYSTRF
40087 C...Handles the fragmentation of an arbitrary colour singlet
40088 C...jet system according to the Lund string fragmentation model.
40089 
40090  SUBROUTINE pystrf(IP)
40091 
40092 C...Double precision and integer declarations.
40093  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40094  IMPLICIT INTEGER(I-N)
40095  INTEGER PYK,PYCHGE,PYCOMP
40096 C...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/
40101 C...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 
40107 C...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 
40112 C...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 
40139 C...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 
40160 C...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 
40183 C...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 
40211 C...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 
40241 C...Reset particle counter. Skip ahead if no junctions are present;
40242 C...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 
40264 C...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 
40290 C...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 
40311 C...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 
40322 C...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 
40327 C...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 
40361 C...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 
40395 C...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 
40426 C...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 
40438 C...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 
40460 C...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 
40481 C...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
40521 C...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 
40530 C...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 
40547 C...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 
40558 C...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 
40570 C...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 
40589 C...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 
40617 C...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 
40626 C...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 
40642 C...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 
40669 C...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 
40702 C...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
40736 C.. MOPS variables and switches
40737  nrvmo=0
40738  xbmo=1d0
40739  mstu(121)=0
40740  mstu(122)=0
40741 
40742 C...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 
40757 C...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)
40762 C.. Closed string: first vertex diq attempt => enforced second
40763 C.. 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
40791 C.. 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 
40798 C...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 
40840 C...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 
40850 C...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
40856 C.. 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 
40870 C...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 
40884 C...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 
40897 C...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 
40917 C.. 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 
40949 C.. 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
40977 C..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 
40984 C..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
41010 C.. MOPS end of modification
41011 
41012  DO 870 j=1,3
41013  in(j)=in(3*jt+j)
41014  870 CONTINUE
41015 
41016 C...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 
41037 C...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
41077 C...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 
41088 C...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 
41105 C...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 
41116 C...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 
41128 C...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 
41147 C...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 
41171 C...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 
41182 C...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 
41196 C...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 
41220 C...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 
41234 C...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 
41261 C...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 
41302 C...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 
41330 C*********************************************************************
41331 
41332 C...PYINDF
41333 C...Handles the fragmentation of a jet system (or a single
41334 C...jet) according to independent fragmentation models.
41335 
41336  SUBROUTINE pyindf(IP)
41337 
41338 C...Double precision and integer declarations.
41339  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41340  IMPLICIT INTEGER(I-N)
41341  INTEGER PYK,PYCHGE,PYCOMP
41342 C...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/
41347 C...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 
41351 C.. 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 
41355 C...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 
41389 C...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 
41412 C...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 
41427 C...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 
41433 C...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 
41439 C...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 
41446 C...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 
41454 C...Initial values for gluon treated like quark-antiquark jet pair,
41455 C...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 
41468 C...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 
41478 C...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 
41495 C...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 
41519 C...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 
41528 C...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 
41539 C...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 
41547 C...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 
41552 C...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 
41571 C...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 
41605 C...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 
41639 C...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 
41654 C...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 
41681 C...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 
41718 C...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 
41745 C...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 
41766 C...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 
41791 C...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 
41803 C*********************************************************************
41804 
41805 C...PYDECY
41806 C...Handles the decay of unstable particles.
41807 
41808  SUBROUTINE pydecy(IP)
41809 
41810 C...Double precision and integer declarations.
41811  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41812  IMPLICIT INTEGER(I-N)
41813  INTEGER PYK,PYCHGE,PYCOMP
41814 C...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/
41820 C...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 
41826 C...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 
41830 C...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 
41838 C...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 
41848 C...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 
41863 C...Interface to external tau decay library (for tau polarization).
41864  IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
41865 
41866 C...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 
41873 C...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
41878 C...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
41883 C...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
41896 C...If coming from weak decay of hadron then W is not stored in record,
41897 C...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
41909 C...If coming from resonance decay then find latest copy of this
41910 C...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 
41922 C...Boost tau to rest frame of production process (where known)
41923 C...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 
41934 C...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 
41946 C...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 
41955 C...Skip past ordinary tau decay treatment.
41956  mmat=0
41957  mbst=0
41958  nd=0
41959  GOTO 630
41960  ENDIF
41961  ENDIF
41962 
41963 C...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 
41972 C...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 
41995 C...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 
42010 C...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 
42025 C...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
42030 C...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
42056 C.. Random flavour and popcorn system memory.
42057  irndmo=0
42058  jtmo=0
42059  mstu(121)=0
42060  mstu(125)=10
42061 
42062 C...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 
42094 C...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
42100 C...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 
42132 C...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 
42137 C...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
42143 C...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
42167 C.. 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 
42171 C...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
42177 C.. 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 
42200 C...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 
42212 C...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 
42225 C...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 
42231 C...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 
42254 C...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 
42262 C...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 
42275 C...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 
42288 C...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 
42309 C...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 
42324 C...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 
42342 C...Check that no infinite loop in matrix element weight.
42343  ntry=ntry+1
42344  IF(ntry.GT.800) GOTO 560
42345 
42346 C...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 
42353 C...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 
42361 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
42362 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
42363 C...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 
42378 C...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 
42389 C...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 
42395 C...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 
42413 C...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 
42422 C...Low invariant mass for system with spectator quark gives particle,
42423 C...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 
42476 C...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 
42509 C...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 
42532 C...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 
42548 C...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 
42556 C...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 
42612 C...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 
42623 C*********************************************************************
42624 
42625 C...PYDCYK
42626 C...Handles flavour production in the decay of unstable particles
42627 C...and small string clusters.
42628 
42629  SUBROUTINE pydcyk(KFL1,KFL2,KFL3,KF)
42630 
42631 C...Double precision and integer declarations.
42632  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42633  IMPLICIT INTEGER(I-N)
42634  INTEGER PYK,PYCHGE,PYCOMP
42635 C...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 
42641 C.. 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 
42657 C.. 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
42662 C.. 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
42669 C.. 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
42674 C.. 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 
42680 C.. 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)
42686 C.. 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 
42694 C 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 
42706 C..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 
42714 C.. 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 
42746 C.. Store meson
42747  120 IF(nmes.LE.nmax) mstu(nsto+mstu(121)+1)=kfm
42748  IF(mstu(121).GT.0) GOTO 110
42749 
42750 C.. 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 
42762 C********************************************************************
42763 
42764 C...PYKFDI
42765 C...Generates a new flavour pair and combines off a hadron
42766 
42767  SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)
42768 
42769 C...Double precision and integer declarations.
42770  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42771  IMPLICIT INTEGER(I-N)
42772  INTEGER PYK,PYCHGE,PYCOMP
42773 C...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/
42777 C...Local arrays.
42778  dimension pd(7)
42779 
42780  IF(mstu(123).EQ.0.AND.mstj(12).GT.0) CALL pykfin
42781 
42782 C...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 
42794 C...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 
42822 C.. 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 
42827 C.. 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 
42844 C.. 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 
42865 C...Meson/baryon choice. Set number of mesons if starting a popcorn
42866 C...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 
42879 C..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 
42886 C..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))
42893 C.. 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 
42900 C.. 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 
42954 C..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 
42966 C..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
42972 C... 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 
43004 C..Optional extra suppression of eta and eta'.
43005 C..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 
43015 C.. 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 
43026 C... 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 
43057 C.. 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 
43064 C.. 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 
43077 C...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 
43108 C...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 
43125 C...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 
43163 C...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 
43181 C...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 
43193 C*********************************************************************
43194 
43195 C...PYNMES
43196 C...Generates number of popcorn mesons and stores some relevant
43197 C...parameters.
43198 
43199  SUBROUTINE pynmes(KFDIQ)
43200 
43201 C...Double precision and integer declarations.
43202  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43203  IMPLICIT INTEGER(I-N)
43204  INTEGER PYK,PYCHGE,PYCOMP
43205 C...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 
43213 C..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 
43230 C..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 
43245 C..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 
43256 C***************************************************************
43257 
43258 C...PYKFIN
43259 C...Precalculates a set of diquark and popcorn weights.
43260 
43261  SUBROUTINE pykfin
43262 
43263 C...Double precision and integer declarations.
43264  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43265  IMPLICIT INTEGER(I-N)
43266  INTEGER PYK,PYCHGE,PYCOMP
43267 C...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
43276 C..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 
43285 C.. *** SU(6) factors **
43286 C..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 
43302 C..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 
43312 C..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 
43319 C..diquark SU(6) survival =
43320 C..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 
43330 C.. *** Tunneling factors for Diquark production***
43331 C.. 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 
43358 C.. 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 
43367 C.. 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
43373 C..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 
43382 C..New version: curtain flavour ratios.
43383 C.. s/u for q->B+M+...
43384 C.. s/u for rank 0 diquark: su -> ...M+B+...
43385 C.. 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
43393 C..Old version: reset unused rank 0 diquark weights and
43394 C.. 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 
43400 C..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 
43405 C..Old version: curtain flavour ratios.
43406 C.. s/u for q->B+M+...
43407 C.. s/u for rank 0 diquark: su -> ...M+B+...
43408 C.. 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 
43415 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
43416 C.. 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 
43424 C.. *** Popcorn factors ***
43425 
43426  IF(mstj(12).LT.5)THEN
43427 C.. 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
43440 C..New version: Store weights for popcorn mesons,
43441 C..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 
43538 C..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 
43574 C*********************************************************************
43575 
43576 C...PYPTDI
43577 C...Generates transverse momentum according to a Gaussian.
43578 
43579  SUBROUTINE pyptdi(KFL,PX,PY)
43580 
43581 C...Double precision and integer declarations.
43582  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43583  IMPLICIT INTEGER(I-N)
43584  INTEGER PYK,PYCHGE,PYCOMP
43585 C...Commonblocks.
43586  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43587  SAVE /pydat1/
43588 
43589 C...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 
43602 C*********************************************************************
43603 
43604 C...PYZDIS
43605 C...Generates the longitudinal splitting variable z.
43606 
43607  SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)
43608 
43609 C...Double precision and integer declarations.
43610  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43611  IMPLICIT INTEGER(I-N)
43612  INTEGER PYK,PYCHGE,PYCOMP
43613 C...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 
43618 C...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 
43624 C...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 
43648 C...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 
43662 C...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 
43682 C...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 
43704 C...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 
43711 C...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 
43730 C*********************************************************************
43731 
43732 C...PYSHOW
43733 C...Generates timelike parton showers from given partons.
43734 
43735  SUBROUTINE pyshow(IP1,IP2,QMAX)
43736 
43737 C...Double precision and integer declarations.
43738  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43739  IMPLICIT INTEGER(I-N)
43740  INTEGER PYK,PYCHGE,PYCOMP
43741 C...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/
43746 C...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 
43752 C...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 
43762 C...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 
43803 C...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 
43831 C...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)
43840 C...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 
43870 C...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 
43892 C...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 
43916 C...Boost interfering initial partons to rest frame
43917 C...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 
43957 C...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 
43979 C...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 
44001 C...Position of aunt (sister to branching parton).
44002 C...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 
44031 C...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 
44047 C...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 
44076 C...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 
44106 C...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 
44116 C...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 
44138 C...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 
44149 C...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 
44163 C...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 
44193 C...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 
44199 C...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 
44206 C...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 
44213 C...Reset QCD probability for lepton.
44214  IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0d0
44215 
44216 C...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 
44222 C...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 
44239 C...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
44244 C...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 
44261 C...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 
44273 C...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 
44281 C...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 
44298 C...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 
44304 C...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 
44331 C...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 
44346 C...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 
44356 C...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 
44400 C...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 
44415 C...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 
44452 C...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 
44481 C...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 
44495 C...Impose angular constraint in first branching from interference
44496 C...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 
44506 C...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 
44523 C...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 
44622 C...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 
44658 C...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 
44684 C...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 
44704 C...Find coefficient of azimuthal asymmetry due to soft gluon
44705 C...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 
44725 C...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 
44738 C...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 
44763 C...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 
44786 C...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 
44825 C...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 
44856 C...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 
44877 C...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 
44888 C...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 
44901 C...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 
44938 C...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 
44966 C...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 
44973 C...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 
44993 C*********************************************************************
44994 
44995 C...PYBOEI
44996 C...Modifies an event so as to approximately take into account
44997 C...Bose-Einstein effects according to a simple phenomenological
44998 C...parametrization.
44999 
45000  SUBROUTINE pyboei(NSAV)
45001 
45002 C...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)
45007 C...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/
45012 C...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/
45016 C...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 
45020 C...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 
45044 C...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 
45089 C...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 
45128 C...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 
45209 C...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 
45221 C...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
45359 C...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 
45396 C...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 
45434 C...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 
45452 C...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 
45461 C*********************************************************************
45462 
45463 C...PYBESQ
45464 C...Calculates the momentum shift in a system of two particles assuming
45465 C...the relative momentum squared should be shifted to Q2NEW. NI is the
45466 C...last position occupied in /PYJETS/.
45467 
45468  SUBROUTINE pybesq(I1,I2,NI,Q2OLD,Q2NEW)
45469 
45470 C...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)
45475 C...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/
45479 C...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 
45511 C...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 
45538 C*********************************************************************
45539 
45540 C...PYMASS
45541 C...Gives the mass of a particle/parton.
45542 
45543  FUNCTION pymass(KF)
45544 
45545 C...Double precision and integer declarations.
45546  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45547  IMPLICIT INTEGER(I-N)
45548  INTEGER PYK,PYCHGE,PYCOMP
45549 C...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 
45554 C...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 
45563 C...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 
45578 C...Other masses can be read directly off table.
45579  ELSE
45580  pymass=pmas(kc,1)
45581  ENDIF
45582 
45583 C...Optional mass broadening according to truncated Breit-Wigner
45584 C...(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 
45603 C*********************************************************************
45604 
45605 C...PYMRUN
45606 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
45607 C...for Higgs couplings. Everything else sent on to PYMASS.
45608 
45609  FUNCTION pymrun(KF,Q2)
45610 
45611 C...Double precision and integer declarations.
45612  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45613  IMPLICIT INTEGER(I-N)
45614  INTEGER PYK,PYCHGE,PYCOMP
45615 C...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 
45621 C...Most masses not handled here.
45622  kfa=iabs(kf)
45623  IF(kfa.EQ.0.OR.kfa.GT.5) THEN
45624  pymrun=pymass(kf)
45625 
45626 C...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 
45630 C...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 
45641 C*********************************************************************
45642 
45643 C...PYNAME
45644 C...Gives the particle/parton name as a character string.
45645 
45646  SUBROUTINE pyname(KF,CHAU)
45647 
45648 C...Double precision and integer declarations.
45649  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45650  IMPLICIT INTEGER(I-N)
45651  INTEGER PYK,PYCHGE,PYCOMP
45652 C...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/
45658 C...Local character variable.
45659  CHARACTER CHAU*16
45660 
45661 C...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 
45670 C*********************************************************************
45671 
45672 C...PYCHGE
45673 C...Gives three times the charge for a particle/parton.
45674 
45675  FUNCTION pychge(KF)
45676 
45677 C...Double precision and integer declarations.
45678  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45679  IMPLICIT INTEGER(I-N)
45680  INTEGER PYK,PYCHGE,PYCOMP
45681 C...Commonblocks.
45682  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45683  SAVE /pydat2/
45684 
45685 C...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 
45693 C*********************************************************************
45694 
45695 C...PYCOMP
45696 C...Compress the standard KF codes for use in mass and decay arrays;
45697 C...also checks whether a given code actually is defined.
45698 
45699  FUNCTION pycomp(KF)
45700 
45701 C...Double precision and integer declarations.
45702  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45703  IMPLICIT INTEGER(I-N)
45704  INTEGER PYK,PYCHGE,PYCOMP
45705 C...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/
45709 C...Local arrays and saved data.
45710  dimension kford(100:500),kcord(101:500)
45711  SAVE kford,kcord,nford,kflast,kclast
45712 
45713 C...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 
45734 C...Fast action if same code as in latest call.
45735  IF(kf.EQ.kflast) THEN
45736  pycomp=kclast
45737  RETURN
45738  ENDIF
45739 
45740 C...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 
45746 C...Simple cases: direct translation.
45747  IF(kfa.GT.kford(nford)) THEN
45748  ELSEIF(kfa.LE.100) THEN
45749  pycomp=kfa
45750 
45751 C...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 
45767 C...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 
45772 C...Save codes for possible future fast action.
45773  kflast=kf
45774  kclast=pycomp
45775 
45776  RETURN
45777  END
45778 
45779 C*********************************************************************
45780 
45781 C...PYERRM
45782 C...Informs user of errors in program execution.
45783 
45784  SUBROUTINE pyerrm(MERR,CHMESS)
45785 
45786 C...Double precision and integer declarations.
45787  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45788  IMPLICIT INTEGER(I-N)
45789  INTEGER PYK,PYCHGE,PYCOMP
45790 C...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/
45794 C...Local character variable.
45795  CHARACTER CHMESS*(*)
45796 
45797 C...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 
45804 C...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 
45817 C...Stop program in case of irreparable error.
45818  ELSE
45819  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
45820  stop
45821  ENDIF
45822 
45823 C...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 
45836 C*********************************************************************
45837 
45838 C...PYALEM
45839 C...Calculates the running alpha_electromagnetic.
45840 
45841  FUNCTION pyalem(Q2)
45842 
45843 C...Double precision and integer declarations.
45844  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45845  IMPLICIT INTEGER(I-N)
45846  INTEGER PYK,PYCHGE,PYCOMP
45847 C...Commonblocks.
45848  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45849  SAVE /pydat1/
45850 
45851 C...Calculate real part of photon vacuum polarization.
45852 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
45853 C...For hadrons use parametrization of H. Burkhardt et al.
45854 C...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 
45875 C...Calculate running alpha_em.
45876  pyalem=paru(101)/(1d0-rpigg)
45877  paru(108)=pyalem
45878 
45879  RETURN
45880  END
45881 
45882 C*********************************************************************
45883 
45884 C...PYALPS
45885 C...Gives the value of alpha_strong.
45886 
45887  FUNCTION pyalps(Q2)
45888 
45889 C...Double precision and integer declarations.
45890  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45891  IMPLICIT INTEGER(I-N)
45892  INTEGER PYK,PYCHGE,PYCOMP
45893 C...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 
45898 C...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 
45909 C...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 
45933 C...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 
45949 C*********************************************************************
45950 
45951 C...PYANGL
45952 C...Reconstructs an angle from given x and y coordinates.
45953 
45954  FUNCTION pyangl(X,Y)
45955 
45956 C...Double precision and integer declarations.
45957  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45958  IMPLICIT INTEGER(I-N)
45959  INTEGER PYK,PYCHGE,PYCOMP
45960 C...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 
45981 C*********************************************************************
45982 
45983 C...PYR
45984 C...Generates random numbers uniformly distributed between
45985 C...0 and 1, excluding the endpoints.
45986 
45987  FUNCTION pyr(IDUMMY)
45988 
45989 C...Double precision and integer declarations.
45990  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45991  IMPLICIT INTEGER(I-N)
45992  INTEGER PYK,PYCHGE,PYCOMP
45993 C...Commonblocks.
45994  common/pydatr/mrpy(6),rrpy(100)
45995  SAVE /pydatr/
45996 C...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 
46001 C...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 
46036 C...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 
46050 C...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 
46061 C*********************************************************************
46062 
46063 C...PYRGET
46064 C...Dumps the state of the random number generator on a file
46065 C...for subsequent startup from this state onwards.
46066 
46067  SUBROUTINE pyrget(LFN,MOVE)
46068 
46069 C...Double precision and integer declarations.
46070  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46071  IMPLICIT INTEGER(I-N)
46072  INTEGER PYK,PYCHGE,PYCOMP
46073 C...Commonblocks.
46074  common/pydatr/mrpy(6),rrpy(100)
46075  SAVE /pydatr/
46076 C...Local character variable.
46077  CHARACTER CHERR*8
46078 
46079 C...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 
46088 C...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 
46094 C...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 
46102 C*********************************************************************
46103 
46104 C...PYRSET
46105 C...Reads a state of the random number generator from a file
46106 C...for subsequent generation from this state onwards.
46107 
46108  SUBROUTINE pyrset(LFN,MOVE)
46109 
46110 C...Double precision and integer declarations.
46111  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46112  IMPLICIT INTEGER(I-N)
46113  INTEGER PYK,PYCHGE,PYCOMP
46114 C...Commonblocks.
46115  common/pydatr/mrpy(6),rrpy(100)
46116  SAVE /pydatr/
46117 C...Local character variable.
46118  CHARACTER CHERR*8
46119 
46120 C...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 
46129 C...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 
46138 C...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 
46146 C*********************************************************************
46147 
46148 C...PYROBO
46149 C...Performs rotations and boosts.
46150 
46151  SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
46152 
46153 C...Double precision and integer declarations.
46154  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46155  IMPLICIT INTEGER(I-N)
46156  INTEGER PYK,PYCHGE,PYCOMP
46157 C...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/
46161 C...Local arrays.
46162  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
46163 
46164 C...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 
46176 C...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 
46186 C...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 
46210 C...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
46218 C...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 
46250 C*********************************************************************
46251 
46252 C...PYEDIT
46253 C...Performs global manipulations on the event record, in particular
46254 C...to exclude unstable or undetectable partons/particles.
46255 
46256  SUBROUTINE pyedit(MEDIT)
46257 
46258 C...Double precision and integer declarations.
46259  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46260  IMPLICIT INTEGER(I-N)
46261  INTEGER PYK,PYCHGE,PYCOMP
46262 C...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/
46267 C...Local arrays.
46268  dimension ns(2),pts(2),pls(2)
46269 
46270 C...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 
46296 C...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 
46309 C...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 
46325 C...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 
46364 C...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 
46389 C...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
46394 C...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
46405 C...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
46420 C...Find daughters who point to documentation daughters who,
46421 C...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 
46441 C...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 
46456 C...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 
46467 C...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 
46481 C...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 
46491 C...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 
46513 C...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 
46534 C*********************************************************************
46535 
46536 C...PYLIST
46537 C...Gives program heading, or lists an event, or particle
46538 C...data, or current parameter values.
46539 
46540  SUBROUTINE pylist(MLIST)
46541 
46542 C...Double precision and integer declarations.
46543  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46544  IMPLICIT INTEGER(I-N)
46545  INTEGER PYK,PYCHGE,PYCOMP
46546 C...Parameter statement to help give large particle numbers.
46547  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
46548 C...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/
46554 C...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 
46559 C...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 
46566 C...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 
46579 C...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 
46602 C...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 
46621 C...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 
46643 C...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 
46654 C...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 
46668 C...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 
46754 C...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 
46763 C...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 
46770 C...Particle decay: channel number, branching ratios, matrix element,
46771 C...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 
46781 C...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 
46789 C...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 
46828 C*********************************************************************
46829 
46830 C...PYLOGO
46831 C...Writes a logo for the program.
46832 
46833  SUBROUTINE pylogo
46834 
46835 C...Double precision and integer declarations.
46836  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46837  IMPLICIT INTEGER(I-N)
46838  INTEGER PYK,PYCHGE,PYCOMP
46839 C...Parameter for length of information block.
46840  parameter(irefer=17)
46841 C...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/
46845 C...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 
46850 C...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 
46930 C...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 
46937 C...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 
46969 C...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 
46979 C...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 
46991 C...Write lines to appropriate unit.
46992  WRITE(mstu(11),'(A79)') line
46993  100 CONTINUE
46994 
46995  RETURN
46996  END
46997 
46998 C*********************************************************************
46999 
47000 C...PYUPDA
47001 C...Facilitates the updating of particle and decay data
47002 C...by allowing it to be done in an external file.
47003 
47004  SUBROUTINE pyupda(MUPDA,LFN)
47005 
47006 C...Double precision and integer declarations.
47007  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47008  IMPLICIT INTEGER(I-N)
47009  INTEGER PYK,PYCHGE,PYCOMP
47010 C...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/
47018 C...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 
47027 C...Write header if not yet done.
47028  IF(mstu(12).GE.1) CALL pylist(0)
47029 
47030 C...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 
47042 C...Read complete set of information from edited file or
47043 C...read partial set of new or updated information from edited file.
47044  ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN
47045 
47046 C...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 
47061 C...Begin of loop: read new line; unknown whether particle or
47062 C...decay data.
47063  140 READ(lfn,5200,END=190) chinl
47064 
47065 C...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
47085 C...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 
47110 C...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 
47119 C...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 
47130 C...End of loop; ensure that PYCOMP tables are updated.
47131  GOTO 140
47132  190 CONTINUE
47133  mstu(20)=0
47134 
47135 C...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 
47180 C...Write DATA statements for inclusion in program.
47181  ELSEIF(mupda.EQ.4) THEN
47182 
47183 C...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 
47193 C...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 
47203 C...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 
47228 C...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 
47247 C...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 
47282 C...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 
47305 C...Add characters to end of line, to new line (after storing old line),
47306 C...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 
47334 C...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 
47345 C...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 
47358 C*********************************************************************
47359 
47360 C...PYK
47361 C...Provides various integer-valued event related data.
47362 
47363  FUNCTION pyk(I,J)
47364 
47365 C...Double precision and integer declarations.
47366  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47367  IMPLICIT INTEGER(I-N)
47368  INTEGER PYK,PYCHGE,PYCOMP
47369 C...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 
47375 C...Default value. For I=0 number of entries, number of stable entries
47376 C...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 
47389 C...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 
47395 C...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 
47409 C...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 
47417 C...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 
47457 C...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 
47481 C...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 
47497 C*********************************************************************
47498 
47499 C...PYP
47500 C...Provides various real-valued event related data.
47501 
47502  FUNCTION pyp(I,J)
47503 
47504 C...Double precision and integer declarations.
47505  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47506  IMPLICIT INTEGER(I-N)
47507  INTEGER PYK,PYCHGE,PYCOMP
47508 C...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/
47513 C...Local array.
47514  dimension psum(4)
47515 
47516 C...Set default value. For I = 0 sum of momenta or charges,
47517 C...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 
47539 C...Direct readout of P matrix.
47540  ELSEIF(j.LE.5) THEN
47541  pyp=p(i,j)
47542 
47543 C...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 
47551 C...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 
47557 C...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 
47566 C...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 
47579 C*********************************************************************
47580 
47581 C...PYSPHE
47582 C...Performs sphericity tensor analysis to give sphericity,
47583 C...aplanarity and the related event axes.
47584 
47585  SUBROUTINE pysphe(SPH,APL)
47586 
47587 C...Double precision and integer declarations.
47588  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47589  IMPLICIT INTEGER(I-N)
47590  INTEGER PYK,PYCHGE,PYCOMP
47591 C...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/
47596 C...Local arrays.
47597  dimension sm(3,3),sv(3,3)
47598 
47599 C...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 
47629 C...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 
47642 C...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 
47659 C...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 
47701 C...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 
47718 C...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 
47729 C*********************************************************************
47730 
47731 C...PYTHRU
47732 C...Performs thrust analysis to give thrust, oblateness
47733 C...and the related event axes.
47734 
47735  SUBROUTINE pythru(THR,OBL)
47736 
47737 C...Double precision and integer declarations.
47738  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47739  IMPLICIT INTEGER(I-N)
47740  INTEGER PYK,PYCHGE,PYCOMP
47741 C...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/
47746 C...Local arrays.
47747  dimension tdi(3),tpr(3)
47748 
47749 C...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 
47779 C...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 
47787 C...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 
47798 C...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 
47816 C...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 
47846 C...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 
47866 C...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 
47881 C...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 
47893 C...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 
47907 C...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 
47918 C*********************************************************************
47919 
47920 C...PYCLUS
47921 C...Subdivides the particle content of an event into jets/clusters.
47922 
47923  SUBROUTINE pyclus(NJET)
47924 
47925 C...Double precision and integer declarations.
47926  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47927  IMPLICIT INTEGER(I-N)
47928  INTEGER PYK,PYCHGE,PYCOMP
47929 C...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/
47934 C...Local arrays and saved variables.
47935  dimension ps(5)
47936  SAVE nsav,np,ps,pss,rinit,npre,nrem
47937 
47938 C...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 
47946 C...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 
47969 C...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 
47985 C...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 
48008 C...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 
48015 C...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 
48031 C...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 
48050 C...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 
48064 C...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 
48078 C...Sum up precluster around it according to mass or
48079 C...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 
48105 C...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 
48110 C...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 
48143 C...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 
48161 C...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 
48184 C...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 
48221 C...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 
48228 C...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 
48252 C...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 
48271 C...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 
48291 C*********************************************************************
48292 
48293 C...PYCELL
48294 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
48295 C...as used for calorimeters at hadron colliders.
48296 
48297  SUBROUTINE pycell(NJET)
48298 
48299 C...Double precision and integer declarations.
48300  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48301  IMPLICIT INTEGER(I-N)
48302  INTEGER PYK,PYCHGE,PYCOMP
48303 C...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 
48309 C...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 
48333 C...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 
48355 C...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 
48368 C...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 
48385 C...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 
48412 C...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 
48428 C...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 
48457 C...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 
48479 C...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 
48495 C...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 
48505 C*********************************************************************
48506 
48507 C...PYJMAS
48508 C...Determines, approximately, the two jet masses that minimize
48509 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
48510 
48511  SUBROUTINE pyjmas(PMH,PML)
48512 
48513 C...Double precision and integer declarations.
48514  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48515  IMPLICIT INTEGER(I-N)
48516  INTEGER PYK,PYCHGE,PYCOMP
48517 C...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/
48522 C...Local arrays.
48523  dimension sm(3,3),sax(3),ps(3,5)
48524 
48525 C...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 
48538 C...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 
48562 C...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 
48574 C...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 
48584 C...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 
48598 C...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 
48631 C...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 
48644 C...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 
48660 C...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 
48672 C...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 
48683 C*********************************************************************
48684 
48685 C...PYFOWO
48686 C...Calculates the first few Fox-Wolfram moments.
48687 
48688  SUBROUTINE pyfowo(H10,H20,H30,H40)
48689 
48690 C...Double precision and integer declarations.
48691  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48692  IMPLICIT INTEGER(I-N)
48693  INTEGER PYK,PYCHGE,PYCOMP
48694 C...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 
48700 C...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 
48731 C...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 
48741 C...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 
48758 C...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 
48769 C*********************************************************************
48770 
48771 C...PYTABU
48772 C...Evaluates various properties of an event, with statistics
48773 C...accumulated during the course of the run and
48774 C...printed at the end.
48775 
48776  SUBROUTINE pytabu(MTABU)
48777 
48778 C...Double precision and integer declarations.
48779  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48780  IMPLICIT INTEGER(I-N)
48781  INTEGER PYK,PYCHGE,PYCOMP
48782 C...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/
48788 C...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 
48802 C...Reset statistics on initial parton state.
48803  IF(mtabu.EQ.10) THEN
48804  nevis=0
48805  nkfis=0
48806 
48807 C...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 
48847 C...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 
48878 C...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 
48901 C...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 
48934 C...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 
48942 C...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 
48979 C...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 
49011 C...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 
49024 C...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 
49054 C...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 
49067 C...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 
49098 C...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 
49130 C...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 
49171 C...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 
49189 C...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 
49214 C...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 
49247 C...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 
49259 C...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 
49291 C...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 
49315 C...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 
49330 C...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 
49361 C...Reset statistics on decay channels.
49362  ELSEIF(mtabu.EQ.50) THEN
49363  nevdc=0
49364  nkfdc=0
49365  nredc=0
49366 
49367 C...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 
49389 C...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 
49429 C...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 
49446 C...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 
49481 C...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 
49520 C*********************************************************************
49521 
49522 C...PYEEVT
49523 C...Handles the generation of an e+e- annihilation jet event.
49524 
49525  SUBROUTINE pyeevt(KFL,ECM)
49526 
49527 C...Double precision and integer declarations.
49528  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49529  IMPLICIT INTEGER(I-N)
49530  INTEGER PYK,PYCHGE,PYCOMP
49531 C...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 
49537 C...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 
49550 C...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 
49562 C...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 
49574 C...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 
49591 C...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 
49603 C...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 
49617 C...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 
49627 C...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 
49641 C...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 
49648 C...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 
49657 C...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 
49668 C...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 
49676 C*********************************************************************
49677 
49678 C...PYXTEE
49679 C...Calculates total cross-section, including initial state
49680 C...radiation effects.
49681 
49682  SUBROUTINE pyxtee(KFL,ECM,XTOT)
49683 
49684 C...Double precision and integer declarations.
49685  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49686  IMPLICIT INTEGER(I-N)
49687  INTEGER PYK,PYCHGE,PYCOMP
49688 C...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 
49693 C...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 
49709 C...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 
49724 C...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 
49740 C...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 
49753 C...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 
49767 C...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 
49782 C...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 
49797 C...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 
49804 C...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 
49810 C...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 
49830 C...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 
49840 C*********************************************************************
49841 
49842 C...PYRADK
49843 C...Generates initial state photon radiation.
49844 
49845  SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)
49846 
49847 C...Double precision and integer declarations.
49848  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49849  IMPLICIT INTEGER(I-N)
49850  INTEGER PYK,PYCHGE,PYCOMP
49851 C...Commonblocks.
49852  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49853  SAVE /pydat1/
49854 
49855 C...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 
49859 C...Determine whether radiative photon or not.
49860  mk=0
49861  pak=0d0
49862  IF(parj(160).LT.pyr(0)) RETURN
49863  mk=1
49864 
49865 C...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 
49872 C...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 
49896 C...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 
49907 C...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 
49917 C*********************************************************************
49918 
49919 C...PYXKFL
49920 C...Selects flavour for produced qqbar pair.
49921 
49922  SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)
49923 
49924 C...Double precision and integer declarations.
49925  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49926  IMPLICIT INTEGER(I-N)
49927  INTEGER PYK,PYCHGE,PYCOMP
49928 C...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 
49933 C...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 
49950 C...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 
49967 C...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 
49979 C...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 
49991 C*********************************************************************
49992 
49993 C...PYXJET
49994 C...Selects number of jets in matrix element approach.
49995 
49996  SUBROUTINE pyxjet(ECM,NJET,CUT)
49997 
49998 C...Double precision and integer declarations.
49999  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50000  IMPLICIT INTEGER(I-N)
50001  INTEGER PYK,PYCHGE,PYCOMP
50002 C...Commonblocks.
50003  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50004  SAVE /pydat1/
50005 C...Local array and data.
50006  dimension zhut(5)
50007  DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/
50008 
50009 C...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 
50013 C...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 
50034 C...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 
50046 C...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 
50053 C...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 
50065 C...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 
50074 C...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 
50089 C...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 
50094 C...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 
50117 C...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 
50126 C...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 
50144 C...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 
50155 C...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 
50171 C*********************************************************************
50172 
50173 C...PYX3JT
50174 C...Selects the kinematical variables of three-jet events.
50175 
50176  SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)
50177 
50178 C...Double precision and integer declarations.
50179  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50180  IMPLICIT INTEGER(I-N)
50181  INTEGER PYK,PYCHGE,PYCOMP
50182 C...Commonblocks.
50183  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50184  SAVE /pydat1/
50185 C...Local array.
50186  dimension zhup(5,12)
50187 
50188 C...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 
50201 C...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 
50205 C...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 
50226 C...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 
50233 C...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 
50243 C...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
50278 C...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 
50309 C...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 
50319 C...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 
50338 C*********************************************************************
50339 
50340 C...PYX4JT
50341 C...Selects the kinematical variables of four-jet events.
50342 
50343  SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
50344 
50345 C...Double precision and integer declarations.
50346  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50347  IMPLICIT INTEGER(I-N)
50348  INTEGER PYK,PYCHGE,PYCOMP
50349 C...Commonblocks.
50350  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50351  SAVE /pydat1/
50352 C...Local arrays.
50353  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
50354 
50355 C...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 
50369 C...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 
50379 C...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 
50398 C...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 
50466 C...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 
50493 C...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 
50511 C...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 
50522 C...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 
50540 C...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 
50562 C*********************************************************************
50563 
50564 C...PYXDIF
50565 C...Gives the angular orientation of events.
50566 
50567  SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
50568 
50569 C...Double precision and integer declarations.
50570  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50571  IMPLICIT INTEGER(I-N)
50572  INTEGER PYK,PYCHGE,PYCOMP
50573 C...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 
50579 C...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 
50589 C...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 
50608 C...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 
50621 C...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 
50633 C...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 
50649 C...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 
50667 C...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 
50677 C...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 
50701 C*********************************************************************
50702 
50703 C...PYONIA
50704 C...Generates Upsilon and toponium decays into three gluons
50705 C...or two gluons and a photon.
50706 
50707  SUBROUTINE pyonia(KFL,ECM)
50708 
50709 C...Double precision and integer declarations.
50710  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50711  IMPLICIT INTEGER(I-N)
50712  INTEGER PYK,PYCHGE,PYCOMP
50713 C...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 
50719 C...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 
50730 C...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 
50752 C...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 
50764 C...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 
50806 C...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 
50820 C...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 
50842 C...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 
50853 C...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 
50861 C*********************************************************************
50862 
50863 C...PYBOOK
50864 C...Books a histogram.
50865 
50866  SUBROUTINE pybook(ID,TITLE,NX,XL,XU)
50867 
50868 C...Double precision declaration.
50869  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50870  IMPLICIT INTEGER(I-N)
50871 C...Commonblock.
50872  common/pybins/ihist(4),indx(1000),bin(20000)
50873  SAVE /pybins/
50874 C...Local character variables.
50875  CHARACTER TITLE*(*), TITFX*60
50876 
50877 C...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 
50890 C...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 
50897 C...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 
50907 C*********************************************************************
50908 
50909 C...PYFILL
50910 C...Fills entry in histogram.
50911 
50912  SUBROUTINE pyfill(ID,X,W)
50913 
50914 C...Double precision declaration.
50915  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50916  IMPLICIT INTEGER(I-N)
50917 C...Commonblock.
50918  common/pybins/ihist(4),indx(1000),bin(20000)
50919  SAVE /pybins/
50920 
50921 C...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 
50929 C...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 
50944 C*********************************************************************
50945 
50946 C...PYFACT
50947 C...Multiplies histogram contents by factor.
50948 
50949  SUBROUTINE pyfact(ID,F)
50950 
50951 C...Double precision declaration.
50952  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50953  IMPLICIT INTEGER(I-N)
50954 C...Commonblock.
50955  common/pybins/ihist(4),indx(1000),bin(20000)
50956  SAVE /pybins/
50957 
50958 C...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 
50971 C*********************************************************************
50972 
50973 C...PYOPER
50974 C...Performs operations between histograms.
50975 
50976  SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)
50977 
50978 C...Double precision declaration.
50979  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50980  IMPLICIT INTEGER(I-N)
50981 C...Commonblock.
50982  common/pybins/ihist(4),indx(1000),bin(20000)
50983  SAVE /pybins/
50984 C...Character variable.
50985  CHARACTER OPER*(*)
50986 
50987 C...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 
50996 C...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 
51003 C...Operations on pair of histograms: addition, subtraction,
51004 C...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 
51027 C...Operations on single histogram: multiplication+addition,
51028 C...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 
51047 C...Operation on two or three histograms: average and
51048 C...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 
51071 C*********************************************************************
51072 
51073 C...PYHIST
51074 C...Prints and resets all histograms.
51075 
51076  SUBROUTINE pyhist
51077 
51078 C...Double precision declaration.
51079  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51080  IMPLICIT INTEGER(I-N)
51081 C...Commonblock.
51082  common/pybins/ihist(4),indx(1000),bin(20000)
51083  SAVE /pybins/
51084 
51085 C...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 
51097 C*********************************************************************
51098 
51099 C...PYPLOT
51100 C...Prints a histogram (but does not reset it).
51101 
51102  SUBROUTINE pyplot(ID)
51103 
51104 C...Double precision declaration.
51105  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51106  IMPLICIT INTEGER(I-N)
51107 C...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/
51111 C...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 
51115 C...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 
51119 C...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 
51128 C...Number of histogram lines and x bins.
51129  lin=ihist(3)-18
51130  nx=nint(bin(is+1))
51131 
51132 C...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 
51139 C...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 
51147 C...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 
51155 C...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 
51168 C...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 
51177 C...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 
51188 C...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 
51203 C...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 
51221 C...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 
51237 C...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 
51253 C*********************************************************************
51254 
51255 C...PYNULL
51256 C...Resets bin contents of a histogram.
51257 
51258  SUBROUTINE pynull(ID)
51259 
51260 C...Double precision declaration.
51261  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51262  IMPLICIT INTEGER(I-N)
51263 C...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 
51277 C*********************************************************************
51278 
51279 C...PYDUMP
51280 C...Dumps histogram contents on file for reading by other program.
51281 C...Can also read back own dump.
51282 
51283  SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)
51284 
51285 C...Double precision declaration.
51286  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51287  IMPLICIT INTEGER(I-N)
51288 C...Commonblock.
51289  common/pybins/ihist(4),indx(1000),bin(20000)
51290  SAVE /pybins/
51291 C...Local arrays and character variables.
51292  dimension ihi(*),iss(100),val(5)
51293  CHARACTER TITLE*60,FORMAT*13
51294 
51295 C...Dump all histograms that have been booked,
51296 C...including titles and ranges, one after the other.
51297  IF(mdump.EQ.1) THEN
51298 
51299 C...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 
51314 C...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 
51327 C...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 
51340 C...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 
51346 C...Read back in histograms dumped MDUMP=1.
51347  ELSEIF(mdump.EQ.2) THEN
51348 
51349 C...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 
51355 C...Read filling statistics.
51356  READ(lfn,5300) nentry,bin(is+6),bin(is+7),bin(is+8)
51357  bin(is+5)=dble(nentry)
51358 
51359 C...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 
51368 C...Go to next histogram; finish.
51369  GOTO 140
51370  170 CONTINUE
51371 
51372 C...Write histogram contents in column format,
51373 C...convenient e.g. for GNUPLOT input.
51374  ELSEIF(mdump.EQ.3) THEN
51375 
51376 C...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 
51400 C...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 
51411 C...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 
51419 C...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 
51428 C*********************************************************************
51429 
51430 C...PYKCUT
51431 C...Dummy routine, which the user can replace in order to make cuts on
51432 C...the kinematics on the parton level before the matrix elements are
51433 C...evaluated and the event is generated. The cross-section estimates
51434 C...will automatically take these cuts into account, so the given
51435 C...values are for the allowed phase space region only. MCUT=0 means
51436 C...that the event has passed the cuts, MCUT=1 that it has failed.
51437 
51438  SUBROUTINE pykcut(MCUT)
51439 
51440 C...Double precision and integer declarations.
51441  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51442  IMPLICIT INTEGER(I-N)
51443  INTEGER PYK,PYCHGE,PYCOMP
51444 C...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 
51450 C...Set default value (accepting event) for MCUT.
51451  mcut=0
51452 
51453 C...Read out subprocess number.
51454  isub=mint(1)
51455  istsb=iset(isub)
51456 
51457 C...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 
51465 C...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 
51475 C...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 
51491 C...Decisions by user to be put here.
51492 
51493 C...Stop program if this routine is ever called.
51494 C...You should not copy these lines to your own routine.
51495  WRITE(mstu(11),5000)
51496  IF(pyr(0).LT.10d0) stop
51497 
51498 C...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 
51506 C*********************************************************************
51507 
51508 C...PYEVWT
51509 C...Dummy routine, which the user can replace in order to multiply the
51510 C...standard PYTHIA differential cross-section by a process- and
51511 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
51512 C...to generation of weighted events, with weight 1/WTXS, while for
51513 C...MSTP(142)=2 it corresponds to a modification of the underlying
51514 C...physics.
51515 
51516  SUBROUTINE pyevwt(WTXS)
51517 
51518 C...Double precision and integer declarations.
51519  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51520  IMPLICIT INTEGER(I-N)
51521  INTEGER PYK,PYCHGE,PYCOMP
51522 C...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 
51528 C...Set default weight for WTXS.
51529  wtxs=1d0
51530 
51531 C...Read out subprocess number.
51532  isub=mint(1)
51533  istsb=iset(isub)
51534 
51535 C...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 
51543 C...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 
51552 C...Modifications by user to be put here.
51553 
51554 C...Stop program if this routine is ever called.
51555 C...You should not copy these lines to your own routine.
51556  WRITE(mstu(11),5000)
51557  IF(pyr(0).LT.10d0) stop
51558 
51559 C...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 
51567 C*********************************************************************
51568 
51569 C...PYUPIN
51570 C...Dummy copy of routine to be called by user to set up a user-defined
51571 C...process.
51572 
51573  SUBROUTINE pyupin(ISUB,TITLE,SIGMAX)
51574 
51575 C...Double precision and integer declarations.
51576  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51577  IMPLICIT INTEGER(I-N)
51578  INTEGER PYK,PYCHGE,PYCOMP
51579 C...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/
51585 C...Local character variable.
51586  CHARACTER*(*) TITLE
51587 
51588 C...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 
51594 C...Fill information on new process.
51595  iset(isub)=11
51596  coef(isub,1)=sigmax
51597  proc(isub)=title//' '
51598 
51599 C...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 
51606 C*********************************************************************
51607 
51608 C...PYUPEV
51609 C...Dummy routine, to be replaced by user. When called from PYTHIA
51610 C...the subprocess number ISUB will be given, and PYUPEV is supposed
51611 C...to generate an event of this type, to be stored in the PYUPPR
51612 C...commonblock. SIGEV gives the differential cross-section associated
51613 C...with the event, i.e. the acceptance probability of the event is
51614 C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
51615 C...call.
51616 
51617  SUBROUTINE pyupev(ISUB,SIGEV)
51618 
51619 C...Double precision and integer declarations.
51620  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51621  IMPLICIT INTEGER(I-N)
51622  INTEGER PYK,PYCHGE,PYCOMP
51623 C...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 
51628 C...Stop program if this routine is ever called.
51629 C...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 
51634 C...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 
51642 C*********************************************************************
51643 
51644 C...PDFSET
51645 C...Dummy routine, to be removed when PDFLIB is to be linked.
51646 
51647  SUBROUTINE pdfset(PARM,VALUE)
51648 
51649 C...Double precision and integer declarations.
51650  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51651  IMPLICIT INTEGER(I-N)
51652  INTEGER PYK,PYCHGE,PYCOMP
51653 C...Commonblocks.
51654  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51655  SAVE /pydat1/
51656 C...Local arrays and character variables.
51657  CHARACTER*20 PARM(20)
51658  DOUBLE PRECISION VALUE(20)
51659 
51660 C...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 
51666 C...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 
51674 C*********************************************************************
51675 
51676 C...STRUCTM
51677 C...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 
51681 C...Double precision and integer declarations.
51682  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51683  IMPLICIT INTEGER(I-N)
51684  INTEGER PYK,PYCHGE,PYCOMP
51685 C...Commonblocks.
51686  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51687  SAVE /pydat1/
51688 C...Local variables
51689  DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
51690 
51691 C...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 
51704 C...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 
51712 C*********************************************************************
51713 
51714 C...STRUCTP
51715 C...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 
51720 C...Double precision and integer declarations.
51721  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51722  IMPLICIT INTEGER(I-N)
51723  INTEGER PYK,PYCHGE,PYCOMP
51724 C...Commonblocks.
51725  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51726  SAVE /pydat1/
51727 C...Local variables
51728  DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
51729  &top,glu
51730 
51731 C...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 
51744 C...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 
51752 C*********************************************************************
51753 
51754 C...PYTAUD
51755 C...Dummy routine, to be replaced by user, to handle the decay of a
51756 C...polarized tau lepton.
51757 C...Input:
51758 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
51759 C...IORIG is the position where the mother of the tau is stored;
51760 C... is 0 when the mother is not stored.
51761 C...KFORIG is the flavour of the mother of the tau;
51762 C... is 0 when the mother is not known.
51763 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
51764 C... e.g. in B hadron semileptonic decays the W propagator
51765 C... is not explicitly stored but the W code is still unambiguous.
51766 C...Output:
51767 C...NDECAY is the number of decay products in the current tau decay.
51768 C...These decay products should be added to the /PYJETS/ common block,
51769 C...in positions N+1 through N+NDECAY. For each product I you must
51770 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
51771 C...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 
51775 C...Double precision and integer declarations.
51776  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51777  IMPLICIT INTEGER(I-N)
51778  INTEGER PYK,PYCHGE,PYCOMP
51779 C...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 
51784 C...Stop program if this routine is ever called.
51785 C...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 
51790 C...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 
51798 C*********************************************************************
51799 
51800 C...PYTIME
51801 C...Finds current date and time.
51802 C...Since this task is not standardized in Fortran 77, the routine
51803 C...is dummy, to be replaced by the user. Examples are given for
51804 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
51805 C...you do not have access to suitable routines.
51806 
51807  SUBROUTINE pytime(IDATI)
51808 
51809 C...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
51814 C...Local array.
51815  INTEGER IDATI(6),IDTEMP(3)
51816 
51817 C...Example 0: if you do not have suitable routines.
51818 C DO 100 J=1,6
51819 C IDATI(J)=0
51820 C 100 CONTINUE
51821 
51822 C...Example 1: Fortran 90 routine.
51823 C INTEGER IVAL(8)
51824 C CALL DATE_AND_TIME(VALUES=IVAL)
51825 C IDATI(1)=IVAL(1)
51826 C IDATI(2)=IVAL(2)
51827 C IDATI(3)=IVAL(3)
51828 C IDATI(4)=IVAL(5)
51829 C IDATI(5)=IVAL(6)
51830 C IDATI(6)=IVAL(7)
51831 
51832 C...Example 2: DEC Fortran 77. AIX.
51833 C CALL IDATE(IMON,IDAY,IYEAR)
51834 C IF(IYEAR.LT.70) THEN
51835 C IDATI(1)=2000+IYEAR
51836 C ELSEIF(IYEAR.LT.100) THEN
51837 C IDATI(1)=1900+IYEAR
51838 C ELSE
51839 C IDATI(1)=IYEAR
51840 C ENDIF
51841 C IDATI(2)=IMON
51842 C IDATI(3)=IDAY
51843 C CALL ITIME(IHOUR,IMIN,ISEC)
51844 C IDATI(4)=IHOUR
51845 C IDATI(5)=IMIN
51846 C IDATI(6)=ISEC
51847 
51848 C...Example 3: DEC Fortran, IRIX, IRIX64.
51849 C CALL IDATE(IMON,IDAY,IYEAR)
51850 C IF(IYEAR.LT.70) THEN
51851 C IDATI(1)=2000+IYEAR
51852 C ELSEIF(IYEAR.LT.100) THEN
51853 C IDATI(1)=1900+IYEAR
51854 C ELSE
51855 C IDATI(1)=IYEAR
51856 C ENDIF
51857 C IDATI(2)=IMON
51858 C IDATI(3)=IDAY
51859 C CALL TIME(ATIME)
51860 C IHOUR=0
51861 C IMIN=0
51862 C ISEC=0
51863 C READ(ATIME(1:2),'(I2)') IHOUR
51864 C READ(ATIME(4:5),'(I2)') IMIN
51865 C READ(ATIME(7:8),'(I2)') ISEC
51866 C IDATI(4)=IHOUR
51867 C IDATI(5)=IMIN
51868 C IDATI(6)=ISEC
51869 
51870 C...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