Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
pythia61.f
Go to the documentation of this file.
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* Argonne National Laboratory **
20 C* 9700 South Cass Avenue, Argonne, IL 60439, USA **
21 C* phone + 1 - 630 - 252 - 7615 **
22 C* E-mail mrenna@hep.anl.gov **
23 C* **
24 C* Several parts are written by Hans-Uno Bengtsson **
25 C* PYSHOW is written together with Mats Bengtsson **
26 C* CTEQ 3 parton distributions are by the CTEQ collaboration **
27 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
28 C* SaS photon parton distributions together with Gerhard Schuler **
29 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
30 C* MSSM Higgs mass calculation code by M. Carena, **
31 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
32 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
33 C* **
34 C* The latest program version and documentation is found on WWW **
35 C* http://thep.lu.se/tf2/staff/torbjorn/Pythia.html **
36 C* **
37 C* Copyright Torbjorn Sjostrand, Lund 1997 **
38 C* **
39 C*********************************************************************
40 C*********************************************************************
41 C *
42 C List of subprograms in order of appearance, with main purpose *
43 C (S = subroutine, F = function, B = block data) *
44 C *
45 C B PYDATA to contain all default values *
46 C S PYTEST to test the proper functioning of the package *
47 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
48 C *
49 C S PYINIT to administer the initialization procedure *
50 C S PYEVNT to administer the generation of an event *
51 C S PYSTAT to print cross-section and other information *
52 C S PYINRE to initialize treatment of resonances *
53 C S PYINBM to read in beam, target and frame choices *
54 C S PYINKI to initialize kinematics of incoming particles *
55 C S PYINPR to set up the selection of included processes *
56 C S PYXTOT to give total, elastic and diffractive cross-sect. *
57 C S PYMAXI to find differential cross-section maxima *
58 C S PYPILE to select multiplicity of pileup events *
59 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
60 C S PYRAND to select subprocess and kinematics for event *
61 C S PYSCAT to set up kinematics and colour flow of event *
62 C S PYSSPA to simulate initial state spacelike showers *
63 C S PYRESD to perform resonance decays *
64 C S PYMULT to generate multiple interactions *
65 C S PYREMN to add on target remnants *
66 C S PYDIFF to set up kinematics for diffractive events *
67 C S PYDOCU to compute cross-sections and handle documentation *
68 C S PYFRAM to perform boosts between different frames *
69 C S PYWIDT to calculate full and partial widths of resonances *
70 C S PYOFSH to calculate partial width into off-shell channels *
71 C S PYRECO to handle colour reconnection in W+W- events *
72 C S PYKLIM to calculate borders of allowed kinematical region *
73 C S PYKMAP to construct value of kinematical variable *
74 C S PYSIGH to calculate differential cross-sections *
75 C S PYPDFU to evaluate parton distributions *
76 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
77 C S PYPDEL to evaluate electron parton distributions *
78 C S PYPDGA to evaluate photon parton distributions (generic) *
79 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
80 C S PYGVMD to evaluate VMD part of photon parton distributions *
81 C S PYGANO to evaluate anomalous part of photon pdf's *
82 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
83 C S PYGDIR to evaluate direct contribution to photon pdf's *
84 C S PYPDPI to evaluate pion parton distributions *
85 C S PYPDPR to evaluate proton parton distributions *
86 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
87 C S PYGRVL to evaluate the GRV 94L pronton parton distributions *
88 C S PYGRVM to evaluate the GRV 94M pronton parton distributions *
89 C S PYGRVD to evaluate the GRV 94D pronton parton distributions *
90 C F PYGRVV auxiliary to the PYGRV* routines *
91 C F PYGRVW auxiliary to the PYGRV* routines *
92 C F PYGRVS auxiliary to the PYGRV* routines *
93 C F PYHFTH to evaluate threshold factor for heavy flavour *
94 C S PYSPLI to find flavours left in hadron when one removed *
95 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
96 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
97 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
98 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
99 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
100 C *
101 C S PYMSIN to initialize the supersymmetry simulation *
102 C S PYAPPS to determine MSSM parameters from SUGRA input *
103 C F PYRNMQ to determine running quark masses *
104 C F PYRNMT to determine running top mass *
105 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
106 C S PYINOM to calculate neutralino/chargino mass eigenstates *
107 C F PYRNM3 to determine running M3, gluino mass *
108 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
109 C S PYHGGM to determine Higgs mass spectrum *
110 C S PYSUBH to determine Higgs masses in the MSSM *
111 C S PYPOLE to determine Higgs masses in the MSSM *
112 C S PYVACU to determine Higgs masses in the MSSM *
113 C S PYRGHM auxiliary to PYVACU *
114 C S PYGFXX auxiliary to PYRGHM *
115 C F PYFINT auxiliary to PYVACU *
116 C F PYFISB auxiliary to PYFINT *
117 C S PYSFDC to calculate sfermion decay partial widths *
118 C S PYGLUI to calculate gluino decay partial widths *
119 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
120 C S PYTBBC to calculate 3-body decay of gluino to chargino *
121 C S PYNJDC to calculate neutralino decay partial widths *
122 C S PYCJDC to calculate chargino decay partial widths *
123 C F PYXXZ5 auxiliary for neutralino 3-body decay *
124 C F PYXXW5 auxiliary for ino charge change 3-body decay *
125 C F PYXXGA auxiliary for ino -> ino + gamma decay *
126 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
127 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
128 C F PYXXZ2 auxiliary for chargino 3-body decay *
129 C S PYHEXT to calculate non-SM Higgs decay partial widths *
130 C F PYH2XX auxiliary for H -> ino + ino decay *
131 C F PYGAUS to perform Gaussian integration *
132 C F PYSIMP to perform Simpson integration *
133 C F PYLAMF to evaluate the lambda kinematics function *
134 C S PYTBDY to perform 3-body decay of gauginos *
135 C *
136 C S PY1ENT to fill one entry (= parton or particle) *
137 C S PY2ENT to fill two entries *
138 C S PY3ENT to fill three entries *
139 C S PY4ENT to fill four entries *
140 C S PYJOIN to connect entries with colour flow information *
141 C S PYGIVE to fill (or query) commonblock variables *
142 C S PYEXEC to administrate fragmentation and decay chain *
143 C S PYPREP to rearrange showered partons along strings *
144 C S PYSTRF to do string fragmentation of jet system *
145 C S PYINDF to do independent fragmentation of one or many jets *
146 C S PYDECY to do the decay of a particle *
147 C S PYKFDI to select parton and hadron flavours in fragm *
148 C S PYPTDI to select transverse momenta in fragm *
149 C S PYZDIS to select longitudinal scaling variable in fragm *
150 C S PYSHOW to do timelike parton shower evolution *
151 C S PYBOEI to include Bose-Einstein effects (crudely) *
152 C F PYMASS to give the mass of a particle or parton *
153 C S PYNAME to give the name of a particle or parton *
154 C F PYCHGE to give three times the electric charge *
155 C F PYCOMP to compress standard KF flavour code to internal KC *
156 C S PYERRM to write error messages and abort faulty run *
157 C F PYALEM to give the alpha_electromagnetic value *
158 C F PYALPS to give the alpha_strong value *
159 C F PYANGL to give the angle from known x and y components *
160 C F PYR to provide a random number generator *
161 C S PYRGET to save the state of the random number generator *
162 C S PYRSET to set the state of the random number generator *
163 C S PYROBO to rotate and/or boost an event *
164 C S PYEDIT to remove unwanted entries from record *
165 C S PYLIST to list event record or particle data *
166 C S PYLOGO to write a logo *
167 C S PYUPDA to update particle data *
168 C F PYK to provide integer-valued event information *
169 C F PYP to provide real-valued event information *
170 C S PYSPHE to perform sphericity analysis *
171 C S PYTHRU to perform thrust analysis *
172 C S PYCLUS to perform three-dimensional cluster analysis *
173 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
174 C S PYJMAS to give high and low jet mass of event *
175 C S PYFOWO to give Fox-Wolfram moments *
176 C S PYTABU to analyze events, with tabular output *
177 C *
178 C S PYEEVT to administrate the generation of an e+e- event *
179 C S PYXTEE to give the total cross-section at given CM energy *
180 C S PYRADK to generate initial state photon radiation *
181 C S PYXKFL to select flavour of primary qqbar pair *
182 C S PYXJET to select (matrix element) jet multiplicity *
183 C S PYX3JT to select kinematics of three-jet event *
184 C S PYX4JT to select kinematics of four-jet event *
185 C S PYXDIF to select angular orientation of event *
186 C S PYONIA to perform generation of onium decay to gluons *
187 C *
188 C S PYBOOK to book a histogram *
189 C S PYFILL to fill an entry in a histogram *
190 C S PYFACT to multiply histogram contents by a factor *
191 C S PYOPER to perform operations between histograms *
192 C S PYHIST to print and reset all histograms *
193 C S PYPLOT to print a single histogram *
194 C S PYNULL to reset contents of a single histogram *
195 C S PYDUMP to dump histogram contents onto a file *
196 C *
197 C S PYKCUT dummy routine for user kinematical cuts *
198 C S PYEVWT dummy routine for weighting events *
199 C S PYUPIN dummy routine to initialize a user process *
200 C S PYUPEV dummy routine to generate a user process event *
201 C S PDFSET dummy routine to be removed when using PDFLIB *
202 C S STRUCTM dummy routine to be removed when using PDFLIB *
203 C S PYTAUD dummy routine for interface to tau decay libraries *
204 C S PYTIME dummy routine for giving date and time *
205 C *
206 C*********************************************************************
207 
208 C...PYDATA
209 C...Default values for switches and parameters,
210 C...and particle, decay and process data.
211 
212  BLOCK DATA pydata
213 
214 C...Double precision and integer declarations.
215  IMPLICIT DOUBLE PRECISION(a-h, o-z)
216  INTEGER pyk,pychge,pycomp
217 C...Commonblocks.
218  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
219  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
220  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
221  common/pydat4/chaf(500,2)
222  CHARACTER chaf*16
223  common/pydatr/mrpy(6),rrpy(100)
224  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
225  common/pypars/mstp(200),parp(200),msti(200),pari(200)
226  common/pyint1/mint(400),vint(400)
227  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
228  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
229  common/pyint4/mwid(500),wids(500,5)
230  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
231  common/pyint6/proc(0:500)
232  CHARACTER proc*28
233  common/pyint7/sigt(0:6,0:6,0:5)
234  common/pymssm/imss(0:99),rmss(0:99)
235  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
236  &sfmix(16,4)
237  common/pybins/ihist(4),indx(1000),bin(20000)
238  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,/pysubs/,
239  &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
240  &/pyint6/,/pyint7/,/pymssm/,/pyssmt/,/pybins/
241 
242 C...PYDAT1, containing status codes and most parameters.
243  DATA mstu/
244  & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
245  1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
246  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
247  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
248  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
249  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
250  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
251  7 30*0,
252  1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
253  2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
254  & 80*0/
255  DATA paru/
256  & 3.141592653589793d0, 6.283185307179586d0,
257  & 0.197327d0, 5.06773d0, 0.389380d0, 2.56819d0, 4*0d0,
258  1 0.001d0, 0.09d0, 0.01d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
259  2 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
260  3 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
261  4 2.0d0, 1.0d0, 0.25d0, 2.5d0, 0.05d0,
262  4 0d0, 0d0, 0.0001d0, 0d0, 0d0,
263  5 2.5d0,1.5d0,7.0d0,1.0d0,0.5d0,2.0d0,3.2d0, 0d0, 0d0, 0d0,
264  6 40*0d0,
265  & 0.00729735d0, 0.232d0, 0.007764d0, 1.0d0, 1.16639d-5,
266  & 0d0, 0d0, 0d0, 0d0, 0d0,
267  1 0.20d0, 0.25d0, 1.0d0, 4.0d0, 10d0, 0d0, 0d0, 0d0, 0d0, 0d0,
268  2 -0.693d0, -1.0d0, 0.387d0, 1.0d0, -0.08d0,
269  2 -1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,
270  3 1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
271  4 5.0d0, 1.0d0, 1.0d0, 0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0,
272  5 1.0d0, 0d0, 0d0, 0d0, 1000d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0,0d0,
273  6 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
274  7 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
275  8 1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
276  9 0d0, 0d0, 0d0, 0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0/
277  DATA mstj/
278  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
279  1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
280  2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
281  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
282  4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
283  5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
284  6 40*0,
285  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
286  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
287  2 80*0/
288  DATA parj/
289  & 0.10d0, 0.30d0, 0.40d0, 0.05d0, 0.50d0,
290  & 0.50d0, 0.50d0, 0d0, 0d0, 0d0,
291  1 0.50d0,0.60d0,0.75d0, 0d0, 0d0, 0d0, 0d0, 1.0d0, 1.0d0, 0d0,
292  2 0.36d0, 1.0d0,0.01d0, 2.0d0,1.0d0,0.4d0, 0d0, 0d0, 0d0, 0d0,
293  3 0.10d0, 1.0d0, 0.8d0, 1.5d0,0d0,2.0d0,0.2d0,2.5d0,0.6d0,0d0,
294  4 0.3d0, 0.58d0, 0.5d0, 0.9d0,0.5d0,1.0d0,1.0d0,1.0d0,0d0,0d0,
295  5 0.77d0, 0.77d0, 0.77d0, -0.05d0, -0.005d0,
296  5 -0.00001d0, -0.00001d0, -0.00001d0, 1.0d0, 0d0,
297  6 4.5d0, 0.7d0, 0d0,0.003d0, 0.5d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
298  7 10d0, 1000d0, 100d0, 1000d0, 0d0, 0.7d0,10d0, 0d0, 0d0, 0d0,
299  8 0.29d0, 1.0d0, 1.0d0, 0d0, 10d0, 10d0, 0d0, 0d0, 0d0, 0d0,
300  9 0.02d0, 1.0d0, 0.2d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
301  & 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
302  1 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
303  2 1.0d0, 0.25d0,91.187d0,2.489d0, 0.01d0,
304  2 2.0d0, 1.0d0, 0.25d0,0.002d0, 0d0,
305  3 0d0, 0d0, 0d0, 0d0, 0.01d0, 0.99d0, 0d0, 0d0, 0.2d0, 0d0,
306  4 60*0d0/
307 
308 C...PYDAT2, with particle data and flavour treatment parameters.
309  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
310  &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,
311  &8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,3*0,4,3*3,
312  &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,
313  &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,
314  &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,
315  &-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,
316  &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,
317  &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
318  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
319  &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,
320  &-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,
321  &6*1,6*0,2*1,165*0/
322  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,
323  &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0,
324  &102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,
325  &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
326  DATA (kchg(i,4),i= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
327  &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
328  &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
329  &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
330  &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
331  &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
332  &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
333  &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
334  &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
335  &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
336  &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
337  &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
338  &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
339  &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
340  &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
341  &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
342  &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
343  &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
344  &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
345  &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
346  DATA (kchg(i,4),i= 294, 500)/20443,20513,20523,20533,20543,20553,
347  &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
348  &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
349  &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
350  &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
351  &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
352  DATA (pmas(i,1),i= 1, 214)/0.0099d0,0.0056d0,0.199d0,1.35d0,
353  &5d0,175d0,2*400d0,2*0d0,0.00051d0,0d0,0.10566d0,0d0,1.777d0,0d0,
354  &400d0,5*0d0,91.187d0,80.33d0,80d0,6*0d0,500d0,900d0,500d0,
355  &3*300d0,350d0,200d0,5000d0,10*0d0,3*100d0,3*200d0,26*0d0,1d0,2d0,
356  &5d0,16*0d0,0.13498d0,0.7685d0,1.318d0,0.49767d0,0d0,0.13957d0,
357  &0.7669d0,1.318d0,0d0,0.54745d0,0.78194d0,1.275d0,2*0.49767d0,
358  &0.8961d0,1.432d0,0.4936d0,0.8916d0,1.425d0,0d0,0.95777d0,
359  &1.0194d0,1.525d0,1.8693d0,2.01d0,2.46d0,1.8645d0,2.0067d0,2.46d0,
360  &1.9685d0,2.1124d0,2.5735d0,0d0,2.9798d0,3.09688d0,3.5562d0,
361  &5.2792d0,5.3248d0,5.83d0,5.2789d0,5.3248d0,5.83d0,5.3693d0,
362  &5.4163d0,6.07d0,6.594d0,6.602d0,7.35d0,9.4d0,9.4603d0,9.9132d0,
363  &0.77133d0,1.234d0,0.57933d0,0.77133d0,0d0,0.93957d0,1.233d0,
364  &0.77133d0,0d0,0.93827d0,1.232d0,1.231d0,0.80473d0,0.92953d0,
365  &1.19744d0,1.3872d0,1.11568d0,0.80473d0,0.92953d0,1.19255d0,
366  &1.3837d0,1.18937d0,1.3828d0,1.09361d0,1.3213d0,1.535d0,1.3149d0,
367  &1.5318d0,1.67245d0,1.96908d0,2.00808d0,2.4521d0,2.5d0,2.2849d0,
368  &2.4703d0,1.96908d0,2.00808d0,2.4535d0,2.5d0,2.4529d0,2.5d0,
369  &2.4656d0,2.15432d0,2.17967d0,2.55d0,2.63d0,2.55d0,2.63d0,2.704d0,
370  &2.8d0,3.27531d0,3.59798d0,3.65648d0,3.59798d0,3.65648d0,
371  &3.78663d0,3.82466d0,4.91594d0,5.38897d0,5.40145d0,5.8d0,5.81d0/
372  DATA (pmas(i,1),i= 215, 500)/5.641d0,5.84d0,7.00575d0,5.38897d0,
373  &5.40145d0,5.8d0,5.81d0,5.8d0,5.81d0,5.84d0,7.00575d0,5.56725d0,
374  &5.57536d0,5.96d0,5.97d0,5.96d0,5.97d0,6.12d0,6.13d0,7.19099d0,
375  &6.67143d0,6.67397d0,7.03724d0,7.0485d0,7.03724d0,7.0485d0,
376  &7.21101d0,7.219d0,8.30945d0,8.31325d0,10.07354d0,10.42272d0,
377  &10.44144d0,10.42272d0,10.44144d0,10.60209d0,10.61426d0,
378  &11.70767d0,11.71147d0,15.11061d0,0.9835d0,1.231d0,0.9835d0,
379  &1.231d0,1d0,1.17d0,1.429d0,1.29d0,1.429d0,1.29d0,2*1.4d0,2.272d0,
380  &2.424d0,2.272d0,2.424d0,2.5d0,2.536d0,3.4151d0,3.46d0,5.68d0,
381  &5.73d0,5.68d0,5.73d0,5.92d0,5.97d0,7.25d0,7.3d0,9.8598d0,9.875d0,
382  &2*1.23d0,1.282d0,2*1.402d0,1.427d0,2*2.372d0,2.56d0,3.5106d0,
383  &2*5.78d0,6.02d0,7.3d0,9.8919d0,3.686d0,10.0233d0,32*500d0,
384  &4*400d0,163*0d0/
385  DATA (pmas(i,2),i= 1, 500)/5*0d0,1.4d0,16*0d0,2.47833d0,
386  &2.069d0,0.00295d0,6*0d0,14.67788d0,0d0,16.79392d0,8.45231d0,
387  &4.93534d0,5.80468d0,19.1898d0,0.39162d0,417.35283d0,62*0d0,
388  &0.151d0,0.107d0,3*0d0,0.149d0,0.107d0,2*0d0,0.00843d0,0.185d0,
389  &2*0d0,0.0505d0,0.109d0,0d0,0.0498d0,0.098d0,0d0,0.0002d0,
390  &0.00443d0,0.076d0,2*0d0,0.023d0,2*0d0,0.023d0,2*0d0,0.015d0,0d0,
391  &0.0013d0,0d0,0.002d0,2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,
392  &2*0d0,0.02d0,4*0d0,0.12d0,4*0d0,0.12d0,3*0d0,2*0.12d0,3*0d0,
393  &0.0394d0,4*0d0,0.036d0,0d0,0.0358d0,2*0d0,0.0099d0,0d0,0.0091d0,
394  &74*0d0,0.06d0,0.142d0,0.06d0,0.142d0,0d0,0.36d0,0.287d0,0.09d0,
395  &0.287d0,0.09d0,0.25d0,0.08d0,0.05d0,0.02d0,0.05d0,0.02d0,0.05d0,
396  &0d0,0.014d0,0.01d0,8*0.05d0,0d0,0.01d0,2*0.4d0,0.025d0,2*0.174d0,
397  &0.053d0,3*0.05d0,0.0009d0,4*0.05d0,3*0d0,19*1d0,0d0,7*1d0,0d0,
398  &1d0,0d0,1d0,0d0,2.60511d0,2.60839d0,0.42904d0,0.41921d0,163*0d0/
399  DATA (pmas(i,3),i= 1, 500)/5*0d0,14d0,16*0d0,24.78326d0,
400  &20.69d0,0.02954d0,6*0d0,146.77876d0,0d0,167.93924d0,84.52308d0,
401  &49.35344d0,58.04675d0,191.89803d0,3.91624d0,4173.5283d0,62*0d0,
402  &0.4d0,0.25d0,3*0d0,0.4d0,0.25d0,2*0d0,0.1d0,0.17d0,2*0d0,0.2d0,
403  &0.12d0,0d0,0.2d0,0.12d0,0d0,0.002d0,0.015d0,0.2d0,2*0d0,0.12d0,
404  &2*0d0,0.12d0,2*0d0,0.05d0,0d0,0.005d0,0d0,0.01d0,2*0d0,0.05d0,
405  &2*0d0,0.05d0,2*0d0,0.05d0,2*0d0,0.05d0,4*0d0,0.14d0,4*0d0,0.14d0,
406  &3*0d0,2*0.14d0,3*0d0,0.04d0,4*0d0,0.035d0,0d0,0.035d0,2*0d0,
407  &0.05d0,0d0,0.05d0,74*0d0,0.05d0,0.25d0,0.05d0,0.25d0,0d0,0.2d0,
408  &0.4d0,0.005d0,0.4d0,0.01d0,0.35d0,0.001d0,0.1d0,0.08d0,0.1d0,
409  &0.08d0,0.1d0,0d0,0.05d0,0.02d0,6*0.1d0,0.05d0,0.1d0,0d0,0.02d0,
410  &2*0.3d0,0.05d0,2*0.3d0,0.02d0,2*0.1d0,0.03d0,0.001d0,4*0.1d0,
411  &3*0d0,19*10d0,0.00001d0,7*10d0,0.00001d0,10d0,0.00001d0,10d0,
412  &0.00001d0,26.05109d0,26.08388d0,4.29043d0,4.19206d0,163*0d0/
413  DATA (pmas(i,4),i= 1, 500)/12*0d0,658654d0,0d0,0.0872d0,68*0d0,
414  &0.1d0,0.387d0,16*0d0,0.00003d0,2*0d0,15500d0,0d0,7804.5d0,6*0d0,
415  &26.762d0,3*0d0,3709d0,6*0d0,0.317d0,2*0d0,0.1244d0,2*0d0,0.14d0,
416  &6*0d0,0.468d0,2*0d0,0.462d0,2*0d0,0.483d0,2*0d0,0.15d0,19*0d0,
417  &44.34d0,0d0,78.88d0,4*0d0,23.96d0,2*0d0,49.1d0,0d0,87.1d0,0d0,
418  &24.6d0,4*0d0,0.0618d0,0.029d0,6*0d0,0.106d0,6*0d0,0.019d0,2*0d0,
419  &7*0.1d0,4*0d0,0.342d0,2*0.387d0,6*0d0,2*0.387d0,6*0d0,0.387d0,
420  &0d0,0.387d0,2*0d0,8*0.387d0,0d0,9*0.387d0,83*0d0,163*0d0/
421  DATA parf/
422  & 0.5d0,0.25d0, 0.5d0,0.25d0, 1d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
423  1 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
424  2 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
425  3 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
426  4 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
427  5 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
428  6 0.75d0, 0.5d0, 0d0,0.1667d0,0.0833d0,0.1667d0,0d0,0d0,0d0, 0d0,
429  7 0d0, 0d0, 1d0,0.3333d0,0.6667d0,0.3333d0,0d0,0d0,0d0, 0d0,
430  8 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
431  9 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
432  & 0.325d0,0.325d0,0.5d0,1.6d0, 5.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
433  1 0d0,0.11d0,0.16d0,0.048d0,0.50d0,0.45d0,0.55d0,0.60d0,0d0,0d0,
434  2 0.2d0, 0.1d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
435  3 1870*0d0/
436  DATA ((vckm(i,j),j=1,4),i=1,4)/
437  & 0.95113d0, 0.04884d0, 0.00003d0, 0.00000d0,
438  & 0.04884d0, 0.94940d0, 0.00176d0, 0.00000d0,
439  & 0.00003d0, 0.00176d0, 0.99821d0, 0.00000d0,
440  & 0.00000d0, 0.00000d0, 0.00000d0, 1.00000d0/
441 
442 C...PYDAT3, with particle decay parameters and data.
443  DATA (mdcy(i,1),i= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
444  &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1,
445  &0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,
446  &2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,
447  &1,0,4*1,163*0/
448  DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
449  &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
450  &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
451  &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
452  &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
453  &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
454  &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
455  &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
456  &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
457  &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
458  &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
459  &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
460  &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
461  &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
462  &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
463  &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
464  &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
465  &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
466  &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
467  &2493,2496,163*0/
468  DATA (mdcy(i,3),i= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
469  &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18,
470  &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6,
471  &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0,
472  &1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,
473  &4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,
474  &1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,
475  &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
476  &15,0,2*4,3,2,163*0/
477  DATA (mdme(i,1),i= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
478  &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
479  &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,2*-1,
480  &6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,197*1,2*-1,2*1,-1,20*1,
481  &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1,
482  &2*-1,1892*1,1503*0/
483  DATA (mdme(i,2),i= 1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
484  &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
485  &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
486  &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0,
487  &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*0,12,2*42,2*11,9*42,0,2,3,
488  &15*0,4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,
489  &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,
490  &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
491  &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,
492  &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,
493  &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
494  &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,
495  &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
496  &4*32,2*4,5*0,828*53,1515*0/
497  DATA (brat(i) ,i= 1, 418)/43*0d0,0.00003d0,0.00177d0,0.9982d0,
498  &33*0d0,1d0,6*0d0,0.1783d0,0.1735d0,0.1131d0,0.2494d0,0.003d0,
499  &0.09d0,0.0027d0,0.01d0,0.0014d0,0.0012d0,2*0.00025d0,0.0071d0,
500  &0.012d0,0.0004d0,0.00075d0,0.00006d0,2*0.00078d0,0.0034d0,0.08d0,
501  &0.011d0,0.0191d0,0.00006d0,0.005d0,0.0133d0,0.0067d0,0.0005d0,
502  &0.0035d0,0.0006d0,0.0015d0,0.00021d0,0.0002d0,0.00075d0,0.0001d0,
503  &0.0002d0,0.0011d0,3*0.0002d0,0.00022d0,0.0004d0,0.0001d0,
504  &2*0.00205d0,2*0.00069d0,0.00025d0,0.00051d0,0.00025d0,35*0d0,
505  &0.15403d0,0.11945d0,0.15402d0,0.11931d0,0.15215d0,3*0d0,
506  &0.03357d0,0.0668d0,0.03357d0,0.0668d0,0.0335d0,0.0668d0,2*0d0,
507  &0.32139d0,0.0165d0,2*0d0,0.0165d0,0.32067d0,2*0d0,0.00001d0,
508  &0.00059d0,6*0d0,2*0.10814d0,0.10806d0,3*0d0,0.00031d0,0.04438d0,
509  &0.88031d0,4*0d0,0.0002d0,0.05531d0,0d0,0.01838d0,0.00071d0,0d0,
510  &0.00009d0,0.00032d0,62*0d0,0.14449d0,0.11223d0,0.14449d0,
511  &0.11223d0,0.14443d0,0.05782d0,2*0d0,0.03172d0,0.06305d0,
512  &0.03172d0,0.06305d0,0.03172d0,0.06305d0,8*0d0,0.24928d0,0.0128d0,
513  &0.00001d0,0d0,0.0128d0,0.24882d0,0.00039d0,0d0,0.00001d0,
514  &0.00046d0,0.22153d0,5*0d0,2*0.08464d0,0.08463d0,7*0d0,0.00005d0,
515  &0.00097d0,5*0d0,0.00007d0,0d0,0.00049d0,0.00001d0,0.00006d0,
516  &0.30591d0,0.68863d0,0d0,0.0038d0,66*0d0,0.00008d0,0.00167d0/
517  DATA (brat(i) ,i= 419, 722)/5*0d0,0.00013d0,0d0,0.00294d0,
518  &0.00001d0,3*0d0,0.99517d0,63*0d0,0.00002d0,0.07231d0,2*0d0,
519  &0.00001d0,0.00269d0,0d0,0.92497d0,18*0d0,0.0024d0,0.99483d0,
520  &0.00278d0,1d0,3*0.21511d0,0.21478d0,2*0d0,2*0.06995d0,2*0d0,1d0,
521  &3*0d0,0.95d0,0.05d0,3*0d0,4*0.25d0,16*0d0,4*0.25d0,20*0d0,1d0,
522  &17*0d0,1d0,2*0.08d0,0.76d0,0.08d0,2*0.105d0,0.04d0,0.5d0,0.08d0,
523  &0.14d0,0.01d0,0.015d0,0.005d0,0.988d0,0.012d0,0.998739d0,
524  &0.00079d0,0.00038d0,0.000046d0,0.000045d0,2*0.34725d0,0.144d0,
525  &0.104d0,0.0245d0,2*0.01225d0,0.0028d0,0.0057d0,0.2112d0,0.1256d0,
526  &2*0.1939d0,2*0.1359d0,0.002d0,0.001d0,0.0006d0,0.999877d0,
527  &0.000123d0,0.99955d0,0.00045d0,2*0.34725d0,0.144d0,0.104d0,
528  &0.049d0,0.0028d0,0.0057d0,0.3923d0,0.321d0,0.2317d0,0.0478d0,
529  &0.0049d0,0.0013d0,0.0003d0,0.0007d0,0.89d0,0.08693d0,0.0221d0,
530  &0.00083d0,2*0.00007d0,0.564d0,0.282d0,0.072d0,0.028d0,0.023d0,
531  &2*0.0115d0,0.005d0,0.003d0,0.6861d0,0.3139d0,2*0.5d0,0.665d0,
532  &0.333d0,0.002d0,0.333d0,0.166d0,0.168d0,0.084d0,0.087d0,0.043d0,
533  &0.059d0,2*0.029d0,0.002d0,0.6352d0,0.2116d0,0.0559d0,0.0173d0,
534  &0.0482d0,0.0318d0,0.666d0,0.333d0,0.001d0,0.332d0,0.166d0,
535  &0.168d0,0.084d0,0.086d0,0.043d0,0.059d0,2*0.029d0,2*0.002d0,
536  &0.437d0,0.208d0,0.302d0,0.0302d0,0.0212d0,0.0016d0,0.48947d0/
537  DATA (brat(i) ,i= 723, 897)/0.34d0,3*0.043d0,0.027d0,0.0126d0,
538  &0.0013d0,0.0003d0,0.00025d0,0.00008d0,0.444d0,2*0.222d0,0.104d0,
539  &2*0.004d0,0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.07d0,
540  &0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.026d0,0.019d0,0.066d0,
541  &0.041d0,0.045d0,0.076d0,0.0073d0,2*0.0047d0,0.026d0,0.001d0,
542  &0.0006d0,0.0066d0,0.005d0,2*0.003d0,2*0.0006d0,2*0.001d0,0.006d0,
543  &0.005d0,0.012d0,0.0057d0,0.067d0,0.008d0,0.0022d0,0.027d0,
544  &0.004d0,0.019d0,0.012d0,0.002d0,0.009d0,0.0218d0,0.001d0,0.022d0,
545  &0.087d0,0.001d0,0.0019d0,0.0015d0,0.0028d0,0.683d0,0.306d0,
546  &0.011d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,
547  &0.034d0,0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.034d0,0.027d0,
548  &2*0.002d0,2*0.004d0,2*0.002d0,0.0365d0,0.045d0,0.073d0,0.062d0,
549  &3*0.021d0,0.0061d0,0.015d0,0.025d0,0.0088d0,0.074d0,0.0109d0,
550  &0.0041d0,0.002d0,0.0035d0,0.0011d0,0.001d0,0.0027d0,2*0.0016d0,
551  &0.0018d0,0.011d0,0.0063d0,0.0052d0,0.018d0,0.016d0,0.0034d0,
552  &0.0036d0,0.0009d0,0.0006d0,0.015d0,0.0923d0,0.018d0,0.022d0,
553  &0.0077d0,0.009d0,0.0075d0,0.024d0,0.0085d0,0.067d0,0.0511d0,
554  &0.017d0,0.0004d0,0.0028d0,0.619d0,0.381d0,0.3d0,0.15d0,0.16d0,
555  &0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.01d0,2*0.02d0,0.03d0,
556  &2*0.005d0,2*0.02d0,0.03d0,2*0.005d0,0.015d0,0.037d0,0.028d0/
557  DATA (brat(i) ,i= 898,1063)/0.079d0,0.095d0,0.052d0,0.0078d0,
558  &4*0.001d0,0.028d0,0.033d0,0.026d0,0.05d0,0.01d0,4*0.005d0,0.25d0,
559  &0.0952d0,0.94d0,0.06d0,2*0.4d0,2*0.1d0,1d0,0.0602d0,0.0601d0,
560  &0.8797d0,0.135d0,0.865d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
561  &0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,
562  &0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,
563  &0.0185d0,0.0135d0,0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,
564  &0.0019d0,0.0025d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,
565  &1d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,
566  &0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,
567  &2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,
568  &0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,0.0185d0,0.0135d0,
569  &0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,0.0019d0,0.0025d0,
570  &0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,1d0,0.3d0,0.15d0,
571  &0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.02d0,0.055d0,
572  &2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
573  &0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,
574  &0.018d0,0.015d0,0.0185d0,0.0135d0,0.025d0,2*0.0002d0,0.0007d0,
575  &2*0.0004d0,0.0014d0,0.001d0,0.0009d0,0.0025d0,0.4291d0,0.08d0,
576  &0.07d0,0.02d0,0.015d0,0.005d0,1d0,2*0.3d0,2*0.2d0,0.047d0/
577  DATA (brat(i) ,i=1064,1254)/0.122d0,0.006d0,0.012d0,0.035d0,
578  &0.012d0,0.035d0,0.003d0,0.007d0,0.15d0,0.037d0,0.008d0,0.002d0,
579  &0.05d0,0.015d0,0.003d0,0.001d0,0.014d0,0.042d0,0.014d0,0.042d0,
580  &0.24d0,0.065d0,0.012d0,0.003d0,0.001d0,0.002d0,0.001d0,0.002d0,
581  &0.014d0,0.003d0,1d0,2*0.3d0,2*0.2d0,1d0,0.0252d0,0.0248d0,
582  &0.0267d0,0.015d0,0.045d0,0.015d0,0.045d0,0.7743d0,0.029d0,0.22d0,
583  &0.78d0,1d0,0.331d0,0.663d0,0.006d0,0.663d0,0.331d0,0.006d0,1d0,
584  &0.999d0,0.001d0,0.88d0,2*0.06d0,0.639d0,0.358d0,0.002d0,0.001d0,
585  &1d0,0.88d0,2*0.06d0,0.516d0,0.483d0,0.001d0,0.88d0,2*0.06d0,
586  &0.9988d0,0.0001d0,0.0006d0,0.0004d0,0.0001d0,0.667d0,0.333d0,
587  &0.9954d0,0.0011d0,0.0035d0,0.333d0,0.667d0,0.676d0,0.234d0,
588  &0.085d0,0.005d0,2*1d0,0.018d0,2*0.005d0,0.003d0,0.002d0,
589  &2*0.006d0,0.018d0,2*0.005d0,0.003d0,0.002d0,2*0.006d0,0.0066d0,
590  &0.025d0,0.016d0,0.0088d0,2*0.005d0,0.0058d0,0.005d0,0.0055d0,
591  &4*0.004d0,2*0.002d0,2*0.004d0,0.003d0,0.002d0,2*0.003d0,
592  &3*0.002d0,2*0.001d0,0.002d0,2*0.001d0,2*0.002d0,0.0013d0,
593  &0.0018d0,5*0.001d0,4*0.003d0,2*0.005d0,2*0.002d0,2*0.001d0,
594  &2*0.002d0,2*0.001d0,0.2432d0,0.057d0,2*0.035d0,0.15d0,2*0.075d0,
595  &0.03d0,2*0.015d0,2*0.08d0,0.76d0,0.08d0,4*1d0,2*0.08d0,0.76d0,
596  &0.08d0,1d0,2*0.5d0,1d0,2*0.5d0,2*0.08d0,0.76d0,0.08d0,1d0/
597  DATA (brat(i) ,i=1255,1447)/2*0.08d0,0.76d0,3*0.08d0,0.76d0,
598  &3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,
599  &3*0.08d0,0.76d0,0.08d0,2*1d0,2*0.105d0,0.04d0,0.0077d0,0.02d0,
600  &0.0235d0,0.0285d0,0.0435d0,0.0011d0,0.0022d0,0.0044d0,0.4291d0,
601  &0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,
602  &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,
603  &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,0.04d0,
604  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
605  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,
606  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,1d0,2*0.105d0,
607  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
608  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
609  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
610  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
611  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
612  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
613  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
614  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
615  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
616  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0/
617  DATA (brat(i) ,i=1448,1648)/0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
618  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
619  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
620  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
621  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
622  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
623  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
624  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
625  &0.015d0,0.005d0,4*1d0,0.52d0,0.26d0,0.11d0,2*0.055d0,0.333d0,
626  &0.334d0,0.333d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,
627  &0.11d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,0.11d0,
628  &0.36d0,0.18d0,0.03d0,2*0.015d0,2*0.2d0,4*0.25d0,0.667d0,0.333d0,
629  &0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.007d0,
630  &0.993d0,1d0,0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,
631  &0.667d0,0.333d0,8*0.5d0,0.02d0,0.98d0,1d0,4*0.5d0,3*0.146d0,
632  &3*0.05d0,0.15d0,2*0.05d0,4*0.024d0,0.066d0,0.667d0,0.333d0,
633  &0.667d0,0.333d0,4*0.25d0,0.667d0,0.333d0,0.667d0,0.333d0,2*0.5d0,
634  &0.273d0,0.727d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.35d0,
635  &0.65d0,2*0.0083d0,0.1866d0,0.324d0,0.184d0,0.027d0,0.001d0,
636  &0.093d0,0.087d0,0.078d0,0.0028d0,3*0.014d0,0.008d0,0.024d0/
637  DATA (brat(i) ,i=1649,4000)/0.008d0,0.024d0,0.425d0,0.02d0,
638  &0.185d0,0.088d0,0.043d0,0.067d0,0.066d0,827*0d0,0.8516d0,
639  &0.00539d0,0.04483d0,0.09819d0,0.85053d0,0.02152d0,0.02989d0,
640  &0.09806d0,0.29439d0,0.10943d0,0.59618d0,0.38983d0,0.61017d0,
641  &1503*0d0/
642  DATA (kfdp(i,1),i= 1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
643  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
644  &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
645  &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
646  &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
647  &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,
648  &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
649  &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
650  &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
651  &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
652  &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
653  &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
654  &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
655  &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
656  &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
657  &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
658  &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
659  &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
660  &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
661  &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
662  DATA (kfdp(i,1),i= 376, 606)/1000003,-1000003,1000004,2000004,
663  &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
664  &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
665  &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
666  &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
667  &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
668  &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
669  &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
670  &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
671  &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
672  &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
673  &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
674  &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
675  &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
676  &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
677  &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
678  &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
679  &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3,
680  &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7,
681  &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
682  DATA (kfdp(i,1),i= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
683  &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
684  &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
685  &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
686  &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
687  &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
688  &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
689  &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
690  &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
691  &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
692  &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
693  &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
694  &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
695  &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
696  &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
697  &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
698  &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
699  &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
700  &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
701  &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
702  DATA (kfdp(i,1),i=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
703  &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
704  &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
705  &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
706  &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
707  &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
708  &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
709  &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
710  &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
711  &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
712  &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
713  &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
714  &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
715  &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
716  &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
717  &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
718  &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
719  &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
720  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
721  &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
722  DATA (kfdp(i,1),i=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
723  &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
724  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
725  &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
726  &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
727  &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
728  &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
729  &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
730  &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
731  &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
732  &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
733  &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
734  &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
735  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
736  &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
737  &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
738  &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
739  &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
740  &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
741  &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
742  DATA (kfdp(i,1),i=1711,1900)/1000025,1000035,1000006,2000006,
743  &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
744  &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
745  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
746  &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
747  &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
748  &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
749  &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
750  &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
751  &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
752  &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
753  &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
754  &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
755  &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
756  &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
757  &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
758  &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
759  &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
760  &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
761  &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
762  DATA (kfdp(i,1),i=1901,2095)/-1000037,1000037,-1000037,1000037,
763  &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
764  &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
765  &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
766  &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
767  &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
768  &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
769  &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
770  &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
771  &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
772  &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
773  &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
774  &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
775  &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
776  &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
777  &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
778  &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
779  &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
780  &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
781  &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
782  DATA (kfdp(i,1),i=2096,2323)/2000003,-2000003,1000004,-1000004,
783  &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
784  &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
785  &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
786  &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
787  &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
788  &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
789  &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
790  &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
791  &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
792  &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
793  &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
794  &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
795  &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
796  &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
797  &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
798  &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
799  &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
800  &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
801  &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
802  DATA (kfdp(i,1),i=2324,4000)/-1000003,-2000003,1000006,2000006,
803  &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
804  &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
805  &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
806  &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
807  &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
808  &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
809  &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
810  &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
811  &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
812  &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
813  &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
814  &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
815  &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
816  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
817  &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
818  &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
819  &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
820  &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
821  &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
822  DATA (kfdp(i,2),i= 1, 337)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
823  &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,4*1000006,3*7,
824  &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,
825  &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
826  &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
827  &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
828  &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
829  &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
830  &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
831  &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
832  &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
833  &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
834  &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
835  &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
836  &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
837  &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
838  &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
839  &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
840  &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
841  &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/
842  DATA (kfdp(i,2),i= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
843  &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
844  &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
845  &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
846  &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
847  &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
848  &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
849  &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
850  &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
851  &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
852  &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
853  &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
854  &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
855  &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
856  &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
857  &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
858  &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
859  &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
860  &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
861  &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
862  DATA (kfdp(i,2),i= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
863  &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
864  &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
865  &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
866  &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
867  &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
868  &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
869  &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
870  &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
871  &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
872  &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
873  &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
874  &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
875  &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
876  &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
877  &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
878  &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
879  &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
880  &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
881  &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
882  DATA (kfdp(i,2),i= 941,1318)/2*-15,211,213,20213,211,213,20213,
883  &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
884  &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
885  &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
886  &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
887  &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
888  &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
889  &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
890  &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
891  &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
892  &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
893  &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
894  &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
895  &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
896  &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
897  &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
898  &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
899  &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
900  &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
901  &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/
902  DATA (kfdp(i,2),i=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
903  &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,
904  &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,
905  &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,
906  &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
907  &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
908  &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
909  &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
910  &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
911  &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
912  &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
913  &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
914  &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
915  &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
916  &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
917  &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
918  &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,
919  &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24,
920  &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11,
921  &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
922  DATA (kfdp(i,2),i=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
923  &4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,
924  &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,
925  &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
926  &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
927  &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
928  &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,
929  &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
930  &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
931  &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
932  &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,
933  &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
934  &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
935  &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
936  &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
937  &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
938  &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
939  &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
940  &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
941  &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
942  DATA (kfdp(i,2),i=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
943  &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
944  &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
945  &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
946  &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
947  &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
948  &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
949  &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25,
950  &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6,
951  &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
952  &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
953  &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
954  DATA (kfdp(i,3),i= 1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
955  &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
956  &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
957  &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
958  &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
959  &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
960  &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
961  &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
962  &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
963  &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
964  &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
965  &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
966  &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
967  &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
968  &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
969  &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
970  &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
971  &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
972  &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
973  &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
974  DATA (kfdp(i,3),i=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
975  &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
976  &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
977  &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
978  &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
979  &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
980  &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,
981  &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,
982  &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,
983  &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
984  &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
985  &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
986  &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
987  &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
988  &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
989  &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
990  &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
991  &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
992  &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
993  &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
994  DATA (kfdp(i,3),i=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
995  &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
996  &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
997  &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
998  DATA (kfdp(i,4),i= 1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
999  &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1000  &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1001  &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1002  &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1003  &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1004  &-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,
1005  &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1006  &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,
1007  &162*81,31*0,-211,111,2450*0/
1008  DATA (kfdp(i,5),i= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
1009  &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1010  &3*111,-211,111,3127*0/
1011 
1012 C...PYDAT4, with particle names (character strings).
1013  DATA (chaf(i,1),i= 1, 190)/'d','u','s','c','b','t','b''','t''',
1014  &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1015  &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1016  &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1017  &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1018  &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
1019  &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
1020  &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
1021  &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
1022  &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
1023  &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
1024  &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
1025  &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
1026  &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
1027  &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
1028  &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
1029  &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
1030  &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
1031  &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
1032  &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
1033  DATA (chaf(i,1),i= 191, 317)/'Sigma*_c+','Sigma_c++',
1034  &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
1035  &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
1036  &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
1037  &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
1038  &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1039  &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1040  &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1041  &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1042  &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1043  &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1044  &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1045  &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1046  &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1047  &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1048  &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1049  &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1050  &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1051  &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1052  &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
1053  DATA (chaf(i,1),i= 318, 500)/'~chi_30','~chi_40','~chi_2+',
1054  &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
1055  &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
1056  &'nu*_e0',163*' '/
1057  DATA (chaf(i,2),i= 1, 206)/'dbar','ubar','sbar','cbar','bbar',
1058  &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1059  &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1060  &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1061  &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
1062  &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
1063  &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
1064  &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
1065  &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
1066  &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
1067  &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
1068  &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
1069  &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
1070  &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
1071  &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
1072  &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
1073  &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
1074  &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
1075  &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1076  &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
1077  DATA (chaf(i,2),i= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
1078  &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
1079  &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
1080  &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
1081  &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
1082  &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
1083  &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
1084  &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
1085  &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
1086  &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
1087  &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1088  &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1089  &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1090  &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1091  &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1092  &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1093  &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1094  &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1095  &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1096  &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
1097  DATA (chaf(i,2),i= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
1098  &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1099  &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1100 
1101 C...PYDATR, with initial values for the random number generator.
1102  DATA mrpy/19780503,0,0,97,33,0/
1103 
1104 C...Default values for allowed processes and kinematics constraints.
1105  DATA msel/1/
1106  DATA msub/500*0/
1107  DATA ((kfin(i,j),j=-40,40),i=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1108  &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,
1109  &6*1,4*0,4*1,16*0/
1110  DATA ckin/
1111  & 2.0d0, -1.0d0, 0.0d0, -1.0d0, 1.0d0,
1112  & 1.0d0, -10d0, 10d0, -10d0, 10d0,
1113  1 -10d0, 10d0, -10d0, 10d0, -10d0,
1114  1 10d0, -1.0d0, 1.0d0, -1.0d0, 1.0d0,
1115  2 0.0d0, 1.0d0, 0.0d0, 1.0d0, -1.0d0,
1116  2 1.0d0, -1.0d0, 1.0d0, 0d0, 0d0,
1117  3 2.0d0, -1.0d0, 0d0, 0d0, 0.0d0,
1118  3 -1.0d0, 0.0d0, -1.0d0, 4.0d0, -1.0d0,
1119  4 12.0d0, -1.0d0, 12.0d0, -1.0d0, 12.0d0,
1120  4 -1.0d0, 12.0d0, -1.0d0, 0d0, 0d0,
1121  5 0.0d0, -1.0d0, 0.0d0, -1.0d0, 0.0d0,
1122  5 -1.0d0, 0d0, 0d0, 0d0, 0d0,
1123  6 140*0d0/
1124 
1125 C...Default values for main switches and parameters. Reset information.
1126  DATA (mstp(i),i=1,100)/
1127  & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1128  1 1, 0, 1, 0, 5, 0, 0, 0, 0, 0,
1129  2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1130  3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0,
1131  4 1, 1, 3, 7, 3, 1, 1, 2, 1, 0,
1132  5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7,
1133  6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0,
1134  7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1135  8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
1136  9 1, 4, 1, 2, 0, 0, 0, 0, 0, 0/
1137  DATA (mstp(i),i=101,200)/
1138  & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1139  1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1140  2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1141  3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1142  4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1143  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1144  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1145  7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1146  8 6, 102, 1997, 04, 22, 0, 0, 0, 0, 0,
1147  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1148  DATA (parp(i),i=1,100)/
1149  & 0.25d0, 10d0, 8*0d0,
1150  1 0d0, 0d0, 1.0d0, 0.01d0, 0.6d0, 1.0d0, 1.0d0, 3*0d0,
1151  2 10*0d0,
1152  3 1.5d0,2.0d0,0.075d0,1.0d0,0.2d0,0d0,2.0d0,0.70d0,0.006d0,0d0,
1153  4 0.02d0,2.0d0,0.10d0,1000d0,2054d0, 123d0, 246d0, 50d0, 2*0d0,
1154  5 1.0d0, 9*0d0,
1155  6 0.25d0, 1.0d0,0.25d0, 1.0d0, 2.0d0,1d-3, 4.0d0,1d-3,2*0d0,
1156  7 4.0d0, 0.25d0, 8*0d0,
1157  8 1.40d0,1.55d0,0.5d0, 0.2d0,0.33d0,0.66d0, 0.7d0, 0.5d0,2*0d0,
1158  9 0.44d0,0.20d0,2.0d0,1.0d0,0d0,3.0d0,1.0d0,0.75d0,0.44d0,2.0d0/
1159  DATA (parp(i),i=101,200)/
1160  & 0.5d0, 0.28d0, 1.0d0, 0.8d0, 6*0d0,
1161  1 2.0d0, 3*0d0, 1.5d0, 0.5d0, 0.6d0, 2.5d0, 2.0d0, 1.0d0,
1162  2 1.0d0, 0.4d0, 8*0d0,
1163  3 0.01d0, 9*0d0,
1164  4 0.33333d0, 82d0, 1d0, 4d0, 200d0, 5*0d0,
1165  5 0d0, 0d0, 0d0, 0d0, 6*0d0,
1166  6 2.20d0, 23.6d0, 18.4d0, 11.5d0, 6*0d0,
1167  7 0d0, 0d0, 0d0, 1.0d0, 6*0d0,
1168  8 20*0d0/
1169  DATA msti/200*0/
1170  DATA pari/200*0d0/
1171  DATA mint/400*0/
1172  DATA vint/400*0d0/
1173 
1174 C...Constants for the generation of the various processes.
1175  DATA (iset(i),i=1,100)/
1176  & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1177  1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1178  2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1179  3 2, -1, 2, 2, 2, 2, -1, -1, -1, -1,
1180  4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1181  5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1182  6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1183  7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1184  8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1185  9 0, 0, 0, 0, 0, 9, -2, -2, -2, -2/
1186  DATA (iset(i),i=101,200)/
1187  & -1, 1, 1, -2, -2, -2, -2, -2, -2, 2,
1188  1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1189  2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1190  3 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1191  4 1, 1, 1, 1, 1, -2, 1, 1, 1, -2,
1192  5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1193  6 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1194  7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1195  8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1196  9 1, 1, 1, 2, -2, -2, -2, -2, -2, -2/
1197  DATA (iset(i),i=201,300)/
1198  & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1199  1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1200  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1201  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1202  4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1203  5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1204  6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1205  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1206  8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1207  9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
1208  DATA (iset(i),i=301,500)/200*-2/
1209  DATA ((kfpr(i,j),j=1,2),i=1,50)/
1210  & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1211  & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1212  1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1213  1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1214  2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1215  2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1216  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1217  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1218  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1219  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1220  DATA ((kfpr(i,j),j=1,2),i=51,100)/
1221  5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1222  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1223  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1224  6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1225  7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1226  7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1227  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1228  8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1229  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1230  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1231  DATA ((kfpr(i,j),j=1,2),i=101,150)/
1232  & 23, 0, 25, 0, 25, 0, 0, 0, 0, 0,
1233  & 0, 0, 0, 0, 0, 0, 0, 0, 22, 25,
1234  1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1235  1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1236  2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1237  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1238  3 23, 5, 0, 0, 0, 0, 0, 0, 0, 0,
1239  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1240  4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1241  4 0, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1242  DATA ((kfpr(i,j),j=1,2),i=151,200)/
1243  5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1244  5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1245  6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1246  6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 0, 0,
1247  7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1248  7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1249  8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1250  8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1251  9 54, 0, 55, 0, 56, 0, 11, 0, 0, 0,
1252  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1253  DATA ((kfpr(i,j),j=1,2),i=201,240)/
1254  & 1000011, 1000011, 2000011, 2000011, 1000011,
1255  & 2000011, 1000013, 1000013, 2000013, 2000013,
1256  & 1000013, 2000013, 1000015, 1000015, 2000015,
1257  & 2000015, 1000015, 2000015, 1000011, 1000012,
1258  1 1000015, 1000016, 2000015, 1000016, 1000012,
1259  1 1000012, 1000016, 1000016, 0, 0,
1260  1 1000022, 1000022, 1000023, 1000023, 1000025,
1261  1 1000025, 1000035, 1000035, 1000022, 1000023,
1262  2 1000022, 1000025, 1000022, 1000035, 1000023,
1263  2 1000025, 1000023, 1000035, 1000025, 1000035,
1264  2 1000024, 1000024, 1000037, 1000037, 1000024,
1265  2 1000037, 1000022, 1000024, 1000023, 1000024,
1266  3 1000025, 1000024, 1000035, 1000024, 1000022,
1267  3 1000037, 1000023, 1000037, 1000025, 1000037,
1268  3 1000035, 1000037, 1000021, 1000022, 1000021,
1269  3 1000023, 1000021, 1000025, 1000021, 1000035/
1270  DATA ((kfpr(i,j),j=1,2),i=241,280)/
1271  4 1000021, 1000024, 1000021, 1000037, 1000021,
1272  4 1000021, 1000021, 1000021, 0, 0,
1273  4 1000002, 1000022, 2000002, 1000022, 1000002,
1274  4 1000023, 2000002, 1000023, 1000002, 1000025,
1275  5 2000002, 1000025, 1000002, 1000035, 2000002,
1276  5 1000035, 1000001, 1000024, 2000005, 1000024,
1277  5 1000001, 1000037, 2000005, 1000037, 1000002,
1278  5 1000021, 2000002, 1000021, 0, 0,
1279  6 1000006, 1000006, 2000006, 2000006, 1000006,
1280  6 2000006, 1000006, 1000006, 2000006, 2000006,
1281  6 0, 0, 0, 0, 0,
1282  6 0, 0, 0, 0, 0,
1283  7 1000002, 1000002, 2000002, 2000002, 1000002,
1284  7 2000002, 1000002, 1000002, 2000002, 2000002,
1285  7 1000002, 2000002, 1000002, 1000002, 2000002,
1286  7 2000002, 1000002, 1000002, 2000002, 2000002/
1287  DATA ((kfpr(i,j),j=1,2),i=281,500)/440*0/
1288  DATA coef/10000*0d0/
1289  DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/
1290  &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,
1291  &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,
1292  &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,
1293  &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,
1294  &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,
1295  &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,
1296  &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,
1297  &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,
1298  &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,
1299  &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/
1300 
1301 C...Treatment of resonances.
1302  DATA (mwid(i) ,i= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1303  &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1304 
1305 C...Character constants: name of processes.
1306  DATA proc(0)/ 'All included subprocesses '/
1307  DATA (proc(i),i=1,20)/
1308  &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1309  &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1310  &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1311  &' ', 'W+ + W- -> h0 ',
1312  &' ', 'f + f'' -> f + f'' (QFD) ',
1313  1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1314  1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1315  1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1316  1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1317  1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1318  DATA (proc(i),i=21,40)/
1319  2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1320  2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1321  2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1322  2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1323  2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1324  3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1325  3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1326  3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1327  3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1328  3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1329  DATA (proc(i),i=41,60)/
1330  4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1331  4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1332  4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1333  4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1334  4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1335  5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1336  5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1337  5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1338  5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1339  5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1340  DATA (proc(i),i=61,80)/
1341  6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1342  6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1343  6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1344  6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1345  6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1346  7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1347  7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1348  7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1349  7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1350  7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1351  DATA (proc(i),i=81,100)/
1352  8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1353  8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1354  8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1355  8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1356  8'g + g -> chi_2c + g ', ' ',
1357  9'Elastic scattering ', 'Single diffractive (XB) ',
1358  9'Single diffractive (AX) ', 'Double diffractive ',
1359  9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1360  9' ', ' ',
1361  9' ', ' '/
1362  DATA (proc(i),i=101,120)/
1363  &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1364  &'gamma + gamma -> h0 ', ' ',
1365  &' ', ' ',
1366  &' ', ' ',
1367  &' ', 'f + fbar -> gamma + h0 ',
1368  1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1369  1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1370  1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1371  1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1372  1' ', ' '/
1373  DATA (proc(i),i=121,140)/
1374  2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1375  2'f + f'' -> f + f'' + h0 ',
1376  2'f + f'' -> f" + f"'' + h0 ',
1377  2' ', ' ',
1378  2' ', ' ',
1379  2' ', ' ',
1380  3'g + g -> Z0 + q + qbar ', ' ',
1381  3' ', ' ',
1382  3' ', ' ',
1383  3' ', ' ',
1384  3' ', ' '/
1385  DATA (proc(i),i=141,160)/
1386  4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1387  4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1388  4'q + l -> LQ ', ' ',
1389  4'd + g -> d* ', 'u + g -> u* ',
1390  4'g + g -> eta_techni ', ' ',
1391  5'f + fbar -> H0 ', 'g + g -> H0 ',
1392  5'gamma + gamma -> H0 ', ' ',
1393  5' ', 'f + fbar -> A0 ',
1394  5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1395  5' ', ' '/
1396  DATA (proc(i),i=161,180)/
1397  6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1398  6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1399  6'f + fbar -> f'' + fbar'' (g/Z)',
1400  6'f +fbar'' -> f" + fbar"'' (W) ',
1401  6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1402  6' ', ' ',
1403  7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1404  7'f + f'' -> f + f'' + H0 ',
1405  7'f + f'' -> f" + f"'' + H0 ',
1406  7' ', 'f + fbar -> Z0 + A0 ',
1407  7'f + fbar'' -> W+/- + A0 ',
1408  7'f + f'' -> f + f'' + A0 ',
1409  7'f + f'' -> f" + f"'' + A0 ',
1410  7' '/
1411  DATA (proc(i),i=181,200)/
1412  8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1413  8' ', ' ',
1414  8' ', 'g + g -> Q + Qbar + A0 ',
1415  8'q + qbar -> Q + Qbar + A0 ', ' ',
1416  8' ', ' ',
1417  9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1418  9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)',
1419  9' ', ' ',
1420  9' ', ' ',
1421  9' ', ' '/
1422  DATA (proc(i),i=201,220)/
1423  &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1424  &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1425  &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1426  &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1427  &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1428  1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1429  1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1430  1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1431  1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1432  1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1433  DATA (proc(i),i=221,240)/
1434  2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1435  2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1436  2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1437  2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1438  2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1439  3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1440  3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1441  3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1442  3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1443  3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1444  DATA (proc(i),i=241,260)/
1445  4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1446  4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1447  4' ', 'qj + g -> ~qj_L + ~chi1 ',
1448  4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1449  4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1450  5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1451  5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1452  5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1453  5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1454  5'qj + g -> ~qj_R + ~g ', ' '/
1455  DATA (proc(i),i=261,280)/
1456  6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1457  6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1458  6'g + g -> ~t_2 + ~t_2bar ', ' ',
1459  6' ', ' ',
1460  6' ', ' ',
1461  7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1462  7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1463  7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1464  7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1465  7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar '/
1466  DATA (proc(i),i=281,500)/220*' '/
1467 
1468 C...Cross sections and slope offsets.
1469  DATA sigt/294*0d0/
1470 
1471 C...Supersymmetry switches and parameters.
1472  DATA imss/0,
1473  & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1474  1 89*0/
1475  DATA rmss/0d0,
1476  & 80d0,160d0,500d0,800d0,2d0,250d0,200d0,800d0,700d0,800d0,
1477  1 700d0,500d0,250d0,200d0,800d0,400d0,0d0,0.1d0,850d0,0.041d0,
1478  2 1d0,800d0,1d4,1d4,1d4,0d0,0d0,24d17,2*0d0,
1479  3 69*0d0/
1480 
1481 C...Data for histogramming routines.
1482  DATA ihist/1000,20000,55,1/
1483  DATA indx/1000*0/
1484 
1485  END
1486 
1487 C*********************************************************************
1488 
1489 C...PYTEST
1490 C...A simple program (disguised as subroutine) to run at installation
1491 C...as a check that the program works as intended.
1492 
1493  SUBROUTINE pytest(MTEST)
1494 
1495 C...Double precision and integer declarations.
1496  IMPLICIT DOUBLE PRECISION(a-h, o-z)
1497  INTEGER pyk,pychge,pycomp
1498 C...Commonblocks.
1499  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
1500  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
1501  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
1502  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
1503  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
1504  common/pypars/mstp(200),parp(200),msti(200),pari(200)
1505  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
1506 C...Local arrays.
1507  dimension psum(5),pini(6),pfin(6)
1508 
1509 C...Save defaults for values that are changed.
1510  mstj1=mstj(1)
1511  mstj3=mstj(3)
1512  mstj11=mstj(11)
1513  mstj42=mstj(42)
1514  mstj43=mstj(43)
1515  mstj44=mstj(44)
1516  parj17=parj(17)
1517  parj22=parj(22)
1518  parj43=parj(43)
1519  parj54=parj(54)
1520  mst101=mstj(101)
1521  mst104=mstj(104)
1522  mst105=mstj(105)
1523  mst107=mstj(107)
1524  mst116=mstj(116)
1525 
1526 C...First part: loop over simple events to be generated.
1527  IF(mtest.GE.1) CALL pytabu(20)
1528  nerr=0
1529  DO 180 iev=1,500
1530 
1531 C...Reset parameter values. Switch on some nonstandard features.
1532  mstj(1)=1
1533  mstj(3)=0
1534  mstj(11)=1
1535  mstj(42)=2
1536  mstj(43)=4
1537  mstj(44)=2
1538  parj(17)=0.1d0
1539  parj(22)=1.5d0
1540  parj(43)=1d0
1541  parj(54)=-0.05d0
1542  mstj(101)=5
1543  mstj(104)=5
1544  mstj(105)=0
1545  mstj(107)=1
1546  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
1547 
1548 C...Ten events each for some single jets configurations.
1549  IF(iev.LE.50) THEN
1550  ity=(iev+9)/10
1551  mstj(3)=-1
1552  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
1553  IF(ity.EQ.1) CALL py1ent(1,1,15d0,0d0,0d0)
1554  IF(ity.EQ.2) CALL py1ent(1,3101,15d0,0d0,0d0)
1555  IF(ity.EQ.3) CALL py1ent(1,-2203,15d0,0d0,0d0)
1556  IF(ity.EQ.4) CALL py1ent(1,-4,30d0,0d0,0d0)
1557  IF(ity.EQ.5) CALL py1ent(1,21,15d0,0d0,0d0)
1558 
1559 C...Ten events each for some simple jet systems; string fragmentation.
1560  ELSEIF(iev.LE.130) THEN
1561  ity=(iev-41)/10
1562  IF(ity.EQ.1) CALL py2ent(1,1,-1,40d0)
1563  IF(ity.EQ.2) CALL py2ent(1,4,-4,30d0)
1564  IF(ity.EQ.3) CALL py2ent(1,2,2103,100d0)
1565  IF(ity.EQ.4) CALL py2ent(1,21,21,40d0)
1566  IF(ity.EQ.5) CALL py3ent(1,2101,21,-3203,30d0,0.6d0,0.8d0)
1567  IF(ity.EQ.6) CALL py3ent(1,5,21,-5,40d0,0.9d0,0.8d0)
1568  IF(ity.EQ.7) CALL py3ent(1,21,21,21,60d0,0.7d0,0.5d0)
1569  IF(ity.EQ.8) CALL py4ent(1,2,21,21,-2,40d0,
1570  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
1571 
1572 C...Seventy events with independent fragmentation and momentum cons.
1573  ELSEIF(iev.LE.200) THEN
1574  ity=1+(iev-131)/16
1575  mstj(2)=1+mod(iev-131,4)
1576  mstj(3)=1+mod((iev-131)/4,4)
1577  IF(ity.EQ.1) CALL py2ent(1,4,-5,40d0)
1578  IF(ity.EQ.2) CALL py3ent(1,3,21,-3,40d0,0.9d0,0.4d0)
1579  IF(ity.EQ.3) CALL py4ent(1,2,21,21,-2,40d0,
1580  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
1581  IF(ity.GE.4) CALL py4ent(1,2,-3,3,-2,40d0,
1582  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
1583 
1584 C...A hundred events with random jets (check invariant mass).
1585  ELSEIF(iev.LE.300) THEN
1586  100 DO 110 j=1,5
1587  psum(j)=0d0
1588  110 CONTINUE
1589  njet=2d0+6d0*pyr(0)
1590  DO 130 i=1,njet
1591  kfl=21
1592  IF(i.EQ.1) kfl=int(1d0+4d0*pyr(0))
1593  IF(i.EQ.njet) kfl=-int(1d0+4d0*pyr(0))
1594  ejet=5d0+20d0*pyr(0)
1595  theta=acos(2d0*pyr(0)-1d0)
1596  phi=6.2832d0*pyr(0)
1597  IF(i.LT.njet) CALL py1ent(-i,kfl,ejet,theta,phi)
1598  IF(i.EQ.njet) CALL py1ent(i,kfl,ejet,theta,phi)
1599  IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
1600  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+pymass(kfl)
1601  DO 120 j=1,4
1602  psum(j)=psum(j)+p(i,j)
1603  120 CONTINUE
1604  130 CONTINUE
1605  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
1606  & (psum(5)+parj(32))**2) goto 100
1607 
1608 C...Fifty e+e- continuum events with matrix elements.
1609  ELSEIF(iev.LE.350) THEN
1610  mstj(101)=2
1611  CALL pyeevt(0,40d0)
1612 
1613 C...Fifty e+e- continuum event with varying shower options.
1614  ELSEIF(iev.LE.400) THEN
1615  mstj(42)=1+mod(iev,2)
1616  mstj(43)=1+mod(iev/2,4)
1617  mstj(44)=mod(iev/8,3)
1618  CALL pyeevt(0,90d0)
1619 
1620 C...Fifty e+e- continuum events with coherent shower.
1621  ELSEIF(iev.LE.450) THEN
1622  CALL pyeevt(0,500d0)
1623 
1624 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1625  ELSE
1626  CALL pyonia(5,9.46d0)
1627  ENDIF
1628 
1629 C...Generate event. Find total momentum, energy and charge.
1630  DO 140 j=1,4
1631  pini(j)=pyp(0,j)
1632  140 CONTINUE
1633  pini(6)=pyp(0,6)
1634  CALL pyexec
1635  DO 150 j=1,4
1636  pfin(j)=pyp(0,j)
1637  150 CONTINUE
1638  pfin(6)=pyp(0,6)
1639 
1640 C...Check conservation of energy, momentum and charge;
1641 C...usually exact, but only approximate for single jets.
1642  merr=0
1643  IF(iev.LE.50) THEN
1644  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4d0)
1645  & merr=merr+1
1646  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
1647  IF(epzrem.LT.0d0.OR.epzrem.GT.2d0*parj(31)) merr=merr+1
1648  IF(abs(pfin(6)-pini(6)).GT.2.1d0) merr=merr+1
1649  ELSE
1650  DO 160 j=1,4
1651  IF(abs(pfin(j)-pini(j)).GT.0.0001d0*pini(4)) merr=merr+1
1652  160 CONTINUE
1653  IF(abs(pfin(6)-pini(6)).GT.0.1d0) merr=merr+1
1654  ENDIF
1655  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
1656  & (pfin(j),j=1,4),pfin(6)
1657 
1658 C...Check that all KF codes are known ones, and that partons/particles
1659 C...satisfy energy-momentum-mass relation. Store particle statistics.
1660  DO 170 i=1,n
1661  IF(k(i,1).GT.20) goto 170
1662  IF(pycomp(k(i,2)).EQ.0) THEN
1663  WRITE(mstu(11),5100) i
1664  merr=merr+1
1665  ENDIF
1666  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
1667  IF(abs(pd).GT.max(0.1d0,0.001d0*p(i,4)**2).OR.p(i,4).LT.0d0)
1668  & THEN
1669  WRITE(mstu(11),5200) i
1670  merr=merr+1
1671  ENDIF
1672  170 CONTINUE
1673  IF(mtest.GE.1) CALL pytabu(21)
1674 
1675 C...List all erroneous events and some normal ones.
1676  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
1677  IF(merr.GE.1) WRITE(mstu(11),6400)
1678  CALL pylist(2)
1679  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
1680  CALL pylist(1)
1681  ENDIF
1682 
1683 C...Stop execution if too many errors.
1684  IF(merr.NE.0) nerr=nerr+1
1685  IF(nerr.GE.10) THEN
1686  WRITE(mstu(11),6300)
1687  CALL pylist(1)
1688  stop
1689  ENDIF
1690  180 CONTINUE
1691 
1692 C...Summarize result of run.
1693  IF(mtest.GE.1) CALL pytabu(22)
1694 
1695 C...Reset commonblock variables changed during run.
1696  mstj(1)=mstj1
1697  mstj(3)=mstj3
1698  mstj(11)=mstj11
1699  mstj(42)=mstj42
1700  mstj(43)=mstj43
1701  mstj(44)=mstj44
1702  parj(17)=parj17
1703  parj(22)=parj22
1704  parj(43)=parj43
1705  parj(54)=parj54
1706  mstj(101)=mst101
1707  mstj(104)=mst104
1708  mstj(105)=mst105
1709  mstj(107)=mst107
1710  mstj(116)=mst116
1711 
1712 C...Second part: complete events of various kinds.
1713 C...Common initial values. Loop over initiating conditions.
1714  mstp(122)=max(0,min(2,mtest))
1715  mdcy(pycomp(111),1)=0
1716  DO 230 iproc=1,8
1717 
1718 C...Reset process type, kinematics cuts, and the flags used.
1719  msel=0
1720  DO 190 isub=1,500
1721  msub(isub)=0
1722  190 CONTINUE
1723  ckin(1)=2d0
1724  ckin(3)=0d0
1725  mstp(2)=1
1726  mstp(11)=0
1727  mstp(33)=0
1728  mstp(81)=1
1729  mstp(82)=1
1730  mstp(111)=1
1731  mstp(131)=0
1732  mstp(133)=0
1733  parp(131)=0.01d0
1734 
1735 C...Prompt photon production at fixed target.
1736  IF(iproc.EQ.1) THEN
1737  pzsum=300d0
1738  pesum=sqrt(pzsum**2+pymass(211)**2)+pymass(2212)
1739  pqsum=2d0
1740  msel=10
1741  ckin(3)=5d0
1742  CALL pyinit('FIXT','pi+','p',pzsum)
1743 
1744 C...QCD processes at ISR energies.
1745  ELSEIF(iproc.EQ.2) THEN
1746  pesum=63d0
1747  pzsum=0d0
1748  pqsum=2d0
1749  msel=1
1750  ckin(3)=5d0
1751  CALL pyinit('CMS','p','p',pesum)
1752 
1753 C...W production + multiple interactions at CERN Collider.
1754  ELSEIF(iproc.EQ.3) THEN
1755  pesum=630d0
1756  pzsum=0d0
1757  pqsum=0d0
1758  msel=12
1759  ckin(1)=20d0
1760  mstp(82)=4
1761  mstp(2)=2
1762  mstp(33)=3
1763  CALL pyinit('CMS','p','pbar',pesum)
1764 
1765 C...W/Z gauge boson pairs + pileup events at the Tevatron.
1766  ELSEIF(iproc.EQ.4) THEN
1767  pesum=1800d0
1768  pzsum=0d0
1769  pqsum=0d0
1770  msub(22)=1
1771  msub(23)=1
1772  msub(25)=1
1773  ckin(1)=200d0
1774  mstp(111)=0
1775  mstp(131)=1
1776  mstp(133)=2
1777  parp(131)=0.04d0
1778  CALL pyinit('CMS','p','pbar',pesum)
1779 
1780 C...Higgs production at LHC.
1781  ELSEIF(iproc.EQ.5) THEN
1782  pesum=15400d0
1783  pzsum=0d0
1784  pqsum=2d0
1785  msub(3)=1
1786  msub(102)=1
1787  msub(123)=1
1788  msub(124)=1
1789  pmas(25,1)=300d0
1790  ckin(1)=200d0
1791  mstp(81)=0
1792  mstp(111)=0
1793  CALL pyinit('CMS','p','p',pesum)
1794 
1795 C...Z' production at SSC.
1796  ELSEIF(iproc.EQ.6) THEN
1797  pesum=40000d0
1798  pzsum=0d0
1799  pqsum=2d0
1800  msel=21
1801  pmas(32,1)=600d0
1802  ckin(1)=400d0
1803  mstp(81)=0
1804  mstp(111)=0
1805  CALL pyinit('CMS','p','p',pesum)
1806 
1807 C...W pair production at 1 TeV e+e- collider.
1808  ELSEIF(iproc.EQ.7) THEN
1809  pesum=1000d0
1810  pzsum=0d0
1811  pqsum=0d0
1812  msub(25)=1
1813  msub(69)=1
1814  mstp(11)=1
1815  CALL pyinit('CMS','e+','e-',pesum)
1816 
1817 C...Deep inelastic scattering at a LEP+LHC ep collider.
1818  ELSEIF(iproc.EQ.8) THEN
1819  p(1,1)=0d0
1820  p(1,2)=0d0
1821  p(1,3)=8000d0
1822  p(2,1)=0d0
1823  p(2,2)=0d0
1824  p(2,3)=-80d0
1825  pesum=8080d0
1826  pzsum=7920d0
1827  pqsum=0d0
1828  msub(10)=1
1829  ckin(3)=50d0
1830  mstp(111)=0
1831  CALL pyinit('USER','p','e-',pesum)
1832  ENDIF
1833 
1834 C...Generate 20 events of each required type.
1835  DO 220 iev=1,20
1836  CALL pyevnt
1837  pesumm=pesum
1838  IF(iproc.EQ.4) pesumm=msti(41)*pesum
1839 
1840 C...Check conservation of energy/momentum/flavour.
1841  pini(1)=0d0
1842  pini(2)=0d0
1843  pini(3)=pzsum
1844  pini(4)=pesumm
1845  pini(6)=pqsum
1846  DO 200 j=1,4
1847  pfin(j)=pyp(0,j)
1848  200 CONTINUE
1849  pfin(6)=pyp(0,6)
1850  merr=0
1851  deve=abs(pfin(4)-pini(4))+abs(pfin(3)-pini(3))
1852  devt=abs(pfin(1)-pini(1))+abs(pfin(2)-pini(2))
1853  devq=abs(pfin(6)-pini(6))
1854  IF(deve.GT.2d-3*pesum.OR.devt.GT.max(0.01d0,1d-4*pesum).OR.
1855  & devq.GT.0.1d0) merr=1
1856  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
1857  & (pfin(j),j=1,4),pfin(6)
1858 
1859 C...Check that all KF codes are known ones, and that partons/particles
1860 C...satisfy energy-momentum-mass relation.
1861  DO 210 i=1,n
1862  IF(k(i,1).GT.20) goto 210
1863  IF(pycomp(k(i,2)).EQ.0) THEN
1864  WRITE(mstu(11),5100) i
1865  merr=merr+1
1866  ENDIF
1867  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*
1868  & sign(1d0,p(i,5))
1869  IF(abs(pd).GT.max(0.1d0,0.002d0*p(i,4)**2,0.002d0*p(i,5)**2)
1870  & .OR.(p(i,5).GE.0d0.AND.p(i,4).LT.0d0)) THEN
1871  WRITE(mstu(11),5200) i
1872  merr=merr+1
1873  ENDIF
1874  210 CONTINUE
1875 
1876 C...Listing of erroneous events, and first event of each type.
1877  IF(merr.GE.1) nerr=nerr+1
1878  IF(nerr.GE.10) THEN
1879  WRITE(mstu(11),6300)
1880  CALL pylist(1)
1881  stop
1882  ENDIF
1883  IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN
1884  IF(merr.GE.1) WRITE(mstu(11),6400)
1885  CALL pylist(1)
1886  ENDIF
1887  220 CONTINUE
1888 
1889 C...List statistics for each process type.
1890  IF(mtest.GE.1) CALL pystat(1)
1891  230 CONTINUE
1892 
1893 C...Summarize result of run.
1894  IF(nerr.EQ.0) WRITE(mstu(11),6500)
1895  IF(nerr.GT.0) WRITE(mstu(11),6600) nerr
1896 
1897 C...Format statements for output.
1898  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
1899  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
1900  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
1901  &4(1x,f12.5),1x,f8.2)
1902  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
1903  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
1904  &'kinematics')
1905  6300 FORMAT(/5x,'This is the tenth error experienced! Something is ',
1906  &'wrong.'/5x,'Execution will be stopped after listing of event.')
1907  6400 FORMAT(5x,'Faulty event follows:')
1908  6500 FORMAT(//5x,'End result of PYTEST: no errors detected.')
1909  6600 FORMAT(//5x,'End result of PYTEST:',i2,' errors detected.'/
1910  &5x,'This should not have happened!')
1911 
1912  RETURN
1913  END
1914 
1915 C*********************************************************************
1916 
1917 C...PYHEPC
1918 C...Converts PYTHIA event record contents to or from
1919 C...the standard event record commonblock.
1920 
1921  SUBROUTINE pyhepc(MCONV)
1922 
1923 C...Double precision and integer declarations.
1924  IMPLICIT DOUBLE PRECISION(a-h, o-z)
1925  INTEGER pyk,pychge,pycomp
1926 C...Commonblocks.
1927  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
1928  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
1929  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
1930  SAVE /pyjets/,/pydat1/,/pydat2/
1931 C...HEPEVT commonblock.
1932  parameter(nmxhep=4000)
1933  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
1934  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
1935  DOUBLE PRECISION phep,vhep
1936  SAVE /hepevt/
1937 
1938 C...Conversion from PYTHIA to standard, the easy part.
1939  IF(mconv.EQ.1) THEN
1940  nevhep=0
1941  IF(n.GT.nmxhep) CALL pyerrm(8,
1942  & '(PYHEPC:) no more space in /HEPEVT/')
1943  nhep=min(n,nmxhep)
1944  DO 140 i=1,nhep
1945  isthep(i)=0
1946  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
1947  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
1948  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
1949  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
1950  idhep(i)=k(i,2)
1951  jmohep(1,i)=k(i,3)
1952  jmohep(2,i)=0
1953  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
1954  jdahep(1,i)=k(i,4)
1955  jdahep(2,i)=k(i,5)
1956  ELSE
1957  jdahep(1,i)=0
1958  jdahep(2,i)=0
1959  ENDIF
1960  DO 100 j=1,5
1961  phep(j,i)=p(i,j)
1962  100 CONTINUE
1963  DO 110 j=1,4
1964  vhep(j,i)=v(i,j)
1965  110 CONTINUE
1966 
1967 C...Check if new event (from pileup).
1968  IF(i.EQ.1) THEN
1969  inew=1
1970  ELSE
1971  IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
1972  ENDIF
1973 
1974 C...Fill in missing mother information.
1975  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
1976  imo1=i-2
1977  IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)
1978  & imo1=imo1-1
1979  jmohep(1,i)=imo1
1980  jmohep(2,i)=imo1+1
1981  ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
1982  i1=k(i,3)-1
1983  120 i1=i1+1
1984  IF(i1.GE.i) CALL pyerrm(8,
1985  & '(PYHEPC:) translation of inconsistent event history')
1986  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 120
1987  kc=pycomp(k(i1,2))
1988  IF(i1.LT.i.AND.kc.EQ.0) goto 120
1989  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 120
1990  jmohep(2,i)=i1
1991  ELSEIF(k(i,2).EQ.94) THEN
1992  njet=2
1993  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
1994  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
1995  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
1996  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
1997  & mod(k(i+1,4)/mstu(5),mstu(5))
1998  ENDIF
1999 
2000 C...Fill in missing daughter information.
2001  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
2002  DO 130 i1=jdahep(1,i),jdahep(2,i)
2003  i2=mod(k(i1,4)/mstu(5),mstu(5))
2004  jdahep(1,i2)=i
2005  130 CONTINUE
2006  ENDIF
2007  IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 140
2008  i1=jmohep(1,i)
2009  IF(i1.LE.0.OR.i1.GT.nhep) goto 140
2010  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 140
2011  IF(jdahep(1,i1).EQ.0) THEN
2012  jdahep(1,i1)=i
2013  ELSE
2014  jdahep(2,i1)=i
2015  ENDIF
2016  140 CONTINUE
2017  DO 150 i=1,nhep
2018  IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 150
2019  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
2020  150 CONTINUE
2021 
2022 C...Conversion from standard to PYTHIA, the easy part.
2023  ELSE
2024  IF(nhep.GT.mstu(4)) CALL pyerrm(8,
2025  & '(PYHEPC:) no more space in /PYJETS/')
2026  n=min(nhep,mstu(4))
2027  nkq=0
2028  kqsum=0
2029  DO 180 i=1,n
2030  k(i,1)=0
2031  IF(isthep(i).EQ.1) k(i,1)=1
2032  IF(isthep(i).EQ.2) k(i,1)=11
2033  IF(isthep(i).EQ.3) k(i,1)=21
2034  k(i,2)=idhep(i)
2035  k(i,3)=jmohep(1,i)
2036  k(i,4)=jdahep(1,i)
2037  k(i,5)=jdahep(2,i)
2038  DO 160 j=1,5
2039  p(i,j)=phep(j,i)
2040  160 CONTINUE
2041  DO 170 j=1,4
2042  v(i,j)=vhep(j,i)
2043  170 CONTINUE
2044  v(i,5)=0d0
2045  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
2046  i1=jdahep(1,i)
2047  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
2048  & phep(5,i)/phep(4,i)
2049  ENDIF
2050 
2051 C...Fill in missing information on colour connection in jet systems.
2052  IF(isthep(i).EQ.1) THEN
2053  kc=pycomp(k(i,2))
2054  kq=0
2055  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
2056  IF(kq.NE.0) nkq=nkq+1
2057  IF(kq.NE.2) kqsum=kqsum+kq
2058  IF(kq.NE.0.AND.kqsum.NE.0) THEN
2059  k(i,1)=2
2060  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
2061  IF(k(i+1,2).EQ.21) k(i,1)=2
2062  ENDIF
2063  ENDIF
2064  180 CONTINUE
2065  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL pyerrm(8,
2066  & '(PYHEPC:) input parton configuration not colour singlet')
2067  ENDIF
2068 
2069  END
2070 
2071 C*********************************************************************
2072 
2073 C...PYINIT
2074 C...Initializes the generation procedure; finds maxima of the
2075 C...differential cross-sections to be used for weighting.
2076 
2077  SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
2078 
2079 C...Double precision and integer declarations.
2080  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2081  INTEGER pyk,pychge,pycomp
2082 C...Commonblocks.
2083  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2084  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2085  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
2086  common/pydat4/chaf(500,2)
2087  CHARACTER chaf*16
2088  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2089  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2090  common/pyint1/mint(400),vint(400)
2091  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2092  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2093  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
2094  &/pyint1/,/pyint2/,/pyint5/
2095 C...Local arrays and character variables.
2096  dimension alamin(20),nfin(20)
2097  CHARACTER*(*) frame,beam,target
2098  CHARACTER chfram*8,chbeam*8,chtarg*8,chlh(2)*6
2099 
2100 C...Interface to PDFLIB.
2101  common/w50512/qcdl4,qcdl5
2102  SAVE /w50512/
2103  DOUBLE PRECISION value(20),qcdl4,qcdl5
2104  CHARACTER*20 parm(20)
2105  DATA value/20*0d0/,parm/20*' '/
2106 
2107 C...Data:Lambda and n_f values for parton distributions; months.
2108  DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,
2109  &14*0.2d0/,nfin/20*4/
2110  DATA chlh/'lepton','hadron'/
2111 
2112 C...Reset MINT and VINT arrays. Write headers.
2113  DO 100 j=1,400
2114  mint(j)=0
2115  vint(j)=0d0
2116  100 CONTINUE
2117  IF(mstu(12).GE.1) CALL pylist(0)
2118  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
2119 
2120 C...Maximum 4 generations; set maximum number of allowed flavours.
2121  mstp(1)=min(4,mstp(1))
2122  mstu(114)=min(mstu(114),2*mstp(1))
2123  mstp(58)=min(mstp(58),2*mstp(1))
2124 
2125 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2126  DO 120 i=-20,20
2127  vint(180+i)=0d0
2128  ia=iabs(i)
2129  IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN
2130  DO 110 j=1,mstp(1)
2131  ib=2*j-1+mod(ia,2)
2132  IF(ib.GE.6.AND.mstp(9).EQ.0) goto 110
2133  ipm=(5-isign(1,i))/2
2134  idc=j+mdcy(ia,2)+2
2135  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=
2136  & vint(180+i)+vckm((ia+1)/2,(ib+1)/2)
2137  110 CONTINUE
2138  ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN
2139  vint(180+i)=1d0
2140  ENDIF
2141  120 CONTINUE
2142 
2143 C...Initialize parton distributions: PDFLIB.
2144  IF(mstp(52).EQ.2) THEN
2145  parm(1)='NPTYPE'
2146  value(1)=1
2147  parm(2)='NGROUP'
2148  value(2)=mstp(51)/1000
2149  parm(3)='NSET'
2150  value(3)=mod(mstp(51),1000)
2151  parm(4)='TMAS'
2152  value(4)=pmas(6,1)
2153  CALL pdfset(parm,value)
2154  mint(93)=1000000+mstp(51)
2155  ENDIF
2156 
2157 C...Choose Lambda value to use in alpha-strong.
2158  mstu(111)=mstp(2)
2159  IF(mstp(3).GE.2) THEN
2160  alam=0.2d0
2161  nf=4
2162  IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.10) THEN
2163  alam=alamin(mstp(51))
2164  nf=nfin(mstp(51))
2165  ELSEIF(mstp(52).EQ.2) THEN
2166  alam=qcdl4
2167  nf=4
2168  ENDIF
2169  parp(1)=alam
2170  parp(61)=alam
2171  parp(72)=alam
2172  paru(112)=alam
2173  mstu(112)=nf
2174  IF(mstp(3).EQ.3) parj(81)=alam
2175  ENDIF
2176 
2177 C...Initialize the SUSY generation: couplings, masses,
2178 C...decay modes, branching ratios, and so on.
2179  CALL pymsin
2180 
2181 C...Initialize widths and partial widths for resonances.
2182  CALL pyinre
2183 C...Set Z0 mass and width for e+e- routines.
2184  parj(123)=pmas(23,1)
2185  parj(124)=pmas(23,2)
2186 
2187 C...Identify beam and target particles and frame of process.
2188  chfram=frame//' '
2189  chbeam=beam//' '
2190  chtarg=TARGET//' '
2191  CALL pyinbm(chfram,chbeam,chtarg,win)
2192  IF(mint(65).EQ.1) goto 170
2193 
2194 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2195 C...For e-gamma allow 2 alternatives.
2196  mint(121)=1
2197  mint(123)=mstp(14)
2198  IF(mstp(14).EQ.10.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
2199  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2200  & (iabs(mint(11)).GE.28.OR.iabs(mint(12)).GE.28)) mint(121)=3
2201  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=6
2202  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
2203  & (iabs(mint(11)).EQ.11.OR.iabs(mint(12)).EQ.11)) mint(121)=2
2204  ENDIF
2205 
2206 C...Set up kinematics of process.
2207  CALL pyinki(0)
2208 
2209 C...Loop over gamma-p or gamma-gamma alternatives.
2210  DO 160 iga=1,mint(121)
2211  mint(122)=iga
2212 
2213 C...Select partonic subprocesses to be included in the simulation.
2214  CALL pyinpr
2215 
2216 C...Count number of subprocesses on.
2217  mint(48)=0
2218  DO 130 isub=1,500
2219  IF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
2220  & msub(isub).EQ.1) THEN
2221  WRITE(mstu(11),5200) isub,chlh(mint(41)),chlh(mint(42))
2222  stop
2223  ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN
2224  WRITE(mstu(11),5300) isub
2225  stop
2226  ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN
2227  WRITE(mstu(11),5400) isub
2228  stop
2229  ELSEIF(msub(isub).EQ.1) THEN
2230  mint(48)=mint(48)+1
2231  ENDIF
2232  130 CONTINUE
2233  IF(mint(48).EQ.0) THEN
2234  WRITE(mstu(11),5500)
2235  stop
2236  ENDIF
2237  mint(49)=mint(48)-msub(91)-msub(92)-msub(93)-msub(94)
2238 
2239 C...Reset variables for cross-section calculation.
2240  DO 150 i=0,500
2241  DO 140 j=1,3
2242  ngen(i,j)=0
2243  xsec(i,j)=0d0
2244  140 CONTINUE
2245  150 CONTINUE
2246 
2247 C...Find parametrized total cross-sections.
2248  CALL pyxtot
2249 
2250 C...Maxima of differential cross-sections.
2251  IF(mstp(121).LE.1) CALL pymaxi
2252 
2253 C...Initialize possibility of pileup events.
2254  IF(mint(121).GT.1) mstp(131)=0
2255  IF(mstp(131).NE.0) CALL pypile(1)
2256 
2257 C...Initialize multiple interactions with variable impact parameter.
2258  IF(mint(50).EQ.1.AND.(mint(49).NE.0.OR.mstp(131).NE.0).AND.
2259  & mstp(82).GE.2) CALL pymult(1)
2260 
2261 C...Save results for gamma-p and gamma-gamma alternatives.
2262  IF(mint(121).GT.1) CALL pysave(1,iga)
2263  160 CONTINUE
2264 
2265 C...Initialization finished.
2266  170 IF(mstp(122).GE.1) WRITE(mstu(11),5600)
2267 
2268 C...Formats for initialization information.
2269  5100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',
2270  &'routines',1x,17('*'))
2271  5200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,
2272  &'-',a6,' interactions.'/1x,'Execution stopped!')
2273  5300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/
2274  &1x,'Execution stopped!')
2275  5400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/
2276  &1x,'Execution stopped!')
2277  5500 FORMAT(1x,'Error: no subprocess switched on.'/
2278  &1x,'Execution stopped.')
2279  5600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,
2280  &22('*'))
2281 
2282  RETURN
2283  END
2284 
2285 C*********************************************************************
2286 
2287 C...PYEVNT
2288 C...Administers the generation of a high-pT event via calls to
2289 C...a number of subroutines.
2290 
2291  SUBROUTINE pyevnt
2292 
2293 C...Double precision and integer declarations.
2294  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2295  INTEGER pyk,pychge,pycomp
2296 C...Commonblocks.
2297  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2298  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2299  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2300  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2301  common/pyint1/mint(400),vint(400)
2302  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2303  common/pyint4/mwid(500),wids(500,5)
2304  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2305  common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
2306  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,
2307  &/pyint4/,/pyint5/,/pyuppr/
2308 C...Local array.
2309  dimension vtx(4)
2310 
2311 C...Initial values for some counters.
2312  n=0
2313  mint(5)=mint(5)+1
2314  mint(7)=0
2315  mint(8)=0
2316  mint(83)=0
2317  mint(84)=mstp(126)
2318  mstu(24)=0
2319  mstu70=0
2320  mstj14=mstj(14)
2321 
2322 C...If variable energies: redo incoming kinematics and cross-section.
2323  msti(61)=0
2324  IF(mstp(171).EQ.1) THEN
2325  CALL pyinki(1)
2326  IF(msti(61).EQ.1) THEN
2327  mint(5)=mint(5)-1
2328  RETURN
2329  ENDIF
2330  IF(mint(121).GT.1) CALL pysave(3,1)
2331  CALL pyxtot
2332  ENDIF
2333 
2334 C...Loop over number of pileup events; check space left.
2335  IF(mstp(131).LE.0) THEN
2336  npile=1
2337  ELSE
2338  CALL pypile(2)
2339  npile=mint(81)
2340  ENDIF
2341  DO 260 ipile=1,npile
2342  IF(mint(84)+100.GE.mstu(4)) THEN
2343  CALL pyerrm(11,
2344  & '(PYEVNT:) no more space in PYJETS for pileup events')
2345  IF(mstu(21).GE.1) goto 270
2346  ENDIF
2347  mint(82)=ipile
2348 
2349 C...Generate variables of hard scattering.
2350  mint(51)=0
2351  msti(52)=0
2352  100 CONTINUE
2353  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
2354  mint(31)=0
2355  mint(51)=0
2356  mint(57)=0
2357  CALL pyrand
2358  IF(msti(61).EQ.1) THEN
2359  mint(5)=mint(5)-1
2360  RETURN
2361  ENDIF
2362  IF(mint(51).EQ.2) RETURN
2363  isub=mint(1)
2364  IF(mstp(111).EQ.-1) goto 250
2365 
2366  IF(isub.LE.90.OR.isub.GE.95) THEN
2367 C...Hard scattering (including low-pT):
2368 C...reconstruct kinematics and colour flow of hard scattering.
2369  110 mint(51)=0
2370  CALL pyscat
2371  IF(mint(51).EQ.1) goto 100
2372  ipu1=mint(84)+1
2373  ipu2=mint(84)+2
2374  IF(isub.EQ.95) goto 130
2375 
2376 C...Showering of initial state partons (optional).
2377  alamsv=parj(81)
2378  parj(81)=parp(72)
2379  IF(mstp(61).GE.1.AND.mint(47).GE.2) CALL pysspa(ipu1,ipu2)
2380  parj(81)=alamsv
2381  IF(mint(51).EQ.1) goto 100
2382 
2383 C...Showering of final state partons (optional).
2384  alamsv=parj(81)
2385  parj(81)=parp(72)
2386  IF(mstp(71).GE.1.AND.iset(isub).GE.2.AND.iset(isub).LE.10)
2387  & THEN
2388  ipu3=mint(84)+3
2389  ipu4=mint(84)+4
2390  IF(iset(isub).EQ.5) ipu4=-3
2391  qmax=vint(55)
2392  IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
2393  CALL pyshow(ipu3,ipu4,qmax)
2394  ELSEIF(mstp(71).GE.1.AND.iset(isub).EQ.11.AND.nfup.GE.1) THEN
2395  DO 120 iup=1,nfup
2396  ipu3=ifup(iup,1)+mint(84)
2397  ipu4=ifup(iup,2)+mint(84)
2398  qmax=sqrt(max(0d0,q2up(iup)))
2399  CALL pyshow(ipu3,ipu4,qmax)
2400  120 CONTINUE
2401  ENDIF
2402  parj(81)=alamsv
2403 
2404 C...Decay of final state resonances.
2405  mint(32)=0
2406  IF(mstp(41).GE.1.AND.iset(isub).LE.10) CALL pyresd(0)
2407  IF(mint(51).EQ.1) goto 100
2408  mint(52)=n
2409 
2410 C...Multiple interactions.
2411  IF(mstp(81).GE.1.AND.mint(50).EQ.1) CALL pymult(6)
2412  mint(53)=n
2413 
2414 C...Hadron remnants and primordial kT.
2415  130 CALL pyremn(ipu1,ipu2)
2416  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) goto 110
2417  IF(mint(51).EQ.1) goto 100
2418 
2419  ELSE
2420 C...Diffractive and elastic scattering.
2421  CALL pydiff
2422  ENDIF
2423 
2424 C...Check that no odd resonance left undecayed.
2425  IF(mstp(111).GE.1) THEN
2426  nfix=n
2427  DO 140 i=mint(84)+1,nfix
2428  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
2429  & k(i,2).NE.22) THEN
2430  IF(mwid(pycomp(k(i,2))).NE.0) THEN
2431  CALL pyresd(i)
2432  IF(mint(51).EQ.1) goto 100
2433  ENDIF
2434  ENDIF
2435  140 CONTINUE
2436  ENDIF
2437 
2438 C...Recalculate energies from momenta and masses (if desired).
2439  IF(mstp(113).GE.1) THEN
2440  DO 150 i=mint(83)+1,n
2441  IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
2442  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
2443  150 CONTINUE
2444  nrecal=n
2445  ENDIF
2446 
2447 C...Rearrange partons along strings, check invariant mass cuts.
2448  mstu(28)=0
2449  IF(mstp(111).LE.0) mstj(14)=-1
2450  CALL pyprep(mint(84)+1)
2451  mstj(14)=mstj14
2452  IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) goto 100
2453  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
2454  DO 180 i=mint(84)+1,n
2455  IF(k(i,2).EQ.94) THEN
2456  DO 170 i1=i+1,min(n,i+3)
2457  IF(k(i1,3).EQ.i) THEN
2458  k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
2459  IF(k(i1,3).EQ.0) THEN
2460  DO 160 ii=mint(84)+1,i-1
2461  IF(k(ii,2).EQ.k(i1,2)) THEN
2462  IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
2463  & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
2464  ENDIF
2465  160 CONTINUE
2466  IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
2467  ENDIF
2468  ENDIF
2469  170 CONTINUE
2470  ENDIF
2471  180 CONTINUE
2472  CALL pyedit(12)
2473  CALL pyedit(14)
2474  IF(mstp(125).EQ.0) CALL pyedit(15)
2475  IF(mstp(125).EQ.0) mint(4)=0
2476  DO 200 i=mint(83)+1,n
2477  IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
2478  DO 190 i1=i+1,n
2479  IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
2480  IF(k(i1,3).EQ.i) k(i,5)=i1
2481  190 CONTINUE
2482  ENDIF
2483  200 CONTINUE
2484  ENDIF
2485 
2486 C...Introduce separators between sections in PYLIST event listing.
2487  IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
2488  mstu70=1
2489  mstu(71)=n
2490  ELSEIF(ipile.EQ.1) THEN
2491  mstu70=3
2492  mstu(71)=2
2493  mstu(72)=mint(4)
2494  mstu(73)=n
2495  ENDIF
2496 
2497 C...Go back to lab frame (needed for vertices, also in fragmentation).
2498  CALL pyfram(1)
2499 
2500 C...Set nonvanishing production vertex (optional).
2501  IF(mstp(151).EQ.1) THEN
2502  DO 210 j=1,4
2503  vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
2504  & sin(paru(2)*pyr(0))
2505  210 CONTINUE
2506  DO 230 i=mint(83)+1,n
2507  DO 220 j=1,4
2508  v(i,j)=v(i,j)+vtx(j)
2509  220 CONTINUE
2510  230 CONTINUE
2511  ENDIF
2512 
2513 C...Perform hadronization (if desired).
2514  IF(mstp(111).GE.1) THEN
2515  CALL pyexec
2516  IF(mstu(24).NE.0) goto 100
2517  ENDIF
2518  IF(mstp(113).GE.1) THEN
2519  DO 240 i=nrecal,n
2520  IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
2521  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
2522  240 CONTINUE
2523  ENDIF
2524  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
2525 
2526 C...Store event information and calculate Monte Carlo estimates of
2527 C...subprocess cross-sections.
2528  250 IF(ipile.EQ.1) CALL pydocu
2529 
2530 C...Set counters for current pileup event and loop to next one.
2531  msti(41)=ipile
2532  IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
2533  IF(mstu70.LT.10) THEN
2534  mstu70=mstu70+1
2535  mstu(70+mstu70)=n
2536  ENDIF
2537  mint(83)=n
2538  mint(84)=n+mstp(126)
2539  IF(ipile.LT.npile) CALL pyfram(2)
2540  260 CONTINUE
2541 
2542 C...Generic information on pileup events. Reconstruct missing history.
2543  IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
2544  pari(91)=vint(132)
2545  pari(92)=vint(133)
2546  pari(93)=vint(134)
2547  IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
2548  ENDIF
2549  CALL pyedit(16)
2550 
2551 C...Transform to the desired coordinate frame.
2552  270 CALL pyfram(mstp(124))
2553  mstu(70)=mstu70
2554  paru(21)=vint(1)
2555 
2556  RETURN
2557  END
2558 
2559 C***********************************************************************
2560 
2561 C...PYSTAT
2562 C...Prints out information about cross-sections, decay widths, branching
2563 C...ratios, kinematical limits, status codes and parameter values.
2564 
2565  SUBROUTINE pystat(MSTAT)
2566 
2567 C...Double precision and integer declarations.
2568  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2569  INTEGER pyk,pychge,pycomp
2570 C...Parameter statement to help give large particle numbers.
2571  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
2572 C...Commonblocks.
2573  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2574  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2575  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
2576  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2577  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2578  common/pyint1/mint(400),vint(400)
2579  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2580  common/pyint4/mwid(500),wids(500,5)
2581  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2582  common/pyint6/proc(0:500)
2583  CHARACTER proc*28
2584  common/pymssm/imss(0:99),rmss(0:99)
2585  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
2586  &/pyint2/,/pyint4/,/pyint5/,/pyint6/,/pymssm/
2587 C...Local arrays, character variables and data.
2588  dimension wdtp(0:200),wdte(0:200,0:5)
2589  CHARACTER proga(6)*28,chau*16,chkf*16,chd1*16,chd2*16,chd3*16,
2590  &chin(2)*12,state(-1:5)*4,chkin(21)*18,disga(2)*28
2591  DATA proga/
2592  &'VMD/hadron * VMD ','VMD/hadron * direct ',
2593  &'VMD/hadron * anomalous ','direct * direct ',
2594  &'direct * anomalous ','anomalous * anomalous '/
2595  DATA disga/'e * VMD','e * anomalous'/
2596  DATA state/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2597  &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2598  &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2599  &' y*_small ',' eta*_large ',' eta*_small ',
2600  &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2601  &' x_2 ',' x_F ',' cos(theta_hard) ',
2602  &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2603  &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2604  &' tau'' '/
2605 
2606 C...Cross-sections.
2607  IF(mstat.LE.1) THEN
2608  IF(mint(121).GT.1) CALL pysave(5,0)
2609  WRITE(mstu(11),5000)
2610  WRITE(mstu(11),5100)
2611  WRITE(mstu(11),5200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)
2612  DO 100 i=1,500
2613  IF(msub(i).NE.1) goto 100
2614  WRITE(mstu(11),5200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)
2615  100 CONTINUE
2616  IF(mint(121).GT.1) THEN
2617  WRITE(mstu(11),5300)
2618  DO 110 iga=1,mint(121)
2619  CALL pysave(3,iga)
2620  IF(mint(121).EQ.2) THEN
2621  WRITE(mstu(11),5200) iga,disga(iga),ngen(0,3),ngen(0,1),
2622  & xsec(0,3)
2623  ELSE
2624  WRITE(mstu(11),5200) iga,proga(iga),ngen(0,3),ngen(0,1),
2625  & xsec(0,3)
2626  ENDIF
2627  110 CONTINUE
2628  CALL pysave(5,0)
2629  ENDIF
2630  WRITE(mstu(11),5400) 1d0-dble(ngen(0,3))/
2631  & max(1d0,dble(ngen(0,2)))
2632 
2633 C...Decay widths and branching ratios.
2634  ELSEIF(mstat.EQ.2) THEN
2635  WRITE(mstu(11),5500)
2636  WRITE(mstu(11),5600)
2637  DO 140 kc=1,500
2638  kf=kchg(kc,4)
2639  CALL pyname(kf,chkf)
2640  ioff=0
2641  IF(kc.LE.22) THEN
2642  IF(kc.GT.2*mstp(1).AND.kc.LE.10) goto 140
2643  IF(kc.GT.10+2*mstp(1).AND.kc.LE.20) goto 140
2644  IF(kc.LE.5.OR.(kc.GE.11.AND.kc.LE.16)) ioff=1
2645  IF(kc.EQ.18.AND.pmas(18,1).LT.1d0) ioff=1
2646  IF(kc.EQ.21.OR.kc.EQ.22) ioff=1
2647  ELSE
2648  IF(mwid(kc).LE.0) goto 140
2649  IF(imss(1).LE.0.AND.(kf/ksusy1.EQ.1.OR.
2650  & kf/ksusy1.EQ.2)) goto 140
2651  ENDIF
2652 C...Off-shell branchings.
2653  IF(ioff.EQ.1) THEN
2654  ngp=0
2655  IF(kc.LE.20) ngp=(mod(kc,10)+1)/2
2656  IF(ngp.LE.mstp(1)) WRITE(mstu(11),5700) kf,chkf(1:10),
2657  & pmas(kc,1),0d0,0d0,state(mdcy(kc,1)),0d0
2658  DO 120 j=1,mdcy(kc,3)
2659  idc=j+mdcy(kc,2)-1
2660  ngp1=0
2661  IF(iabs(kfdp(idc,1)).LE.20) ngp1=
2662  & (mod(iabs(kfdp(idc,1)),10)+1)/2
2663  ngp2=0
2664  IF(iabs(kfdp(idc,2)).LE.20) ngp2=
2665  & (mod(iabs(kfdp(idc,2)),10)+1)/2
2666  CALL pyname(kfdp(idc,1),chd1)
2667  CALL pyname(kfdp(idc,2),chd2)
2668  IF(kfdp(idc,3).EQ.0) THEN
2669  IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
2670  & ngp2.LE.mstp(1)) WRITE(mstu(11),5800) idc,chd1(1:10),
2671  & chd2(1:10),0d0,0d0,state(mdme(idc,1)),0d0
2672  ELSE
2673  CALL pyname(kfdp(idc,3),chd3)
2674  IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
2675  & ngp2.LE.mstp(1)) WRITE(mstu(11),5850) idc,chd1(1:10),
2676  & chd2(1:10),chd3(1:10),0d0,0d0,state(mdme(idc,1)),0d0
2677  ENDIF
2678  120 CONTINUE
2679 C...On-shell decays.
2680  ELSE
2681  CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
2682  brfin=1d0
2683  IF(wdte(0,0).LE.0d0) brfin=0d0
2684  WRITE(mstu(11),5700) kf,chkf(1:10),pmas(kc,1),wdtp(0),1d0,
2685  & state(mdcy(kc,1)),brfin
2686  DO 130 j=1,mdcy(kc,3)
2687  idc=j+mdcy(kc,2)-1
2688  ngp1=0
2689  IF(iabs(kfdp(idc,1)).LE.20) ngp1=
2690  & (mod(iabs(kfdp(idc,1)),10)+1)/2
2691  ngp2=0
2692  IF(iabs(kfdp(idc,2)).LE.20) ngp2=
2693  & (mod(iabs(kfdp(idc,2)),10)+1)/2
2694  brfin=0d0
2695  IF(wdte(0,0).GT.0d0) brfin=wdte(j,0)/wdte(0,0)
2696  CALL pyname(kfdp(idc,1),chd1)
2697  CALL pyname(kfdp(idc,2),chd2)
2698  IF(kfdp(idc,3).EQ.0) THEN
2699  IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
2700  & WRITE(mstu(11),5800) idc,chd1(1:10),
2701  & chd2(1:10),wdtp(j),wdtp(j)/wdtp(0),
2702  & state(mdme(idc,1)),brfin
2703  ELSE
2704  CALL pyname(kfdp(idc,3),chd3)
2705  IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
2706  & WRITE(mstu(11),5850) idc,chd1(1:10),
2707  & chd2(1:10),chd3(1:10),wdtp(j),wdtp(j)/wdtp(0),
2708  & state(mdme(idc,1)),brfin
2709  ENDIF
2710  130 CONTINUE
2711  ENDIF
2712  140 CONTINUE
2713  WRITE(mstu(11),5900)
2714 
2715 C...Allowed incoming partons/particles at hard interaction.
2716  ELSEIF(mstat.EQ.3) THEN
2717  WRITE(mstu(11),6000)
2718  CALL pyname(mint(11),chau)
2719  chin(1)=chau(1:12)
2720  CALL pyname(mint(12),chau)
2721  chin(2)=chau(1:12)
2722  WRITE(mstu(11),6100) chin(1),chin(2)
2723  DO 150 i=-20,22
2724  IF(i.EQ.0) goto 150
2725  ia=iabs(i)
2726  IF(ia.GT.mstp(58).AND.ia.LE.10) goto 150
2727  IF(ia.GT.10+2*mstp(1).AND.ia.LE.20) goto 150
2728  CALL pyname(i,chau)
2729  WRITE(mstu(11),6200) chau,state(kfin(1,i)),chau,
2730  & state(kfin(2,i))
2731  150 CONTINUE
2732  WRITE(mstu(11),6300)
2733 
2734 C...User-defined limits on kinematical variables.
2735  ELSEIF(mstat.EQ.4) THEN
2736  WRITE(mstu(11),6400)
2737  WRITE(mstu(11),6500)
2738  shrmax=ckin(2)
2739  IF(shrmax.LT.0d0) shrmax=vint(1)
2740  WRITE(mstu(11),6600) ckin(1),chkin(1),shrmax
2741  pthmin=max(ckin(3),ckin(5))
2742  pthmax=ckin(4)
2743  IF(pthmax.LT.0d0) pthmax=0.5d0*shrmax
2744  WRITE(mstu(11),6700) ckin(3),pthmin,chkin(2),pthmax
2745  WRITE(mstu(11),6800) chkin(3),ckin(6)
2746  DO 160 i=4,14
2747  WRITE(mstu(11),6600) ckin(2*i-1),chkin(i),ckin(2*i)
2748  160 CONTINUE
2749  sprmax=ckin(32)
2750  IF(sprmax.LT.0d0) sprmax=vint(1)
2751  WRITE(mstu(11),6600) ckin(31),chkin(15),sprmax
2752  WRITE(mstu(11),6900)
2753 
2754 C...Status codes and parameter values.
2755  ELSEIF(mstat.EQ.5) THEN
2756  WRITE(mstu(11),7000)
2757  WRITE(mstu(11),7100)
2758  DO 170 i=1,100
2759  WRITE(mstu(11),7200) i,mstp(i),parp(i),100+i,mstp(100+i),
2760  & parp(100+i)
2761  170 CONTINUE
2762 
2763 C...List of all processes implemented in the program.
2764  ELSEIF(mstat.EQ.6) THEN
2765  WRITE(mstu(11),7300)
2766  WRITE(mstu(11),7400)
2767  DO 180 i=1,500
2768  IF(iset(i).LT.0) goto 180
2769  WRITE(mstu(11),7500) i,proc(i),iset(i),kfpr(i,1),kfpr(i,2)
2770  180 CONTINUE
2771  WRITE(mstu(11),7600)
2772  ENDIF
2773 
2774 C...Formats for printouts.
2775  5000 FORMAT('1',9('*'),1x,'PYSTAT: Statistics on Number of ',
2776  &'Events and Cross-sections',1x,9('*'))
2777  5100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,
2778  &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,
2779  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),
2780  &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,
2781  &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,
2782  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,
2783  &'I',12x,'I')
2784  5200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,
2785  &d10.3,1x,'I')
2786  5300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/
2787  &1x,'I',34x,'I',28x,'I',12x,'I')
2788  5400 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//
2789  &1x,'********* Fraction of events that fail fragmentation ',
2790  &'cuts =',1x,f8.5,' *********'/)
2791  5500 FORMAT('1',27('*'),1x,'PYSTAT: Decay Widths and Branching ',
2792  &'Ratios',1x,27('*'))
2793  5600 FORMAT(/1x,98('=')/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
2794  &1x,'I',5x,'Mother --> Branching/Decay Channel',8x,'I',1x,
2795  &'Width (GeV)',1x,'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,
2796  &'Eff. B.R.',1x,'I'/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
2797  &1x,98('='))
2798  5700 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,
2799  &i8,2x,a10,3x,'(m =',f10.3,')',2x,'-->',5x,'I',2x,1p,d10.3,0p,1x,
2800  &'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,d10.3,0p,1x,'I')
2801  5800 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,15x,'I',2x,
2802  &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
2803  &1p,d10.3,0p,1x,'I')
2804  5850 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,1x,'+',1x,a10,2x,'I',2x,
2805  &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
2806  &1p,d10.3,0p,1x,'I')
2807  5900 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,98('='))
2808  6000 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',
2809  &'Particles at Hard Interaction',1x,7('*'))
2810  6100 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,
2811  &'Beam particle:',1x,a12,10x,'I',1x,'Target particle:',1x,a12,7x,
2812  &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',6x,'State',19x,
2813  &'I',1x,'Content',6x,'State',18x,'I'/1x,'I',38x,'I',37x,'I'/1x,
2814  &78('=')/1x,'I',38x,'I',37x,'I')
2815  6200 FORMAT(1x,'I',1x,a9,5x,a4,19x,'I',1x,a9,5x,a4,18x,'I')
2816  6300 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))
2817  6400 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',
2818  &'Kinematical Variables',1x,12('*'))
2819  6500 FORMAT(/1x,78('=')/1x,'I',76x,'I')
2820  6600 FORMAT(1x,'I',16x,1p,d10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,d10.3,0p,
2821  &16x,'I')
2822  6700 FORMAT(1x,'I',3x,1p,d10.3,0p,1x,'(',1p,d10.3,0p,')',1x,'<',1x,a,
2823  &1x,'<',1x,1p,d10.3,0p,16x,'I')
2824  6800 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,d10.3,0p,16x,'I')
2825  6900 FORMAT(1x,'I',76x,'I'/1x,78('='))
2826  7000 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',
2827  &'Parameter Values',1x,12('*'))
2828  7100 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,
2829  &'PARP(I)'/)
2830  7200 FORMAT(1x,i3,5x,i6,6x,1p,d10.3,0p,18x,i3,5x,i6,6x,1p,d10.3)
2831  7300 FORMAT('1',13('*'),1x,'PYSTAT: List of implemented processes',
2832  &1x,13('*'))
2833  7400 FORMAT(/1x,65('=')/1x,'I',34x,'I',28x,'I'/1x,'I',12x,
2834  &'Subprocess',12x,'I',1x,'ISET',2x,'KFPR(I,1)',2x,'KFPR(I,2)',1x,
2835  &'I'/1x,'I',34x,'I',28x,'I'/1x,65('=')/1x,'I',34x,'I',28x,'I')
2836  7500 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i4,1x,i10,1x,i10,1x,'I')
2837  7600 FORMAT(1x,'I',34x,'I',28x,'I'/1x,65('='))
2838 
2839  RETURN
2840  END
2841 
2842 C*********************************************************************
2843 
2844 C...PYINRE
2845 C...Calculates full and effective widths of gauge bosons, stores
2846 C...masses and widths, rescales coefficients to be used for
2847 C...resonance production generation.
2848 
2849  SUBROUTINE pyinre
2850 
2851 C...Double precision and integer declarations.
2852  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2853  INTEGER pyk,pychge,pycomp
2854 C...Parameter statement to help give large particle numbers.
2855  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
2856 C...Commonblocks.
2857  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2858  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2859  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
2860  common/pydat4/chaf(500,2)
2861  CHARACTER chaf*16
2862  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2863  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2864  common/pyint1/mint(400),vint(400)
2865  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2866  common/pyint4/mwid(500),wids(500,5)
2867  common/pyint6/proc(0:500)
2868  CHARACTER proc*28
2869  common/pymssm/imss(0:99),rmss(0:99)
2870  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
2871  &/pyint1/,/pyint2/,/pyint4/,/pyint6/,/pymssm/
2872 C...Local arrays and data.
2873  dimension wdtp(0:200),wdte(0:200,0:5),wdtpm(0:200),
2874  &wdtem(0:200,0:5),kcord(500),pmord(500)
2875 
2876 C...Born level couplings in MSSM Higgs doublet sector.
2877  xw=paru(102)
2878  xwv=xw
2879  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
2880  xw1=1d0-xw
2881  IF(mstp(4).EQ.2) THEN
2882  tanbe=paru(141)
2883  ratbe=((1d0-tanbe**2)/(1d0+tanbe**2))**2
2884  sqmz=pmas(23,1)**2
2885  sqmw=pmas(24,1)**2
2886  sqmh=pmas(25,1)**2
2887  sqma=sqmh*(sqmz-sqmh)/(sqmz*ratbe-sqmh)
2888  sqmhp=0.5d0*(sqma+sqmz+sqrt((sqma+sqmz)**2-4d0*sqma*sqmz*ratbe))
2889  sqmhc=sqma+sqmw
2890  IF(sqmh.GE.sqmz.OR.min(sqma,sqmhp,sqmhc).LE.0d0) THEN
2891  WRITE(mstu(11),5000)
2892  stop
2893  ENDIF
2894  pmas(35,1)=sqrt(sqmhp)
2895  pmas(36,1)=sqrt(sqma)
2896  pmas(37,1)=sqrt(sqmhc)
2897  alsu=0.5d0*atan(2d0*tanbe*(sqma+sqmz)/((1d0-tanbe**2)*
2898  & (sqma-sqmz)))
2899  besu=atan(tanbe)
2900  paru(142)=1d0
2901  paru(143)=1d0
2902  paru(161)=-sin(alsu)/cos(besu)
2903  paru(162)=cos(alsu)/sin(besu)
2904  paru(163)=paru(161)
2905  paru(164)=sin(besu-alsu)
2906  paru(165)=paru(164)
2907  paru(168)=sin(besu-alsu)+0.5d0*cos(2d0*besu)*sin(besu+alsu)/xw
2908  paru(171)=cos(alsu)/cos(besu)
2909  paru(172)=sin(alsu)/sin(besu)
2910  paru(173)=paru(171)
2911  paru(174)=cos(besu-alsu)
2912  paru(175)=paru(174)
2913  paru(176)=cos(2d0*alsu)*cos(besu+alsu)-2d0*sin(2d0*alsu)*
2914  & sin(besu+alsu)
2915  paru(177)=cos(2d0*besu)*cos(besu+alsu)
2916  paru(178)=cos(besu-alsu)-0.5d0*cos(2d0*besu)*cos(besu+alsu)/xw
2917  paru(181)=tanbe
2918  paru(182)=1d0/tanbe
2919  paru(183)=paru(181)
2920  paru(184)=0d0
2921  paru(185)=paru(184)
2922  paru(186)=cos(besu-alsu)
2923  paru(187)=sin(besu-alsu)
2924  paru(188)=paru(186)
2925  paru(189)=paru(187)
2926  paru(190)=0d0
2927  paru(195)=cos(besu-alsu)
2928  ENDIF
2929 
2930 C...Reset effective widths of gauge bosons.
2931  DO 110 i=1,500
2932  DO 100 j=1,5
2933  wids(i,j)=1d0
2934  100 CONTINUE
2935  110 CONTINUE
2936 
2937 C...Order resonances by increasing mass (except Z0 and W+/-).
2938  nres=0
2939  DO 140 kc=1,500
2940  kf=kchg(kc,4)
2941  IF(kf.EQ.0) goto 140
2942  IF(mwid(kc).EQ.0) goto 140
2943  IF(kc.EQ.7.OR.kc.EQ.8.OR.kc.EQ.17.OR.kc.EQ.18) THEN
2944  IF(mstp(1).LE.3) goto 140
2945  ENDIF
2946  IF(kf/ksusy1.EQ.1.OR.kf/ksusy1.EQ.2) THEN
2947  IF(imss(1).LE.0) goto 140
2948  ENDIF
2949  nres=nres+1
2950  pmres=pmas(kc,1)
2951  IF(kc.EQ.23.OR.kc.EQ.24) pmres=0d0
2952  DO 120 i1=nres-1,1,-1
2953  IF(pmres.GE.pmord(i1)) goto 130
2954  kcord(i1+1)=kcord(i1)
2955  pmord(i1+1)=pmord(i1)
2956  120 CONTINUE
2957  130 kcord(i1+1)=kc
2958  pmord(i1+1)=pmres
2959  140 CONTINUE
2960 
2961 C...Loop over possible resonances.
2962  DO 180 i=1,nres
2963  kc=kcord(i)
2964  kf=kchg(kc,4)
2965 
2966 C...Check that no fourth generation channels on by mistake.
2967  IF(mstp(1).LE.3) THEN
2968  DO 150 j=1,mdcy(kc,3)
2969  idc=j+mdcy(kc,2)-1
2970  kfa1=iabs(kfdp(idc,1))
2971  kfa2=iabs(kfdp(idc,2))
2972  IF(kfa1.EQ.7.OR.kfa1.EQ.8.OR.kfa1.EQ.17.OR.kfa1.EQ.18.OR.
2973  & kfa2.EQ.7.OR.kfa2.EQ.8.OR.kfa2.EQ.17.OR.kfa2.EQ.18)
2974  & mdme(idc,1)=-1
2975  150 CONTINUE
2976  ENDIF
2977 
2978 C...Check that no supersymmetric channels on by mistake.
2979  IF(imss(1).LE.0) THEN
2980  DO 160 j=1,mdcy(kc,3)
2981  idc=j+mdcy(kc,2)-1
2982  kfa1s=iabs(kfdp(idc,1))/ksusy1
2983  kfa2s=iabs(kfdp(idc,2))/ksusy1
2984  IF(kfa1s.EQ.1.OR.kfa1s.EQ.2.OR.kfa2s.EQ.1.OR.kfa2s.EQ.2)
2985  & mdme(idc,1)=-1
2986  160 CONTINUE
2987  ENDIF
2988 
2989 C...Find mass and evaluate width.
2990  pmr=pmas(kc,1)
2991  IF(kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) mint(62)=1
2992  IF(mwid(kc).EQ.3) mint(63)=1
2993  CALL pywidt(kf,pmr**2,wdtp,wdte)
2994  mint(51)=0
2995 
2996 C...Evaluate suppression factors due to non-simulated channels.
2997  IF(kchg(kc,3).EQ.0) THEN
2998  wids(kc,1)=((wdte(0,1)+wdte(0,2))**2+
2999  & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
3000  & 2d0*wdte(0,4)*wdte(0,5))/wdtp(0)**2
3001  wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
3002  wids(kc,3)=0d0
3003  wids(kc,4)=0d0
3004  wids(kc,5)=0d0
3005  ELSE
3006  IF(mwid(kc).EQ.3) mint(63)=1
3007  CALL pywidt(-kf,pmr**2,wdtpm,wdtem)
3008  mint(51)=0
3009  wids(kc,1)=((wdte(0,1)+wdte(0,2))*(wdtem(0,1)+wdtem(0,3))+
3010  & (wdte(0,1)+wdte(0,2))*(wdtem(0,4)+wdtem(0,5))+
3011  & (wdte(0,4)+wdte(0,5))*(wdtem(0,1)+wdtem(0,3))+
3012  & wdte(0,4)*wdtem(0,5)+wdte(0,5)*wdtem(0,4))/wdtp(0)**2
3013  wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
3014  wids(kc,3)=(wdtem(0,1)+wdtem(0,3)+wdtem(0,4))/wdtp(0)
3015  wids(kc,4)=((wdte(0,1)+wdte(0,2))**2+
3016  & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
3017  & 2d0*wdte(0,4)*wdte(0,5))/wdtp(0)**2
3018  wids(kc,5)=((wdtem(0,1)+wdtem(0,3))**2+
3019  & 2d0*(wdtem(0,1)+wdtem(0,3))*(wdtem(0,4)+wdtem(0,5))+
3020  & 2d0*wdtem(0,4)*wdtem(0,5))/wdtp(0)**2
3021  ENDIF
3022 
3023 C...Set resonance widths and branching ratios;
3024 C...also on/off switch for decays.
3025  IF(mwid(kc).EQ.1.OR.mwid(kc).EQ.3) THEN
3026  pmas(kc,2)=wdtp(0)
3027  pmas(kc,3)=min(0.9d0*pmas(kc,1),10d0*pmas(kc,2))
3028  mdcy(kc,1)=mstp(41)
3029  DO 170 j=1,mdcy(kc,3)
3030  idc=j+mdcy(kc,2)-1
3031  brat(idc)=0d0
3032  IF(wdtp(0).GT.0d0) brat(idc)=wdtp(j)/wdtp(0)
3033  170 CONTINUE
3034  ENDIF
3035  180 CONTINUE
3036 
3037 C...Flavours of leptoquark: redefine charge and name.
3038  kflqq=kfdp(mdcy(39,2),1)
3039  kflql=kfdp(mdcy(39,2),2)
3040  kchg(39,1)=kchg(pycomp(kflqq),1)*isign(1,kflqq)+
3041  &kchg(pycomp(kflql),1)*isign(1,kflql)
3042  ll=1
3043  IF(iabs(kflql).EQ.13) ll=2
3044  IF(iabs(kflql).EQ.15) ll=3
3045  chaf(39,1)='LQ_'//chaf(iabs(kflqq),1)(1:1)//
3046  &chaf(iabs(kflql),1)(1:ll)//' '
3047  chaf(39,2)=chaf(39,2)(1:4+ll)//'bar '
3048 
3049 C...Special cases in treatment of gamma*/Z0: redefine process name.
3050  IF(mstp(43).EQ.1) THEN
3051  proc(1)='f + fbar -> gamma*'
3052  proc(15)='f + fbar -> g + gamma*'
3053  proc(19)='f + fbar -> gamma + gamma*'
3054  proc(30)='f + g -> f + gamma*'
3055  proc(35)='f + gamma -> f + gamma*'
3056  ELSEIF(mstp(43).EQ.2) THEN
3057  proc(1)='f + fbar -> Z0'
3058  proc(15)='f + fbar -> g + Z0'
3059  proc(19)='f + fbar -> gamma + Z0'
3060  proc(30)='f + g -> f + Z0'
3061  proc(35)='f + gamma -> f + Z0'
3062  ELSEIF(mstp(43).EQ.3) THEN
3063  proc(1)='f + fbar -> gamma*/Z0'
3064  proc(15)='f + fbar -> g + gamma*/Z0'
3065  proc(19)='f + fbar -> gamma + gamma*/Z0'
3066  proc(30)='f + g -> f + gamma*/Z0'
3067  proc(35)='f + gamma -> f + gamma*/Z0'
3068  ENDIF
3069 
3070 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3071  IF(mstp(44).EQ.1) THEN
3072  proc(141)='f + fbar -> gamma*'
3073  ELSEIF(mstp(44).EQ.2) THEN
3074  proc(141)='f + fbar -> Z0'
3075  ELSEIF(mstp(44).EQ.3) THEN
3076  proc(141)='f + fbar -> Z''0'
3077  ELSEIF(mstp(44).EQ.4) THEN
3078  proc(141)='f + fbar -> gamma*/Z0'
3079  ELSEIF(mstp(44).EQ.5) THEN
3080  proc(141)='f + fbar -> gamma*/Z''0'
3081  ELSEIF(mstp(44).EQ.6) THEN
3082  proc(141)='f + fbar -> Z0/Z''0'
3083  ELSEIF(mstp(44).EQ.7) THEN
3084  proc(141)='f + fbar -> gamma*/Z0/Z''0'
3085  ENDIF
3086 
3087 C...Special cases in treatment of WW -> WW: redefine process name.
3088  IF(mstp(45).EQ.1) THEN
3089  proc(77)='W+ + W+ -> W+ + W+'
3090  ELSEIF(mstp(45).EQ.2) THEN
3091  proc(77)='W+ + W- -> W+ + W-'
3092  ELSEIF(mstp(45).EQ.3) THEN
3093  proc(77)='W+/- + W+/- -> W+/- + W+/-'
3094  ENDIF
3095 
3096 C...Format for error information.
3097  5000 FORMAT(1x,'Error: unphysical input tan^2(beta) and m_H ',
3098  &'combination'/1x,'Execution stopped!')
3099 
3100  RETURN
3101  END
3102 
3103 C*********************************************************************
3104 
3105 C...PYINBM
3106 C...Identifies the two incoming particles and the choice of frame.
3107 
3108  SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)
3109 
3110 C...Double precision and integer declarations.
3111  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3112  INTEGER pyk,pychge,pycomp
3113 C...Commonblocks.
3114  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3115  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3116  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3117  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3118  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3119  common/pyint1/mint(400),vint(400)
3120  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
3121 C...Local arrays, character variables and data.
3122  CHARACTER chfram*8,chbeam*8,chtarg*8,chcom(3)*8,chalp(2)*26,
3123  &chidnt(3)*8,chtemp*8,chcde(29)*8,chinit*76
3124  dimension len(3),kcde(29),pm(2)
3125  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
3126  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3127  DATA chcde/'e- ','e+ ','nu_e ','nu_ebar ',
3128  &'mu- ','mu+ ','nu_mu ','nu_mubar','tau- ',
3129  &'tau+ ','nu_tau ','nu_tauba','pi+ ','pi- ',
3130  &'n0 ','nbar0 ','p+ ','pbar- ','gamma ',
3131  &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ',
3132  &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/
3133  DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3134  &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3135  &3312,3322,3334,111,28,29/
3136 
3137 C...Store initial energy. Default frame.
3138  vint(290)=win
3139  mint(111)=0
3140 
3141 C...Convert character variables to lowercase and find their length.
3142  chcom(1)=chfram
3143  chcom(2)=chbeam
3144  chcom(3)=chtarg
3145  DO 130 i=1,3
3146  len(i)=8
3147  DO 110 ll=8,1,-1
3148  IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1
3149  DO 100 la=1,26
3150  IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=
3151  & chalp(1)(la:la)
3152  100 CONTINUE
3153  110 CONTINUE
3154  chidnt(i)=chcom(i)
3155 
3156 C...Fix up bar, underscore and charge in particle name (if needed).
3157  DO 120 ll=1,6
3158  IF(chidnt(i)(ll:ll).EQ.'~') THEN
3159  chtemp=chidnt(i)
3160  chidnt(i)=chtemp(1:ll-1)//'bar'//chtemp(ll+1:6)//' '
3161  ENDIF
3162  120 CONTINUE
3163  IF(chidnt(i)(7:7).EQ.'~') chidnt(i)(7:8)='ba'
3164  IF(chidnt(i)(1:2).EQ.'nu'.AND.chidnt(i)(3:3).NE.'_') THEN
3165  chtemp=chidnt(i)
3166  chidnt(i)='nu_'//chtemp(3:7)
3167  ELSEIF(chidnt(i)(1:2).EQ.'n ') THEN
3168  chidnt(i)(1:3)='n0 '
3169  ELSEIF(chidnt(i)(1:4).EQ.'nbar') THEN
3170  chidnt(i)(1:5)='nbar0'
3171  ELSEIF(chidnt(i)(1:2).EQ.'p ') THEN
3172  chidnt(i)(1:3)='p+ '
3173  ELSEIF(chidnt(i)(1:4).EQ.'pbar'.OR.
3174  & chidnt(i)(1:2).EQ.'p-') THEN
3175  chidnt(i)(1:5)='pbar-'
3176  ELSEIF(chidnt(i)(1:6).EQ.'lambda') THEN
3177  chidnt(i)(7:7)='0'
3178  ELSEIF(chidnt(i)(1:3).EQ.'reg') THEN
3179  chidnt(i)(1:7)='reggeon'
3180  ELSEIF(chidnt(i)(1:3).EQ.'pom') THEN
3181  chidnt(i)(1:7)='pomeron'
3182  ENDIF
3183  130 CONTINUE
3184 
3185 C...Identify free initialization.
3186  IF(chcom(1)(1:2).EQ.'no') THEN
3187  mint(65)=1
3188  RETURN
3189  ENDIF
3190 
3191 C...Identify incoming beam and target particles.
3192  DO 150 i=1,2
3193  DO 140 j=1,29
3194  IF(chidnt(i+1).EQ.chcde(j)) mint(10+i)=kcde(j)
3195  140 CONTINUE
3196  pm(i)=pymass(mint(10+i))
3197  vint(2+i)=pm(i)
3198  150 CONTINUE
3199  IF(mint(11).EQ.0) WRITE(mstu(11),5000) chbeam(1:len(2))
3200  IF(mint(12).EQ.0) WRITE(mstu(11),5100) chtarg(1:len(3))
3201  IF(mint(11).EQ.0.OR.mint(12).EQ.0) stop
3202 
3203 C...Identify choice of frame and input energies.
3204  chinit=' '
3205 
3206 C...Events defined in the CM frame.
3207  IF(chcom(1)(1:2).EQ.'cm') THEN
3208  mint(111)=1
3209  s=win**2
3210  IF(mstp(122).GE.1) THEN
3211  IF(chcom(2)(1:1).NE.'e') THEN
3212  loffs=(31-(len(2)+len(3)))/2
3213  chinit(loffs+1:76)='PYTHIA will be initialized for a '//
3214  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3215  & ' collider'//' '
3216  ELSE
3217  loffs=(30-(len(2)+len(3)))/2
3218  chinit(loffs+1:76)='PYTHIA will be initialized for an '//
3219  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3220  & ' collider'//' '
3221  ENDIF
3222  WRITE(mstu(11),5200) chinit
3223  WRITE(mstu(11),5300) win
3224  ENDIF
3225 
3226 C...Events defined in fixed target frame.
3227  ELSEIF(chcom(1)(1:3).EQ.'fix') THEN
3228  mint(111)=2
3229  s=pm(1)**2+pm(2)**2+2d0*pm(2)*sqrt(pm(1)**2+win**2)
3230  IF(mstp(122).GE.1) THEN
3231  loffs=(29-(len(2)+len(3)))/2
3232  chinit(loffs+1:76)='PYTHIA will be initialized for '//
3233  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3234  & ' fixed target'//' '
3235  WRITE(mstu(11),5200) chinit
3236  WRITE(mstu(11),5400) win
3237  WRITE(mstu(11),5500) sqrt(s)
3238  ENDIF
3239 
3240 C...Frame defined by user three-vectors.
3241  ELSEIF(chcom(1)(1:3).EQ.'use') THEN
3242  mint(111)=3
3243  p(1,5)=pm(1)
3244  p(2,5)=pm(2)
3245  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
3246  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
3247  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
3248  & (p(1,3)+p(2,3))**2
3249  IF(mstp(122).GE.1) THEN
3250  loffs=(12-(len(2)+len(3)))/2
3251  chinit(loffs+1:76)='PYTHIA will be initialized for '//
3252  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3253  & ' user-specified configuration'//' '
3254  WRITE(mstu(11),5200) chinit
3255  WRITE(mstu(11),5600)
3256  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
3257  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
3258  WRITE(mstu(11),5500) sqrt(max(0d0,s))
3259  ENDIF
3260 
3261 C...Frame defined by user four-vectors.
3262  ELSEIF(chcom(1)(1:4).EQ.'four') THEN
3263  mint(111)=4
3264  pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
3265  p(1,5)=sign(sqrt(abs(pms1)),pms1)
3266  pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
3267  p(2,5)=sign(sqrt(abs(pms2)),pms2)
3268  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
3269  & (p(1,3)+p(2,3))**2
3270  IF(mstp(122).GE.1) THEN
3271  loffs=(12-(len(2)+len(3)))/2
3272  chinit(loffs+1:76)='PYTHIA will be initialized for '//
3273  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3274  & ' user-specified configuration'//' '
3275  WRITE(mstu(11),5200) chinit
3276  WRITE(mstu(11),5600)
3277  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
3278  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
3279  WRITE(mstu(11),5500) sqrt(max(0d0,s))
3280  ENDIF
3281 
3282 C...Frame defined by user five-vectors.
3283  ELSEIF(chcom(1)(1:4).EQ.'five') THEN
3284  mint(111)=5
3285  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
3286  & (p(1,3)+p(2,3))**2
3287  IF(mstp(122).GE.1) THEN
3288  loffs=(12-(len(2)+len(3)))/2
3289  chinit(loffs+1:76)='PYTHIA will be initialized for '//
3290  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
3291  & ' user-specified configuration'//' '
3292  WRITE(mstu(11),5200) chinit
3293  WRITE(mstu(11),5600)
3294  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
3295  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
3296  WRITE(mstu(11),5500) sqrt(max(0d0,s))
3297  ENDIF
3298 
3299 C...Unknown frame. Error for too low CM energy.
3300  ELSE
3301  WRITE(mstu(11),5800) chfram(1:len(1))
3302  stop
3303  ENDIF
3304  IF(s.LT.parp(2)**2) THEN
3305  WRITE(mstu(11),5900) sqrt(s)
3306  stop
3307  ENDIF
3308 
3309 C...Formats for initialization and error information.
3310  5000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''D0'/
3311  &1x,'Execution stopped!')
3312  5100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''D0'/
3313  &1x,'Execution stopped!')
3314  5200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')
3315  5300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',
3316  &19x,'I'/1x,'I',76x,'I'/1x,78('='))
3317  5400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')
3318  5500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,
3319  &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))
3320  5600 FORMAT(1x,'I',76x,'I'/1x,'I',18x,'px (GeV/c)',3x,'py (GeV/c)',3x,
3321  &'pz (GeV/c)',6x,'E (GeV)',9x,'I')
3322  5700 FORMAT(1x,'I',8x,a8,4(2x,f10.3,1x),8x,'I')
3323  5800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''D0'/
3324  &1x,'Execution stopped!')
3325  5900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',
3326  &'generation.'/1x,'Execution stopped!')
3327 
3328  RETURN
3329  END
3330 
3331 C*********************************************************************
3332 
3333 C...PYINKI
3334 C...Sets up kinematics, including rotations and boosts to/from CM frame.
3335 
3336  SUBROUTINE pyinki(MODKI)
3337 
3338 C...Double precision and integer declarations.
3339  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3340  INTEGER pyk,pychge,pycomp
3341 C...Commonblocks.
3342  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3343  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3344  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3345  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3346  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3347  common/pyint1/mint(400),vint(400)
3348  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
3349 
3350 C...Set initial flavour state.
3351  n=2
3352  DO 100 i=1,2
3353  k(i,1)=1
3354  k(i,2)=mint(10+i)
3355  100 CONTINUE
3356 
3357 C...Reset boost. Do kinematics for various cases.
3358  DO 110 j=6,10
3359  vint(j)=0d0
3360  110 CONTINUE
3361 
3362 C...Set up kinematics for events defined in CM frame.
3363  IF(mint(111).EQ.1) THEN
3364  win=vint(290)
3365  IF(modki.EQ.1) win=parp(171)*vint(290)
3366  s=win**2
3367  p(1,5)=vint(3)
3368  p(2,5)=vint(4)
3369  p(1,1)=0d0
3370  p(1,2)=0d0
3371  p(2,1)=0d0
3372  p(2,2)=0d0
3373  p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2d0*p(1,5)*p(2,5))**2)/
3374  & (4d0*s))
3375  p(2,3)=-p(1,3)
3376  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
3377  p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
3378 
3379 C...Set up kinematics for fixed target events.
3380  ELSEIF(mint(111).EQ.2) THEN
3381  win=vint(290)
3382  IF(modki.EQ.1) win=parp(171)*vint(290)
3383  p(1,5)=vint(3)
3384  p(2,5)=vint(4)
3385  p(1,1)=0d0
3386  p(1,2)=0d0
3387  p(2,1)=0d0
3388  p(2,2)=0d0
3389  p(1,3)=win
3390  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
3391  p(2,3)=0d0
3392  p(2,4)=p(2,5)
3393  s=p(1,5)**2+p(2,5)**2+2d0*p(2,4)*p(1,4)
3394  vint(10)=p(1,3)/(p(1,4)+p(2,4))
3395  CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
3396 
3397 C...Set up kinematics for events in user-defined frame.
3398  ELSEIF(mint(111).EQ.3) THEN
3399  p(1,5)=vint(3)
3400  p(2,5)=vint(4)
3401  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
3402  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
3403  DO 120 j=1,3
3404  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
3405  120 CONTINUE
3406  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
3407  vint(7)=pyangl(p(1,1),p(1,2))
3408  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
3409  vint(6)=pyangl(p(1,3),p(1,1))
3410  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
3411  s=p(1,5)**2+p(2,5)**2+2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
3412 
3413 C...Set up kinematics for events with user-defined four-vectors.
3414  ELSEIF(mint(111).EQ.4) THEN
3415  pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
3416  p(1,5)=sign(sqrt(abs(pms1)),pms1)
3417  pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
3418  p(2,5)=sign(sqrt(abs(pms2)),pms2)
3419  DO 130 j=1,3
3420  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
3421  130 CONTINUE
3422  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
3423  vint(7)=pyangl(p(1,1),p(1,2))
3424  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
3425  vint(6)=pyangl(p(1,3),p(1,1))
3426  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
3427  s=(p(1,4)+p(2,4))**2
3428 
3429 C...Set up kinematics for events with user-defined five-vectors.
3430  ELSEIF(mint(111).EQ.5) THEN
3431  DO 140 j=1,3
3432  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
3433  140 CONTINUE
3434  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
3435  vint(7)=pyangl(p(1,1),p(1,2))
3436  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
3437  vint(6)=pyangl(p(1,3),p(1,1))
3438  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
3439  s=(p(1,4)+p(2,4))**2
3440  ENDIF
3441 
3442 C...Return or error for too low CM energy.
3443  IF(modki.EQ.1.AND.s.LT.parp(2)**2) THEN
3444  IF(mstp(172).LE.1) THEN
3445  CALL pyerrm(23,
3446  & '(PYINKI:) too low invariant mass in this event')
3447  ELSE
3448  msti(61)=1
3449  RETURN
3450  ENDIF
3451  ENDIF
3452 
3453 C...Save information on incoming particles.
3454  vint(1)=sqrt(s)
3455  vint(2)=s
3456  IF(mint(111).GE.4) vint(3)=p(1,5)
3457  IF(mint(111).GE.4) vint(4)=p(2,5)
3458  vint(5)=p(1,3)
3459  IF(modki.EQ.0) vint(289)=s
3460  DO 150 j=1,5
3461  v(1,j)=0d0
3462  v(2,j)=0d0
3463  vint(290+j)=p(1,j)
3464  vint(295+j)=p(2,j)
3465  150 CONTINUE
3466 
3467 C...Store pT cut-off and related constants to be used in generation.
3468  IF(modki.EQ.0) vint(285)=ckin(3)
3469  IF(mstp(82).LE.1) THEN
3470  IF(mint(121).GT.1) parp(81)=1.30d0+0.15d0*log(vint(1)/200d0)/
3471  & log(900d0/200d0)
3472  ptmn=parp(81)
3473  ELSE
3474  IF(mint(121).GT.1) parp(82)=1.25d0+0.15d0*log(vint(1)/200d0)/
3475  & log(900d0/200d0)
3476  ptmn=parp(82)
3477  ENDIF
3478  vint(149)=4d0*ptmn**2/s
3479 
3480  RETURN
3481  END
3482 
3483 C*********************************************************************
3484 
3485 C...PYINPR
3486 C...Selects partonic subprocesses to be included in the simulation.
3487 
3488  SUBROUTINE pyinpr
3489 
3490 C...Double precision and integer declarations.
3491  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3492  INTEGER pyk,pychge,pycomp
3493 C...Commonblocks.
3494  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3495  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
3496  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
3497  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3498  common/pyint1/mint(400),vint(400)
3499  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3500  SAVE /pydat1/,/pydat3/,/pysubs/,/pypars/,/pyint1/,/pyint2/
3501 
3502 C...Reset processes to be included.
3503  IF(msel.NE.0) THEN
3504  DO 100 i=1,500
3505  msub(i)=0
3506  100 CONTINUE
3507  ENDIF
3508 
3509 C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
3510  IF(mint(121).EQ.2) THEN
3511  msub(10)=1
3512  mint(123)=mint(122)+1
3513 
3514 C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
3515 C...Here also set a few parameters otherwise normally not touched.
3516  ELSEIF(mint(121).GT.1) THEN
3517 
3518 C...Parton distributions dampened at small Q2; go to low energies,
3519 C...alpha_s <1; no minimum pT cut-off a priori.
3520  mstp(57)=3
3521  mstp(85)=0
3522  parp(2)=2d0
3523  paru(115)=1d0
3524  ckin(5)=0.2d0
3525  ckin(6)=0.2d0
3526 
3527 C...Define pT cut-off parameters and whether run involves low-pT.
3528  IF(mstp(82).LE.1) THEN
3529  ptmvmd=1.30d0+0.15d0*log(vint(1)/200d0)/log(900d0/200d0)
3530  ELSE
3531  ptmvmd=1.25d0+0.15d0*log(vint(1)/200d0)/log(900d0/200d0)
3532  ENDIF
3533  ptmdir=parp(15)
3534  ptmano=ptmvmd
3535  IF(mstp(15).EQ.5) ptmano=0.60d0+
3536  & 0.125d0*log(1d0+0.10d0*vint(1))**2
3537  iptl=1
3538  IF(vint(285).GT.max(ptmvmd,ptmdir,ptmano)) iptl=0
3539  IF(msel.EQ.2) iptl=1
3540 
3541 C...Set up for p/VMD * VMD.
3542  IF(mint(122).EQ.1) THEN
3543  mint(123)=2
3544  msub(11)=1
3545  msub(12)=1
3546  msub(13)=1
3547  msub(28)=1
3548  msub(53)=1
3549  msub(68)=1
3550  IF(iptl.EQ.1) msub(95)=1
3551  IF(msel.EQ.2) THEN
3552  msub(91)=1
3553  msub(92)=1
3554  msub(93)=1
3555  msub(94)=1
3556  ENDIF
3557  parp(81)=ptmvmd
3558  parp(82)=ptmvmd
3559  IF(iptl.EQ.1) ckin(3)=0d0
3560 
3561 C...Set up for p/VMD * direct gamma.
3562  ELSEIF(mint(122).EQ.2) THEN
3563  mint(123)=0
3564  IF(mint(121).EQ.6) mint(123)=5
3565  msub(33)=1
3566  msub(54)=1
3567  IF(iptl.EQ.1) ckin(3)=ptmdir
3568 
3569 C...Set up for p/VMD * anomalous gamma.
3570  ELSEIF(mint(122).EQ.3) THEN
3571  mint(123)=3
3572  IF(mint(121).EQ.6) mint(123)=7
3573  msub(11)=1
3574  msub(12)=1
3575  msub(13)=1
3576  msub(28)=1
3577  msub(53)=1
3578  msub(68)=1
3579  IF(mstp(82).GE.2) mstp(85)=1
3580  IF(iptl.EQ.1) ckin(3)=ptmano
3581 
3582 C...Set up for direct * direct gamma (switch off leptons).
3583  ELSEIF(mint(122).EQ.4) THEN
3584  mint(123)=0
3585  msub(58)=1
3586  DO 110 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
3587  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
3588  110 CONTINUE
3589  IF(iptl.EQ.1) ckin(3)=ptmdir
3590 
3591 C...Set up for direct * anomalous gamma.
3592  ELSEIF(mint(122).EQ.5) THEN
3593  mint(123)=6
3594  msub(33)=1
3595  msub(54)=1
3596  IF(iptl.EQ.1) ckin(3)=ptmano
3597 
3598 C...Set up for anomalous * anomalous gamma.
3599  ELSEIF(mint(122).EQ.6) THEN
3600  mint(123)=3
3601  msub(11)=1
3602  msub(12)=1
3603  msub(13)=1
3604  msub(28)=1
3605  msub(53)=1
3606  msub(68)=1
3607  IF(mstp(82).GE.2) mstp(85)=1
3608  IF(iptl.EQ.1) ckin(3)=ptmano
3609  ENDIF
3610 
3611 C...End of special set up for gamma-p and gamma-gamma.
3612  ckin(1)=2d0*ckin(3)
3613  ENDIF
3614 
3615 C...Flavour information for individual beams.
3616  DO 120 i=1,2
3617  mint(40+i)=1
3618  IF(mint(123).GE.1.AND.mint(10+i).EQ.22) mint(40+i)=2
3619  IF(iabs(mint(10+i)).GT.100) mint(40+i)=2
3620  IF(mint(10+i).EQ.28.OR.mint(10+i).EQ.29) mint(40+i)=2
3621  mint(44+i)=mint(40+i)
3622  IF(mstp(11).GE.1.AND.iabs(mint(10+i)).EQ.11) mint(44+i)=3
3623  120 CONTINUE
3624 
3625 C...If two gammas, whereof one direct, pick the first.
3626  IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
3627  IF(mint(123).GE.4.AND.mint(123).LE.6) THEN
3628  mint(41)=1
3629  mint(45)=1
3630  ENDIF
3631  ELSEIF(mint(11).EQ.22.OR.mint(12).EQ.22) THEN
3632  IF(mint(123).GE.4) CALL pyerrm(26,
3633  & '(PYINPR:) unallowed MSTP(14) code for single photon')
3634  ENDIF
3635 
3636 C...Flavour information on combination of incoming particles.
3637  mint(43)=2*mint(41)+mint(42)-2
3638  mint(44)=mint(43)
3639  IF(mint(123).LE.0) THEN
3640  IF(mint(11).EQ.22) mint(43)=mint(43)+2
3641  IF(mint(12).EQ.22) mint(43)=mint(43)+1
3642  ELSEIF(mint(123).LE.3) THEN
3643  IF(mint(11).EQ.22) mint(44)=mint(44)-2
3644  IF(mint(12).EQ.22) mint(44)=mint(44)-1
3645  ELSEIF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
3646  mint(43)=4
3647  mint(44)=1
3648  ENDIF
3649  mint(47)=2*min(2,mint(45))+min(2,mint(46))-2
3650  IF(min(mint(45),mint(46)).EQ.3) mint(47)=5
3651  mint(50)=0
3652  IF(mint(41).EQ.2.AND.mint(42).EQ.2) mint(50)=1
3653  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.mint(123).GE.3)
3654  &mint(50)=0
3655  mint(107)=0
3656  IF(mint(11).EQ.22) THEN
3657  mint(107)=mint(123)
3658  IF(mint(123).GE.4) mint(107)=0
3659  IF(mint(123).EQ.7) mint(107)=2
3660  ENDIF
3661  mint(108)=0
3662  IF(mint(12).EQ.22) THEN
3663  mint(108)=mint(123)
3664  IF(mint(123).GE.4) mint(108)=mint(123)-3
3665  IF(mint(123).EQ.7) mint(108)=3
3666  ENDIF
3667 
3668 C...Select default processes according to incoming beams
3669 C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
3670  IF(mint(121).GT.1) THEN
3671  ELSEIF(msel.EQ.1.OR.msel.EQ.2) THEN
3672 
3673  IF(mint(43).EQ.1) THEN
3674 C...Lepton + lepton -> gamma/Z0 or W.
3675  IF(mint(11)+mint(12).EQ.0) msub(1)=1
3676  IF(mint(11)+mint(12).NE.0) msub(2)=1
3677 
3678  ELSEIF(mint(43).LE.3.AND.mint(123).EQ.0.AND.
3679  & (mint(11).EQ.22.OR.mint(12).EQ.22)) THEN
3680 C...Unresolved photon + lepton: Compton scattering.
3681  msub(34)=1
3682 
3683  ELSEIF(mint(43).LE.3) THEN
3684 C...Lepton + hadron: deep inelastic scattering.
3685  msub(10)=1
3686 
3687  ELSEIF(mint(123).EQ.0.AND.mint(11).EQ.22.AND.
3688  & mint(12).EQ.22) THEN
3689 C...Two unresolved photons: fermion pair production.
3690  msub(58)=1
3691 
3692  ELSEIF((mint(123).EQ.0.AND.(mint(11).EQ.22.OR.mint(12).EQ.22))
3693  & .OR.(mint(123).GE.4.AND.mint(123).LE.6.AND.mint(11).EQ.22.AND.
3694  & mint(12).EQ.22)) THEN
3695 C...Unresolved photon + hadron: photon-parton scattering.
3696  msub(33)=1
3697  msub(34)=1
3698  msub(54)=1
3699 
3700  ELSEIF(msel.EQ.1) THEN
3701 C...High-pT QCD processes:
3702  msub(11)=1
3703  msub(12)=1
3704  msub(13)=1
3705  msub(28)=1
3706  msub(53)=1
3707  msub(68)=1
3708  IF(mstp(82).LE.1.AND.ckin(3).LT.parp(81)) msub(95)=1
3709  IF(mstp(82).GE.2.AND.ckin(3).LT.parp(82)) msub(95)=1
3710  IF(msub(95).EQ.1.AND.mint(50).EQ.0) msub(95)=0
3711 
3712  ELSE
3713 C...All QCD processes:
3714  msub(11)=1
3715  msub(12)=1
3716  msub(13)=1
3717  msub(28)=1
3718  msub(53)=1
3719  msub(68)=1
3720  msub(91)=1
3721  msub(92)=1
3722  msub(93)=1
3723  msub(94)=1
3724  msub(95)=1
3725  ENDIF
3726 
3727  ELSEIF(msel.GE.4.AND.msel.LE.8) THEN
3728 C...Heavy quark production.
3729  msub(81)=1
3730  msub(82)=1
3731  msub(84)=1
3732  DO 130 j=1,min(8,mdcy(21,3))
3733  mdme(mdcy(21,2)+j-1,1)=0
3734  130 CONTINUE
3735  mdme(mdcy(21,2)+msel-1,1)=1
3736  msub(85)=1
3737  DO 140 j=1,min(12,mdcy(22,3))
3738  mdme(mdcy(22,2)+j-1,1)=0
3739  140 CONTINUE
3740  mdme(mdcy(22,2)+msel-1,1)=1
3741 
3742  ELSEIF(msel.EQ.10) THEN
3743 C...Prompt photon production:
3744  msub(14)=1
3745  msub(18)=1
3746  msub(29)=1
3747 
3748  ELSEIF(msel.EQ.11) THEN
3749 C...Z0/gamma* production:
3750  msub(1)=1
3751 
3752  ELSEIF(msel.EQ.12) THEN
3753 C...W+/- production:
3754  msub(2)=1
3755 
3756  ELSEIF(msel.EQ.13) THEN
3757 C...Z0 + jet:
3758  msub(15)=1
3759  msub(30)=1
3760 
3761  ELSEIF(msel.EQ.14) THEN
3762 C...W+/- + jet:
3763  msub(16)=1
3764  msub(31)=1
3765 
3766  ELSEIF(msel.EQ.15) THEN
3767 C...Z0 & W+/- pair production:
3768  msub(19)=1
3769  msub(20)=1
3770  msub(22)=1
3771  msub(23)=1
3772  msub(25)=1
3773 
3774  ELSEIF(msel.EQ.16) THEN
3775 C...h0 production:
3776  msub(3)=1
3777  msub(102)=1
3778  msub(103)=1
3779  msub(123)=1
3780  msub(124)=1
3781 
3782  ELSEIF(msel.EQ.17) THEN
3783 C...h0 & Z0 or W+/- pair production:
3784  msub(24)=1
3785  msub(26)=1
3786 
3787  ELSEIF(msel.EQ.18) THEN
3788 C...h0 production; interesting processes in e+e-.
3789  msub(24)=1
3790  msub(103)=1
3791  msub(123)=1
3792  msub(124)=1
3793 
3794  ELSEIF(msel.EQ.19) THEN
3795 C...h0, H0 and A0 production; interesting processes in e+e-.
3796  msub(24)=1
3797  msub(103)=1
3798  msub(123)=1
3799  msub(124)=1
3800  msub(153)=1
3801  msub(171)=1
3802  msub(173)=1
3803  msub(174)=1
3804  msub(158)=1
3805  msub(176)=1
3806  msub(178)=1
3807  msub(179)=1
3808 
3809  ELSEIF(msel.EQ.21) THEN
3810 C...Z'0 production:
3811  msub(141)=1
3812 
3813  ELSEIF(msel.EQ.22) THEN
3814 C...W'+/- production:
3815  msub(142)=1
3816 
3817  ELSEIF(msel.EQ.23) THEN
3818 C...H+/- production:
3819  msub(143)=1
3820 
3821  ELSEIF(msel.EQ.24) THEN
3822 C...R production:
3823  msub(144)=1
3824 
3825  ELSEIF(msel.EQ.25) THEN
3826 C...LQ (leptoquark) production.
3827  msub(145)=1
3828  msub(162)=1
3829  msub(163)=1
3830  msub(164)=1
3831 
3832  ELSEIF(msel.GE.35.AND.msel.LE.38) THEN
3833 C...Production of one heavy quark (W exchange):
3834  msub(83)=1
3835  DO 150 j=1,min(8,mdcy(21,3))
3836  mdme(mdcy(21,2)+j-1,1)=0
3837  150 CONTINUE
3838  mdme(mdcy(21,2)+msel-31,1)=1
3839 
3840 CMRENNA++Define SUSY alternatives.
3841  ELSEIF(msel.EQ.39) THEN
3842 C...Turn on all SUSY processes.
3843  IF(mint(43).EQ.4) THEN
3844 C...Hadron-hadron processes.
3845  DO 160 i=201,280
3846  IF(iset(i).GE.0) msub(i)=1
3847  160 CONTINUE
3848  ELSEIF(mint(43).EQ.1) THEN
3849 C...Lepton-lepton processes: QED production of squarks.
3850  DO 170 i=201,214
3851  msub(i)=1
3852  170 CONTINUE
3853  msub(210)=0
3854  msub(211)=0
3855  msub(212)=0
3856  DO 180 i=216,228
3857  msub(i)=1
3858  180 CONTINUE
3859  DO 190 i=261,263
3860  msub(i)=1
3861  190 CONTINUE
3862  msub(277)=1
3863  msub(278)=1
3864  ENDIF
3865 
3866  ELSEIF(msel.EQ.40) THEN
3867 C...Gluinos and squarks.
3868  IF(mint(43).EQ.4) THEN
3869  msub(243)=1
3870  msub(244)=1
3871  msub(258)=1
3872  msub(259)=1
3873  msub(261)=1
3874  msub(262)=1
3875  msub(264)=1
3876  msub(265)=1
3877  DO 200 i=271,280
3878  msub(i)=1
3879  200 CONTINUE
3880  ELSEIF(mint(43).EQ.1) THEN
3881  msub(277)=1
3882  msub(278)=1
3883  ENDIF
3884 
3885  ELSEIF(msel.EQ.41) THEN
3886 C...Stop production.
3887  msub(261)=1
3888  msub(262)=1
3889  msub(263)=1
3890  IF(mint(43).EQ.4) THEN
3891  msub(264)=1
3892  msub(265)=1
3893  ENDIF
3894 
3895  ELSEIF(msel.EQ.42) THEN
3896 C...Slepton production.
3897  DO 210 i=201,214
3898  msub(i)=1
3899  210 CONTINUE
3900  IF(mint(43).NE.4) THEN
3901  msub(210)=0
3902  msub(211)=0
3903  msub(212)=0
3904  ENDIF
3905 
3906  ELSEIF(msel.EQ.43) THEN
3907 C...Neutralino/Chargino + Gluino/Squark.
3908  IF(mint(43).EQ.4) THEN
3909  DO 220 i=237,242
3910  msub(i)=1
3911  220 CONTINUE
3912  DO 230 i=246,257
3913  msub(i)=1
3914  230 CONTINUE
3915  ENDIF
3916 
3917  ELSEIF(msel.EQ.44) THEN
3918 C...Neutralino/Chargino pair production.
3919  IF(mint(43).EQ.4) THEN
3920  DO 240 i=216,236
3921  msub(i)=1
3922  240 CONTINUE
3923  ELSEIF(mint(43).EQ.1) THEN
3924  DO 250 i=216,228
3925  msub(i)=1
3926  250 CONTINUE
3927  ENDIF
3928  ENDIF
3929 
3930 C...Find heaviest new quark flavour allowed in processes 81-84.
3931  kflqm=1
3932  DO 260 i=1,min(8,mdcy(21,3))
3933  idc=i+mdcy(21,2)-1
3934  IF(mdme(idc,1).LE.0) goto 260
3935  kflqm=i
3936  260 CONTINUE
3937  IF(mstp(7).GE.1.AND.mstp(7).LE.8.AND.(msel.LE.3.OR.msel.GE.9))
3938  &kflqm=mstp(7)
3939  mint(55)=kflqm
3940  kfpr(81,1)=kflqm
3941  kfpr(81,2)=kflqm
3942  kfpr(82,1)=kflqm
3943  kfpr(82,2)=kflqm
3944  kfpr(83,1)=kflqm
3945  kfpr(84,1)=kflqm
3946  kfpr(84,2)=kflqm
3947 
3948 C...Find heaviest new fermion flavour allowed in process 85.
3949  kflfm=1
3950  DO 270 i=1,min(12,mdcy(22,3))
3951  idc=i+mdcy(22,2)-1
3952  IF(mdme(idc,1).LE.0) goto 270
3953  kflfm=kfdp(idc,1)
3954  270 CONTINUE
3955  IF(((mstp(7).GE.1.AND.mstp(7).LE.8).OR.(mstp(7).GE.11.AND.
3956  &mstp(7).LE.18)).AND.(msel.LE.3.OR.msel.GE.9)) kflfm=mstp(7)
3957  mint(56)=kflfm
3958  kfpr(85,1)=kflfm
3959  kfpr(85,2)=kflfm
3960 
3961  RETURN
3962  END
3963 
3964 C*********************************************************************
3965 
3966 C...PYXTOT
3967 C...Parametrizes total, elastic and diffractive cross-sections
3968 C...for different energies and beams. Donnachie-Landshoff for
3969 C...total and Schuler-Sjostrand for elastic and diffractive.
3970 C...Process code IPROC:
3971 C...= 1 : p + p;
3972 C...= 2 : pbar + p;
3973 C...= 3 : pi+ + p;
3974 C...= 4 : pi- + p;
3975 C...= 5 : pi0 + p;
3976 C...= 6 : phi + p;
3977 C...= 7 : J/psi + p;
3978 C...= 11 : rho + rho;
3979 C...= 12 : rho + phi;
3980 C...= 13 : rho + J/psi;
3981 C...= 14 : phi + phi;
3982 C...= 15 : phi + J/psi;
3983 C...= 16 : J/psi + J/psi;
3984 C...= 21 : gamma + p (DL);
3985 C...= 22 : gamma + p (VDM).
3986 C...= 23 : gamma + pi (DL);
3987 C...= 24 : gamma + pi (VDM);
3988 C...= 25 : gamma + gamma (DL);
3989 C...= 26 : gamma + gamma (VDM).
3990 
3991  SUBROUTINE pyxtot
3992 
3993 C...Double precision and integer declarations.
3994  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3995  INTEGER pyk,pychge,pycomp
3996 C...Commonblocks.
3997  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3998  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3999  common/pyint1/mint(400),vint(400)
4000  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4001  common/pyint7/sigt(0:6,0:6,0:5)
4002  SAVE /pydat1/,/pypars/,/pyint1/,/pyint5/,/pyint7/
4003 C...Local arrays.
4004  dimension nproc(30),xpar(30),ypar(30),ihada(20),ihadb(20),
4005  &pmhad(4),bhad(4),betp(4),ifitsd(20),ifitdd(20),ceffs(10,8),
4006  &ceffd(10,9),sigtmp(6,0:5)
4007 
4008 C...Common constants.
4009  DATA eps/0.0808d0/, eta/-0.4525d0/, alp/0.25d0/, cres/2d0/,
4010  &pmrc/1.062d0/, smp/0.880d0/, facel/0.0511d0/, facsd/0.0336d0/,
4011  &facdd/0.0084d0/
4012 
4013 C...Number of multiple processes to be evaluated (= 0 : undefined).
4014  DATA nproc/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4015 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4016  DATA xpar/2*21.70d0,3*13.63d0,10.01d0,0.970d0,3*0d0,
4017  &8.56d0,6.29d0,0.609d0,4.62d0,0.447d0,0.0434d0,4*0d0,
4018  &0.0677d0,0.0534d0,0.0425d0,0.0335d0,2.11d-4,1.31d-4,4*0d0/
4019  DATA ypar/
4020  &56.08d0,98.39d0,27.56d0,36.02d0,31.79d0,-1.51d0,-0.146d0,3*0d0,
4021  &13.08d0,-0.62d0,-0.060d0,0.030d0,-0.0028d0,0.00028d0,4*0d0,
4022  &0.129d0,0.115d0,0.081d0,0.072d0,2.15d-4,1.70d-4,4*0d0/
4023 
4024 C...Beam and target hadron class:
4025 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4026  DATA ihada/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4027  DATA ihadb/7*1,3*0,2,3,4,3,2*4,4*0/
4028 C...Characteristic class masses, slope parameters, beta = sqrt(X).
4029  DATA pmhad/0.938d0,0.770d0,1.020d0,3.097d0/
4030  DATA bhad/2.3d0,1.4d0,1.4d0,0.23d0/
4031  DATA betp/4.658d0,2.926d0,2.149d0,0.208d0/
4032 
4033 C...Fitting constants used in parametrizations of diffractive results.
4034  DATA ifitsd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4035  DATA ifitdd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4036  DATA ((ceffs(j1,j2),j2=1,8),j1=1,10)/
4037  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.213d0, 0.0d0, -0.47d0, 150d0,
4038  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.267d0, 0.0d0, -0.47d0, 100d0,
4039  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.232d0, 0.0d0, -0.47d0, 110d0,
4040  &0.213d0, 7.0d0, -0.55d0, 800d0, 0.115d0, 0.0d0, -0.47d0, 110d0,
4041  &0.267d0, 0.0d0, -0.46d0, 75d0, 0.267d0, 0.0d0, -0.46d0, 75d0,
4042  &0.232d0, 0.0d0, -0.46d0, 85d0, 0.267d0, 0.0d0, -0.48d0, 100d0,
4043  &0.115d0, 0.0d0, -0.50d0, 90d0, 0.267d0, 6.0d0, -0.56d0, 420d0,
4044  &0.232d0, 0.0d0, -0.48d0, 110d0, 0.232d0, 0.0d0, -0.48d0, 110d0,
4045  &0.115d0, 0.0d0, -0.52d0, 120d0, 0.232d0, 6.0d0, -0.56d0, 470d0,
4046  &0.115d0, 5.5d0, -0.58d0, 570d0, 0.115d0, 5.5d0, -0.58d0, 570d0/
4047  DATA ((ceffd(j1,j2),j2=1,9),j1=1,10)/
4048  &3.11d0, -7.34d0, 9.71d0, 0.068d0, -0.42d0, 1.31d0,
4049  &-1.37d0, 35.0d0, 118d0, 3.11d0, -7.10d0, 10.6d0,
4050  &0.073d0, -0.41d0, 1.17d0, -1.41d0, 31.6d0, 95d0,
4051  &3.12d0, -7.43d0, 9.21d0, 0.067d0, -0.44d0, 1.41d0,
4052  &-1.35d0, 36.5d0, 132d0, 3.13d0, -8.18d0, -4.20d0,
4053  &0.056d0, -0.71d0, 3.12d0, -1.12d0, 55.2d0, 1298d0,
4054  &3.11d0, -6.90d0, 11.4d0, 0.078d0, -0.40d0, 1.05d0,
4055  &-1.40d0, 28.4d0, 78d0, 3.11d0, -7.13d0, 10.0d0,
4056  &0.071d0, -0.41d0, 1.23d0, -1.34d0, 33.1d0, 105d0,
4057  &3.12d0, -7.90d0, -1.49d0, 0.054d0, -0.64d0, 2.72d0,
4058  &-1.13d0, 53.1d0, 995d0, 3.11d0, -7.39d0, 8.22d0,
4059  &0.065d0, -0.44d0, 1.45d0, -1.36d0, 38.1d0, 148d0,
4060  &3.18d0, -8.95d0, -3.37d0, 0.057d0, -0.76d0, 3.32d0,
4061  &-1.12d0, 55.6d0, 1472d0, 4.18d0, -29.2d0, 56.2d0,
4062  &0.074d0, -1.36d0, 6.67d0, -1.14d0, 116.2d0, 6532d0/
4063 
4064 C...Parameters. Combinations of the energy.
4065  aem=paru(101)
4066  pmth=parp(102)
4067  s=vint(2)
4068  srt=vint(1)
4069  seps=s**eps
4070  seta=s**eta
4071  slog=log(s)
4072 
4073 C...Ratio of gamma/pi (for rescaling in parton distributions).
4074  vint(281)=(xpar(22)*seps+ypar(22)*seta)/
4075  &(xpar(5)*seps+ypar(5)*seta)
4076  IF(mint(50).NE.1) RETURN
4077 
4078 C...Order flavours of incoming particles: KF1 < KF2.
4079  IF(iabs(mint(11)).LE.iabs(mint(12))) THEN
4080  kf1=iabs(mint(11))
4081  kf2=iabs(mint(12))
4082  iord=1
4083  ELSE
4084  kf1=iabs(mint(12))
4085  kf2=iabs(mint(11))
4086  iord=2
4087  ENDIF
4088  isgn12=isign(1,mint(11)*mint(12))
4089 
4090 C...Find process number (for lookup tables).
4091  IF(kf1.GT.1000) THEN
4092  iproc=1
4093  IF(isgn12.LT.0) iproc=2
4094  ELSEIF(kf1.GT.100.AND.kf2.GT.1000) THEN
4095  iproc=3
4096  IF(isgn12.LT.0) iproc=4
4097  IF(kf1.EQ.111) iproc=5
4098  ELSEIF(kf1.GT.100) THEN
4099  iproc=11
4100  ELSEIF(kf2.GT.1000) THEN
4101  iproc=21
4102  IF(mint(123).EQ.2) iproc=22
4103  ELSEIF(kf2.GT.100) THEN
4104  iproc=23
4105  IF(mint(123).EQ.2) iproc=24
4106  ELSE
4107  iproc=25
4108  IF(mint(123).EQ.2) iproc=26
4109  ENDIF
4110 
4111 C... Number of multiple processes to be stored; beam/target side.
4112  npr=nproc(iproc)
4113  mint(101)=1
4114  mint(102)=1
4115  IF(npr.EQ.3) THEN
4116  mint(100+iord)=4
4117  ELSEIF(npr.EQ.6) THEN
4118  mint(101)=4
4119  mint(102)=4
4120  ENDIF
4121  n1=0
4122  IF(mint(101).EQ.4) n1=4
4123  n2=0
4124  IF(mint(102).EQ.4) n2=4
4125 
4126 C...Do not do any more for user-set or undefined cross-sections.
4127  IF(mstp(31).LE.0) RETURN
4128  IF(npr.EQ.0) CALL pyerrm(26,
4129  &'(PYXTOT:) cross section for this process not yet implemented')
4130 
4131 C...Parameters. Combinations of the energy.
4132  aem=paru(101)
4133  pmth=parp(102)
4134  s=vint(2)
4135  srt=vint(1)
4136  seps=s**eps
4137  seta=s**eta
4138  slog=log(s)
4139 
4140 C...Loop over multiple processes (for VDM).
4141  DO 110 i=1,npr
4142  IF(npr.EQ.1) THEN
4143  ipr=iproc
4144  ELSEIF(npr.EQ.3) THEN
4145  ipr=i+4
4146  IF(kf2.LT.1000) ipr=i+10
4147  ELSEIF(npr.EQ.6) THEN
4148  ipr=i+10
4149  ENDIF
4150 
4151 C...Evaluate hadron species, mass, slope contribution and fit number.
4152  iha=ihada(ipr)
4153  ihb=ihadb(ipr)
4154  pma=pmhad(iha)
4155  pmb=pmhad(ihb)
4156  bha=bhad(iha)
4157  bhb=bhad(ihb)
4158  isd=ifitsd(ipr)
4159  idd=ifitdd(ipr)
4160 
4161 C...Skip if energy too low relative to masses.
4162  DO 100 j=0,5
4163  sigtmp(i,j)=0d0
4164  100 CONTINUE
4165  IF(srt.LT.pma+pmb+parp(104)) goto 110
4166 
4167 C...Total cross-section. Elastic slope parameter and cross-section.
4168  sigtmp(i,0)=xpar(ipr)*seps+ypar(ipr)*seta
4169  bel=2d0*bha+2d0*bhb+4d0*seps-4.2d0
4170  sigtmp(i,1)=facel*sigtmp(i,0)**2/bel
4171 
4172 C...Diffractive scattering A + B -> X + B.
4173  bsd=2d0*bhb
4174  sqml=(pma+pmth)**2
4175  sqmu=s*ceffs(isd,1)+ceffs(isd,2)
4176  sum1=log((bsd+2d0*alp*log(s/sqml))/
4177  & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
4178  bxb=ceffs(isd,3)+ceffs(isd,4)/s
4179  sum2=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)/
4180  & (bsd+2d0*alp*log(s/((pma+pmth)*(pma+pmrc)))+bxb)
4181  sigtmp(i,2)=facsd*xpar(ipr)*betp(ihb)*max(0d0,sum1+sum2)
4182 
4183 C...Diffractive scattering A + B -> A + X.
4184  bsd=2d0*bha
4185  sqml=(pmb+pmth)**2
4186  sqmu=s*ceffs(isd,5)+ceffs(isd,6)
4187  sum1=log((bsd+2d0*alp*log(s/sqml))/
4188  & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
4189  bax=ceffs(isd,7)+ceffs(isd,8)/s
4190  sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/
4191  & (bsd+2d0*alp*log(s/((pmb+pmth)*(pmb+pmrc)))+bax)
4192  sigtmp(i,3)=facsd*xpar(ipr)*betp(iha)*max(0d0,sum1+sum2)
4193 
4194 C...Order single diffractive correctly.
4195  IF(iord.EQ.2) THEN
4196  sigsav=sigtmp(i,2)
4197  sigtmp(i,2)=sigtmp(i,3)
4198  sigtmp(i,3)=sigsav
4199  ENDIF
4200 
4201 C...Double diffractive scattering A + B -> X1 + X2.
4202  yeff=log(s*smp/((pma+pmth)*(pmb+pmth))**2)
4203  deff=ceffd(idd,1)+ceffd(idd,2)/slog+ceffd(idd,3)/slog**2
4204  sum1=deff+yeff*(log(max(1d-10,yeff/deff))-1d0)/(2d0*alp)
4205  IF(yeff.LE.0) sum1=0d0
4206  sqmu=s*(ceffd(idd,4)+ceffd(idd,5)/slog+ceffd(idd,6)/slog**2)
4207  slup=log(max(1.1d0,s/(alp*(pma+pmth)**2*(pmb+pmth)*(pmb+pmrc))))
4208  sldn=log(max(1.1d0,s/(alp*sqmu*(pmb+pmth)*(pmb+pmrc))))
4209  sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)*log(slup/sldn)/
4210  & (2d0*alp)
4211  slup=log(max(1.1d0,s/(alp*(pmb+pmth)**2*(pma+pmth)*(pma+pmrc))))
4212  sldn=log(max(1.1d0,s/(alp*sqmu*(pma+pmth)*(pma+pmrc))))
4213  sum3=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)*log(slup/sldn)/
4214  & (2d0*alp)
4215  bxx=ceffd(idd,7)+ceffd(idd,8)/srt+ceffd(idd,9)/s
4216  slrr=log(s/(alp*(pma+pmth)*(pma+pmrc)*(pmb+pmth)*(pmb*pmrc)))
4217  sum4=cres**2*log(1d0+((pma+pmrc)/(pma+pmth))**2)*
4218  & log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/max(0.1d0,2d0*alp*slrr+bxx)
4219  sigtmp(i,4)=facdd*xpar(ipr)*max(0d0,sum1+sum2+sum3+sum4)
4220 
4221 C...Non-diffractive by unitarity.
4222  sigtmp(i,5)=sigtmp(i,0)-sigtmp(i,1)-sigtmp(i,2)-sigtmp(i,3)-
4223  & sigtmp(i,4)
4224  110 CONTINUE
4225 
4226 C...Put temporary results in output array: only one process.
4227  IF(mint(101).EQ.1.AND.mint(102).EQ.1) THEN
4228  DO 120 j=0,5
4229  sigt(0,0,j)=sigtmp(1,j)
4230  120 CONTINUE
4231 
4232 C...Beam multiple processes.
4233  ELSEIF(mint(101).EQ.4.AND.mint(102).EQ.1) THEN
4234  DO 140 i=1,4
4235  conv=aem/parp(160+i)
4236  i1=max(1,i-1)
4237  DO 130 j=0,5
4238  sigt(i,0,j)=conv*sigtmp(i1,j)
4239  130 CONTINUE
4240  140 CONTINUE
4241  DO 150 j=0,5
4242  sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
4243  150 CONTINUE
4244 
4245 C...Target multiple processes.
4246  ELSEIF(mint(101).EQ.1.AND.mint(102).EQ.4) THEN
4247  DO 170 i=1,4
4248  conv=aem/parp(160+i)
4249  iv=max(1,i-1)
4250  DO 160 j=0,5
4251  sigt(0,i,j)=conv*sigtmp(iv,j)
4252  160 CONTINUE
4253  170 CONTINUE
4254  DO 180 j=0,5
4255  sigt(0,0,j)=sigt(0,1,j)+sigt(0,2,j)+sigt(0,3,j)+sigt(0,4,j)
4256  180 CONTINUE
4257 
4258 C...Both beam and target multiple processes.
4259  ELSE
4260  DO 210 i1=1,4
4261  DO 200 i2=1,4
4262  conv=aem**2/(parp(160+i1)*parp(160+i2))
4263  IF(i1.LE.2) THEN
4264  iv=max(1,i2-1)
4265  ELSEIF(i2.LE.2) THEN
4266  iv=max(1,i1-1)
4267  ELSEIF(i1.EQ.i2) THEN
4268  iv=2*i1-2
4269  ELSE
4270  iv=5
4271  ENDIF
4272  DO 190 j=0,5
4273  jv=j
4274  IF(i2.GT.i1.AND.(j.EQ.2.OR.j.EQ.3)) jv=5-j
4275  sigt(i1,i2,j)=conv*sigtmp(iv,jv)
4276  190 CONTINUE
4277  200 CONTINUE
4278  210 CONTINUE
4279  DO 230 j=0,5
4280  DO 220 i=1,4
4281  sigt(i,0,j)=sigt(i,1,j)+sigt(i,2,j)+sigt(i,3,j)+sigt(i,4,j)
4282  sigt(0,i,j)=sigt(1,i,j)+sigt(2,i,j)+sigt(3,i,j)+sigt(4,i,j)
4283  220 CONTINUE
4284  sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
4285  230 CONTINUE
4286  ENDIF
4287 
4288 C...Scale up uniformly for Donnachie-Landshoff parametrization.
4289  IF(iproc.EQ.21.OR.iproc.EQ.23.OR.iproc.EQ.25) THEN
4290  rfac=(xpar(iproc)*seps+ypar(iproc)*seta)/sigt(0,0,0)
4291  DO 260 i1=0,n1
4292  DO 250 i2=0,n2
4293  DO 240 j=0,5
4294  sigt(i1,i2,j)=rfac*sigt(i1,i2,j)
4295  240 CONTINUE
4296  250 CONTINUE
4297  260 CONTINUE
4298  ENDIF
4299 
4300  RETURN
4301  END
4302 
4303 C*********************************************************************
4304 
4305 C...PYMAXI
4306 C...Finds optimal set of coefficients for kinematical variable selection
4307 C...and the maximum of the part of the differential cross-section used
4308 C...in the event weighting.
4309 
4310  SUBROUTINE pymaxi
4311 
4312 C...Double precision and integer declarations.
4313  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4314  INTEGER pyk,pychge,pycomp
4315 C...Parameter statement to help give large particle numbers.
4316  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
4317 C...Commonblocks.
4318  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4319  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4320  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
4321  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
4322  common/pypars/mstp(200),parp(200),msti(200),pari(200)
4323  common/pyint1/mint(400),vint(400)
4324  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4325  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
4326  common/pyint4/mwid(500),wids(500,5)
4327  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4328  common/pyint6/proc(0:500)
4329  CHARACTER proc*28
4330  common/pyint7/sigt(0:6,0:6,0:5)
4331  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
4332  &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint6/,/pyint7/
4333 C...Local arrays, character variables and data.
4334  CHARACTER cvar(4)*4
4335  dimension npts(4),mvarpt(500,4),vintpt(500,30),sigspt(500),
4336  &narel(7),wtrel(7),wtmat(7,7),wtreln(7),coefu(7),coefo(7),
4337  &iaccmx(4),sigsmx(4),sigssm(3),pmmn(2)
4338  DATA cvar/'tau ','tau''','y* ','cth '/
4339  DATA sigssm/3*0d0/
4340 
4341 C...Select subprocess to study: skip cases not applicable.
4342  nposi=0
4343  vint(143)=1d0
4344  vint(144)=1d0
4345  xsec(0,1)=0d0
4346  DO 460 isub=1,500
4347  mint(51)=0
4348  IF(iset(isub).EQ.11) THEN
4349  xsec(isub,1)=1.00001d0*coef(isub,1)
4350  nposi=nposi+1
4351  goto 450
4352  ELSEIF(isub.GE.91.AND.isub.LE.95) THEN
4353  xsec(isub,1)=sigt(0,0,isub-90)
4354  IF(msub(isub).NE.1) goto 460
4355  nposi=nposi+1
4356  goto 450
4357  ELSEIF(isub.EQ.96) THEN
4358  IF(mint(50).EQ.0) goto 460
4359  IF(msub(95).NE.1.AND.mstp(81).LE.0.AND.mstp(131).LE.0)
4360  & goto 460
4361  IF(mint(49).EQ.0.AND.mstp(131).EQ.0) goto 460
4362  ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.
4363  & isub.EQ.53.OR.isub.EQ.68) THEN
4364  IF(msub(isub).NE.1.OR.msub(95).EQ.1) goto 460
4365  ELSE
4366  IF(msub(isub).NE.1) goto 460
4367  ENDIF
4368  mint(1)=isub
4369  istsb=iset(isub)
4370  IF(isub.EQ.96) istsb=2
4371  IF(mstp(122).GE.2) WRITE(mstu(11),5000) isub
4372  mwtxs=0
4373  IF(mstp(142).GE.1.AND.isub.NE.96.AND.msub(91)+msub(92)+msub(93)+
4374  & msub(94)+msub(95).EQ.0) mwtxs=1
4375 
4376 C...Find resonances (explicit or implicit in cross-section).
4377  mint(72)=0
4378  kfr1=0
4379  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
4380  kfr1=kfpr(isub,1)
4381  ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165
4382  & .OR.isub.EQ.171.OR.isub.EQ.176) THEN
4383  kfr1=23
4384  ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172
4385  & .OR.isub.EQ.177) THEN
4386  kfr1=24
4387  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
4388  kfr1=25
4389  IF(mstp(46).EQ.5) THEN
4390  kfr1=30
4391  pmas(30,1)=parp(45)
4392  pmas(30,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
4393  ENDIF
4394  ELSEIF(isub.EQ.194) THEN
4395  kfr1=54
4396  ENDIF
4397  ckmx=ckin(2)
4398  IF(ckmx.LE.0d0) ckmx=vint(1)
4399  kcr1=pycomp(kfr1)
4400  IF(kfr1.NE.0) THEN
4401  IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
4402  & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
4403  ENDIF
4404  IF(kfr1.NE.0) THEN
4405  taur1=pmas(kcr1,1)**2/vint(2)
4406  gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
4407  mint(72)=1
4408  mint(73)=kfr1
4409  vint(73)=taur1
4410  vint(74)=gamr1
4411  ENDIF
4412  kfr2=0
4413  IF(isub.EQ.141.OR.isub.EQ.194) THEN
4414  kfr2=23
4415  IF(isub.EQ.194) kfr2=56
4416  kcr2=pycomp(kfr2)
4417  taur2=pmas(kcr2,1)**2/vint(2)
4418  gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
4419  IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
4420  & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) kfr2=0
4421  IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
4422  mint(72)=2
4423  mint(74)=kfr2
4424  vint(75)=taur2
4425  vint(76)=gamr2
4426  ELSEIF(kfr2.NE.0) THEN
4427  kfr1=kfr2
4428  taur1=taur2
4429  gamr1=gamr2
4430  mint(72)=1
4431  mint(73)=kfr1
4432  vint(73)=taur1
4433  vint(74)=gamr1
4434  kfr2=0
4435  ENDIF
4436  ENDIF
4437 
4438 C...Find product masses and minimum pT of process.
4439  sqm3=0d0
4440  sqm4=0d0
4441  mint(71)=0
4442  vint(71)=ckin(3)
4443  vint(80)=1d0
4444  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
4445  nbw=0
4446  DO 110 i=1,2
4447  pmmn(i)=0d0
4448  IF(kfpr(isub,i).EQ.0) THEN
4449  ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
4450  & parp(41)) THEN
4451  IF(i.EQ.1) sqm3=pmas(pycomp(kfpr(isub,i)),1)**2
4452  IF(i.EQ.2) sqm4=pmas(pycomp(kfpr(isub,i)),1)**2
4453  ELSE
4454  nbw=nbw+1
4455 C...This prevents SUSY/t particles from becoming too light.
4456  kflw=kfpr(isub,i)
4457  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
4458  kcw=pycomp(kflw)
4459  pmmn(i)=pmas(kcw,1)
4460  DO 100 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
4461  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
4462  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
4463  & pmas(pycomp(kfdp(idc,2)),1)
4464  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
4465  & pmas(pycomp(kfdp(idc,3)),1)
4466  pmmn(i)=min(pmmn(i),pmsum)
4467  ENDIF
4468  100 CONTINUE
4469  ELSEIF(kflw.EQ.6) THEN
4470  pmmn(i)=pmas(24,1)+pmas(5,1)
4471  ENDIF
4472  ENDIF
4473  110 CONTINUE
4474  IF(nbw.GE.1) THEN
4475  ckin41=ckin(41)
4476  ckin43=ckin(43)
4477  ckin(41)=max(pmmn(1),ckin(41))
4478  ckin(43)=max(pmmn(2),ckin(43))
4479  CALL pyofsh(3,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
4480  ckin(41)=ckin41
4481  ckin(43)=ckin43
4482  IF(mint(51).EQ.1) THEN
4483  WRITE(mstu(11),5100) isub
4484  msub(isub)=0
4485  goto 460
4486  ENDIF
4487  sqm3=pqm3**2
4488  sqm4=pqm4**2
4489  ENDIF
4490  IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1
4491  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
4492  IF(isub.EQ.96.AND.mstp(82).LE.1) vint(71)=parp(81)
4493  IF(isub.EQ.96.AND.mstp(82).GE.2) vint(71)=0.08d0*parp(82)
4494  ENDIF
4495  vint(63)=sqm3
4496  vint(64)=sqm4
4497 
4498 C...Prepare for additional variable choices in 2 -> 3.
4499  IF(istsb.EQ.5) THEN
4500  vint(201)=0d0
4501  IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
4502  vint(206)=vint(201)
4503  vint(204)=pmas(23,1)
4504  IF(isub.EQ.124) vint(204)=pmas(24,1)
4505  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182
4506  & .OR.isub.EQ.186.OR.isub.EQ.187) vint(204)=vint(201)
4507  vint(209)=vint(204)
4508  ENDIF
4509 
4510 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
4511  npts(1)=2+2*mint(72)
4512  IF(mint(47).EQ.1) THEN
4513  IF(istsb.EQ.1.OR.istsb.EQ.2) npts(1)=1
4514  ELSEIF(mint(47).EQ.5) THEN
4515  IF(istsb.LE.2.OR.istsb.GT.5) npts(1)=npts(1)+1
4516  ENDIF
4517  npts(2)=1
4518  IF(istsb.GE.3.AND.istsb.LE.5) THEN
4519  IF(mint(47).GE.2) npts(2)=2
4520  IF(mint(47).EQ.5) npts(2)=3
4521  ENDIF
4522  npts(3)=1
4523  IF(mint(47).GE.4) npts(3)=3
4524  IF(mint(45).EQ.3) npts(3)=npts(3)+1
4525  IF(mint(46).EQ.3) npts(3)=npts(3)+1
4526  npts(4)=1
4527  IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5
4528  ntry=npts(1)*npts(2)*npts(3)*npts(4)
4529 
4530 C...Reset coefficients of cross-section weighting.
4531  DO 120 j=1,20
4532  coef(isub,j)=0d0
4533  120 CONTINUE
4534  coef(isub,1)=1d0
4535  coef(isub,8)=0.5d0
4536  coef(isub,9)=0.5d0
4537  coef(isub,13)=1d0
4538  coef(isub,18)=1d0
4539  mcth=0
4540  mtaup=0
4541  metaup=0
4542  vint(23)=0d0
4543  vint(26)=0d0
4544  sigsam=0d0
4545 
4546 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
4547 C...in grid of phase space points.
4548  CALL pyklim(1)
4549  metau=mint(51)
4550  nacc=0
4551  DO 150 itry=1,ntry
4552  mint(51)=0
4553  IF(metau.EQ.1) goto 150
4554  IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN
4555  mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))
4556  IF(mtau.GT.2+2*mint(72)) mtau=7
4557  rtau=0.5d0
4558 C...Special case when both resonances have same mass,
4559 C...as is often the case in process 194.
4560  IF(mint(72).EQ.2) THEN
4561  IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LT.
4562  & 0.01d0*(pmas(kcr2,1)+pmas(kcr1,1))) THEN
4563  IF(mtau.EQ.3.OR.mtau.EQ.4) THEN
4564  rtau=0.4d0
4565  ELSEIF(mtau.EQ.5.OR.mtau.EQ.6) THEN
4566  rtau=0.6d0
4567  ENDIF
4568  ENDIF
4569  ENDIF
4570  CALL pykmap(1,mtau,rtau)
4571  IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)
4572  metaup=mint(51)
4573  ENDIF
4574  IF(metaup.EQ.1) goto 150
4575  IF(istsb.GE.3.AND.istsb.LE.5.AND.mod(itry-1,npts(3)*npts(4))
4576  & .EQ.0) THEN
4577  mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))
4578  CALL pykmap(4,mtaup,0.5d0)
4579  ENDIF
4580  IF(mod(itry-1,npts(3)*npts(4)).EQ.0) THEN
4581  CALL pyklim(2)
4582  meyst=mint(51)
4583  ENDIF
4584  IF(meyst.EQ.1) goto 150
4585  IF(mod(itry-1,npts(4)).EQ.0) THEN
4586  myst=1+mod((itry-1)/npts(4),npts(3))
4587  IF(myst.EQ.4.AND.mint(45).NE.3) myst=5
4588  CALL pykmap(2,myst,0.5d0)
4589  CALL pyklim(3)
4590  mecth=mint(51)
4591  ENDIF
4592  IF(mecth.EQ.1) goto 150
4593  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
4594  mcth=1+mod(itry-1,npts(4))
4595  CALL pykmap(3,mcth,0.5d0)
4596  ENDIF
4597  IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)
4598 
4599 C...Store position and limits.
4600  mint(51)=0
4601  CALL pyklim(0)
4602  IF(mint(51).EQ.1) goto 150
4603  nacc=nacc+1
4604  mvarpt(nacc,1)=mtau
4605  mvarpt(nacc,2)=mtaup
4606  mvarpt(nacc,3)=myst
4607  mvarpt(nacc,4)=mcth
4608  DO 130 j=1,30
4609  vintpt(nacc,j)=vint(10+j)
4610  130 CONTINUE
4611 
4612 C...Normal case: calculate cross-section.
4613  IF(istsb.NE.5) THEN
4614  CALL pysigh(nchn,sigs)
4615  IF(mwtxs.EQ.1) THEN
4616  CALL pyevwt(wtxs)
4617  sigs=wtxs*sigs
4618  ENDIF
4619 
4620 C..2 -> 3: find highest value out of a number of tries.
4621  ELSE
4622  sigs=0d0
4623  DO 140 ikin3=1,mstp(129)
4624  CALL pykmap(5,0,0d0)
4625  IF(mint(51).EQ.1) goto 140
4626  CALL pysigh(nchn,sigtmp)
4627  IF(mwtxs.EQ.1) THEN
4628  CALL pyevwt(wtxs)
4629  sigtmp=wtxs*sigtmp
4630  ENDIF
4631  IF(sigtmp.GT.sigs) sigs=sigtmp
4632  140 CONTINUE
4633  ENDIF
4634 
4635 C...Store cross-section.
4636  sigspt(nacc)=sigs
4637  IF(sigs.GT.sigsam) sigsam=sigs
4638  IF(mstp(122).GE.2) WRITE(mstu(11),5200) mtau,myst,mcth,mtaup,
4639  & vint(21),vint(22),vint(23),vint(26),sigs
4640  150 CONTINUE
4641  IF(nacc.EQ.0) THEN
4642  WRITE(mstu(11),5100) isub
4643  msub(isub)=0
4644  goto 460
4645  ELSEIF(sigsam.EQ.0d0) THEN
4646  WRITE(mstu(11),5300) isub
4647  msub(isub)=0
4648  goto 460
4649  ENDIF
4650  IF(isub.NE.96) nposi=nposi+1
4651 
4652 C...Calculate integrals in tau over maximal phase space limits.
4653  taumin=vint(11)
4654  taumax=vint(31)
4655  atau1=log(taumax/taumin)
4656  IF(npts(1).GE.2) THEN
4657  atau2=(taumax-taumin)/(taumax*taumin)
4658  ENDIF
4659  IF(npts(1).GE.4) THEN
4660  atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
4661  atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
4662  & gamr1
4663  ENDIF
4664  IF(npts(1).GE.6) THEN
4665  atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
4666  atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
4667  & gamr2
4668  ENDIF
4669  IF(npts(1).GT.2+2*mint(72)) THEN
4670  atau7=log(max(2d-6,1d0-taumin)/max(2d-6,1d0-taumax))
4671  ENDIF
4672 
4673 C...Reset. Sum up cross-sections in points calculated.
4674  DO 320 ivar=1,4
4675  IF(npts(ivar).EQ.1) goto 320
4676  IF(isub.EQ.96.AND.ivar.EQ.4) goto 320
4677  nbin=npts(ivar)
4678  DO 170 j1=1,nbin
4679  narel(j1)=0
4680  wtrel(j1)=0d0
4681  coefu(j1)=0d0
4682  DO 160 j2=1,nbin
4683  wtmat(j1,j2)=0d0
4684  160 CONTINUE
4685  170 CONTINUE
4686  DO 180 iacc=1,nacc
4687  ibin=mvarpt(iacc,ivar)
4688  IF(ivar.EQ.1.AND.ibin.EQ.7) ibin=3+2*mint(72)
4689  IF(ivar.EQ.3.AND.ibin.EQ.5.AND.mint(45).NE.3) ibin=4
4690  narel(ibin)=narel(ibin)+1
4691  wtrel(ibin)=wtrel(ibin)+sigspt(iacc)
4692 
4693 C...Sum up tau cross-section pieces in points used.
4694  IF(ivar.EQ.1) THEN
4695  tau=vintpt(iacc,11)
4696  wtmat(ibin,1)=wtmat(ibin,1)+1d0
4697  wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau
4698  IF(nbin.GE.4) THEN
4699  wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)
4700  wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/
4701  & ((tau-taur1)**2+gamr1**2)
4702  ENDIF
4703  IF(nbin.GE.6) THEN
4704  wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)
4705  wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/
4706  & ((tau-taur2)**2+gamr2**2)
4707  ENDIF
4708  IF(nbin.GT.2+2*mint(72)) THEN
4709  wtmat(ibin,nbin)=wtmat(ibin,nbin)+(atau1/atau7)*
4710  & tau/max(2d-6,1d0-tau)
4711  ENDIF
4712 
4713 C...Sum up tau' cross-section pieces in points used.
4714  ELSEIF(ivar.EQ.2) THEN
4715  tau=vintpt(iacc,11)
4716  taup=vintpt(iacc,16)
4717  taupmn=vintpt(iacc,6)
4718  taupmx=vintpt(iacc,26)
4719  ataup1=log(taupmx/taupmn)
4720  ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
4721  wtmat(ibin,1)=wtmat(ibin,1)+1d0
4722  wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*
4723  & (1d0-tau/taup)**3/taup
4724  IF(nbin.GE.3) THEN
4725  ataup3=log(max(2d-6,1d0-taupmn)/max(2d-6,1d0-taupmx))
4726  wtmat(ibin,3)=wtmat(ibin,3)+(ataup1/ataup3)*
4727  & taup/max(2d-6,1d0-taup)
4728  ENDIF
4729 
4730 C...Sum up y* cross-section pieces in points used.
4731  ELSEIF(ivar.EQ.3) THEN
4732  yst=vintpt(iacc,12)
4733  ystmin=vintpt(iacc,2)
4734  ystmax=vintpt(iacc,22)
4735  ayst0=ystmax-ystmin
4736  ayst1=0.5d0*(ystmax-ystmin)**2
4737  ayst2=ayst1
4738  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
4739  wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)
4740  wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst2)*(ystmax-yst)
4741  wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)
4742  IF(mint(45).EQ.3) THEN
4743  taue=vintpt(iacc,11)
4744  IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
4745  yst0=-0.5d0*log(taue)
4746  ayst4=log(max(1d-6,exp(yst0-ystmin)-1d0)/
4747  & max(1d-6,exp(yst0-ystmax)-1d0))
4748  wtmat(ibin,4)=wtmat(ibin,4)+(ayst0/ayst4)/
4749  & max(1d-6,1d0-exp(yst-yst0))
4750  ENDIF
4751  IF(mint(46).EQ.3) THEN
4752  taue=vintpt(iacc,11)
4753  IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
4754  yst0=-0.5d0*log(taue)
4755  ayst5=log(max(1d-6,exp(yst0+ystmax)-1d0)/
4756  & max(1d-6,exp(yst0+ystmin)-1d0))
4757  wtmat(ibin,nbin)=wtmat(ibin,nbin)+(ayst0/ayst5)/
4758  & max(1d-6,1d0-exp(-yst-yst0))
4759  ENDIF
4760 
4761 C...Sum up cos(theta-hat) cross-section pieces in points used.
4762  ELSE
4763  rm34=max(1d-20,2d0*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2)
4764  rsqm=1d0+rm34
4765  cthmax=sqrt(1d0-4d0*vint(71)**2/(taumax*vint(2)))
4766  cthmin=-cthmax
4767  IF(cthmax.GT.0.9999d0) rm34=max(rm34,2d0*vint(71)**2/
4768  & (taumax*vint(2)))
4769  acth1=cthmax-cthmin
4770  acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
4771  acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
4772  acth4=1d0/max(rm34,rsqm-cthmax)-1d0/max(rm34,rsqm-cthmin)
4773  acth5=1d0/max(rm34,rsqm+cthmin)-1d0/max(rm34,rsqm+cthmax)
4774  cth=vintpt(iacc,13)
4775  wtmat(ibin,1)=wtmat(ibin,1)+1d0
4776  wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/
4777  & max(rm34,rsqm-cth)
4778  wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/
4779  & max(rm34,rsqm+cth)
4780  wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/
4781  & max(rm34,rsqm-cth)**2
4782  wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/
4783  & max(rm34,rsqm+cth)**2
4784  ENDIF
4785  180 CONTINUE
4786 
4787 C...Check that equation system solvable.
4788  IF(mstp(122).GE.2) WRITE(mstu(11),5400) cvar(ivar)
4789  msolv=1
4790  wtrels=0d0
4791  DO 190 ibin=1,nbin
4792  IF(mstp(122).GE.2) WRITE(mstu(11),5500) (wtmat(ibin,ired),
4793  & ired=1,nbin),wtrel(ibin)
4794  IF(narel(ibin).EQ.0) msolv=0
4795  wtrels=wtrels+wtrel(ibin)
4796  190 CONTINUE
4797  IF(abs(wtrels).LT.1d-20) msolv=0
4798 
4799 C...Solve to find relative importance of cross-section pieces.
4800  IF(msolv.EQ.1) THEN
4801  DO 200 ibin=1,nbin
4802  wtreln(ibin)=max(0.1d0,wtrel(ibin)/wtrels)
4803  200 CONTINUE
4804  DO 230 ired=1,nbin-1
4805  DO 220 ibin=ired+1,nbin
4806  IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
4807  msolv=0
4808  goto 260
4809  ENDIF
4810  rqt=wtmat(ibin,ired)/wtmat(ired,ired)
4811  wtrel(ibin)=wtrel(ibin)-rqt*wtrel(ired)
4812  DO 210 icoe=ired,nbin
4813  wtmat(ibin,icoe)=wtmat(ibin,icoe)-rqt*wtmat(ired,icoe)
4814  210 CONTINUE
4815  220 CONTINUE
4816  230 CONTINUE
4817  DO 250 ired=nbin,1,-1
4818  DO 240 icoe=ired+1,nbin
4819  wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)
4820  240 CONTINUE
4821  coefu(ired)=wtrel(ired)/wtmat(ired,ired)
4822  250 CONTINUE
4823  ENDIF
4824 
4825 C...Share evenly if failure.
4826  260 IF(msolv.EQ.0) THEN
4827  DO 270 ibin=1,nbin
4828  coefu(ibin)=1d0
4829  wtreln(ibin)=0.1d0
4830  IF(wtrels.GT.0d0) wtreln(ibin)=max(0.1d0,
4831  & wtrel(ibin)/wtrels)
4832  270 CONTINUE
4833  ENDIF
4834 
4835 C...Normalize coefficients, with piece shared democratically.
4836  coefsu=0d0
4837  wtrels=0d0
4838  DO 280 ibin=1,nbin
4839  coefu(ibin)=max(0d0,coefu(ibin))
4840  coefsu=coefsu+coefu(ibin)
4841  wtrels=wtrels+wtreln(ibin)
4842  280 CONTINUE
4843  IF(coefsu.GT.0d0) THEN
4844  DO 290 ibin=1,nbin
4845  coefo(ibin)=parp(122)/nbin+(1d0-parp(122))*0.5d0*
4846  & (coefu(ibin)/coefsu+wtreln(ibin)/wtrels)
4847  290 CONTINUE
4848  ELSE
4849  DO 300 ibin=1,nbin
4850  coefo(ibin)=1d0/nbin
4851  300 CONTINUE
4852  ENDIF
4853  IF(ivar.EQ.1) ioff=0
4854  IF(ivar.EQ.2) ioff=17
4855  IF(ivar.EQ.3) ioff=7
4856  IF(ivar.EQ.4) ioff=12
4857  DO 310 ibin=1,nbin
4858  icof=ioff+ibin
4859  IF(ivar.EQ.1.AND.ibin.GT.2+2*mint(72)) icof=7
4860  IF(ivar.EQ.3.AND.ibin.EQ.4.AND.mint(45).NE.3) icof=icof+1
4861  coef(isub,icof)=coefo(ibin)
4862  310 CONTINUE
4863  IF(mstp(122).GE.2) WRITE(mstu(11),5600) cvar(ivar),
4864  & (coefo(ibin),ibin=1,nbin)
4865  320 CONTINUE
4866 
4867 C...Find two most promising maxima among points previously determined.
4868  DO 330 j=1,4
4869  iaccmx(j)=0
4870  sigsmx(j)=0d0
4871  330 CONTINUE
4872  nmax=0
4873  DO 390 iacc=1,nacc
4874  DO 340 j=1,30
4875  vint(10+j)=vintpt(iacc,j)
4876  340 CONTINUE
4877  IF(istsb.NE.5) THEN
4878  CALL pysigh(nchn,sigs)
4879  IF(mwtxs.EQ.1) THEN
4880  CALL pyevwt(wtxs)
4881  sigs=wtxs*sigs
4882  ENDIF
4883  ELSE
4884  sigs=0d0
4885  DO 350 ikin3=1,mstp(129)
4886  CALL pykmap(5,0,0d0)
4887  IF(mint(51).EQ.1) goto 350
4888  CALL pysigh(nchn,sigtmp)
4889  IF(mwtxs.EQ.1) THEN
4890  CALL pyevwt(wtxs)
4891  sigtmp=wtxs*sigtmp
4892  ENDIF
4893  IF(sigtmp.GT.sigs) sigs=sigtmp
4894  350 CONTINUE
4895  ENDIF
4896  ieq=0
4897  DO 360 imv=1,nmax
4898  IF(abs(sigs-sigsmx(imv)).LT.1d-4*(sigs+sigsmx(imv))) ieq=imv
4899  360 CONTINUE
4900  IF(ieq.EQ.0) THEN
4901  DO 370 imv=nmax,1,-1
4902  iin=imv+1
4903  IF(sigs.LE.sigsmx(imv)) goto 380
4904  iaccmx(imv+1)=iaccmx(imv)
4905  sigsmx(imv+1)=sigsmx(imv)
4906  370 CONTINUE
4907  iin=1
4908  380 iaccmx(iin)=iacc
4909  sigsmx(iin)=sigs
4910  IF(nmax.LE.1) nmax=nmax+1
4911  ENDIF
4912  390 CONTINUE
4913 
4914 C...Read out starting position for search.
4915  IF(mstp(122).GE.2) WRITE(mstu(11),5700)
4916  sigsam=sigsmx(1)
4917  DO 440 imax=1,nmax
4918  iacc=iaccmx(imax)
4919  mtau=mvarpt(iacc,1)
4920  mtaup=mvarpt(iacc,2)
4921  myst=mvarpt(iacc,3)
4922  mcth=mvarpt(iacc,4)
4923  vtau=0.5d0
4924  vyst=0.5d0
4925  vcth=0.5d0
4926  vtaup=0.5d0
4927 
4928 C...Starting point and step size in parameter space.
4929  DO 430 irpt=1,2
4930  DO 420 ivar=1,4
4931  IF(npts(ivar).EQ.1) goto 420
4932  IF(ivar.EQ.1) vvar=vtau
4933  IF(ivar.EQ.2) vvar=vtaup
4934  IF(ivar.EQ.3) vvar=vyst
4935  IF(ivar.EQ.4) vvar=vcth
4936  IF(ivar.EQ.1) mvar=mtau
4937  IF(ivar.EQ.2) mvar=mtaup
4938  IF(ivar.EQ.3) mvar=myst
4939  IF(ivar.EQ.4) mvar=mcth
4940  IF(irpt.EQ.1) vdel=0.1d0
4941  IF(irpt.EQ.2) vdel=max(0.01d0,min(0.05d0,vvar-0.02d0,
4942  & 0.98d0-vvar))
4943  IF(irpt.EQ.1) vmar=0.02d0
4944  IF(irpt.EQ.2) vmar=0.002d0
4945  imov0=1
4946  IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0
4947  DO 410 imov=imov0,8
4948 
4949 C...Define new point in parameter space.
4950  IF(imov.EQ.0) THEN
4951  inew=2
4952  vnew=vvar
4953  ELSEIF(imov.EQ.1) THEN
4954  inew=3
4955  vnew=vvar+vdel
4956  ELSEIF(imov.EQ.2) THEN
4957  inew=1
4958  vnew=vvar-vdel
4959  ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.
4960  & vvar+2d0*vdel.LT.1d0-vmar) THEN
4961  vvar=vvar+vdel
4962  sigssm(1)=sigssm(2)
4963  sigssm(2)=sigssm(3)
4964  inew=3
4965  vnew=vvar+vdel
4966  ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.
4967  & vvar-2d0*vdel.GT.vmar) THEN
4968  vvar=vvar-vdel
4969  sigssm(3)=sigssm(2)
4970  sigssm(2)=sigssm(1)
4971  inew=1
4972  vnew=vvar-vdel
4973  ELSEIF(sigssm(3).GE.sigssm(1)) THEN
4974  vdel=0.5d0*vdel
4975  vvar=vvar+vdel
4976  sigssm(1)=sigssm(2)
4977  inew=2
4978  vnew=vvar
4979  ELSE
4980  vdel=0.5d0*vdel
4981  vvar=vvar-vdel
4982  sigssm(3)=sigssm(2)
4983  inew=2
4984  vnew=vvar
4985  ENDIF
4986 
4987 C...Convert to relevant variables and find derived new limits.
4988  IF(ivar.EQ.1) THEN
4989  vtau=vnew
4990  CALL pykmap(1,mtau,vtau)
4991  IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)
4992  ENDIF
4993  IF(ivar.LE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN
4994  IF(ivar.EQ.2) vtaup=vnew
4995  CALL pykmap(4,mtaup,vtaup)
4996  ENDIF
4997  IF(ivar.LE.2) CALL pyklim(2)
4998  IF(ivar.LE.3) THEN
4999  IF(ivar.EQ.3) vyst=vnew
5000  CALL pykmap(2,myst,vyst)
5001  CALL pyklim(3)
5002  ENDIF
5003  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
5004  IF(ivar.EQ.4) vcth=vnew
5005  CALL pykmap(3,mcth,vcth)
5006  ENDIF
5007  IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)
5008 
5009 C...Evaluate cross-section. Save new maximum. Final maximum.
5010  IF(istsb.NE.5) THEN
5011  CALL pysigh(nchn,sigs)
5012  IF(mwtxs.EQ.1) THEN
5013  CALL pyevwt(wtxs)
5014  sigs=wtxs*sigs
5015  ENDIF
5016  ELSE
5017  sigs=0d0
5018  DO 400 ikin3=1,mstp(129)
5019  CALL pykmap(5,0,0d0)
5020  IF(mint(51).EQ.1) goto 400
5021  CALL pysigh(nchn,sigtmp)
5022  IF(mwtxs.EQ.1) THEN
5023  CALL pyevwt(wtxs)
5024  sigtmp=wtxs*sigtmp
5025  ENDIF
5026  IF(sigtmp.GT.sigs) sigs=sigtmp
5027  400 CONTINUE
5028  ENDIF
5029  sigssm(inew)=sigs
5030  IF(sigs.GT.sigsam) sigsam=sigs
5031  IF(mstp(122).GE.2) WRITE(mstu(11),5800) imax,ivar,mvar,
5032  & imov,vnew,vint(21),vint(22),vint(23),vint(26),sigs
5033  410 CONTINUE
5034  420 CONTINUE
5035  430 CONTINUE
5036  440 CONTINUE
5037  IF(mstp(121).EQ.1) sigsam=parp(121)*sigsam
5038  xsec(isub,1)=1.05d0*sigsam
5039  450 CONTINUE
5040  IF(mstp(173).EQ.1.AND.isub.NE.96) xsec(isub,1)=
5041  & parp(174)*xsec(isub,1)
5042  IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)
5043  460 CONTINUE
5044  mint(51)=0
5045 
5046 C...Print summary table.
5047  IF(nposi.EQ.0) THEN
5048  WRITE(mstu(11),5900)
5049  stop
5050  ENDIF
5051  IF(mstp(122).GE.1) THEN
5052  WRITE(mstu(11),6000)
5053  WRITE(mstu(11),6100)
5054  DO 470 isub=1,500
5055  IF(msub(isub).NE.1.AND.isub.NE.96) goto 470
5056  IF(isub.EQ.96.AND.mint(50).EQ.0) goto 470
5057  IF(isub.EQ.96.AND.msub(95).NE.1.AND.mstp(81).LE.0) goto 470
5058  IF(isub.EQ.96.AND.mint(49).EQ.0.AND.mstp(131).EQ.0) goto 470
5059  IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13
5060  & .OR.isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) goto 470
5061  WRITE(mstu(11),6200) isub,proc(isub),xsec(isub,1)
5062  470 CONTINUE
5063  WRITE(mstu(11),6300)
5064  ENDIF
5065 
5066 C...Format statements for maximization results.
5067  5000 FORMAT(/1x,'Coefficient optimization and maximum search for ',
5068  &'subprocess no',i4/1x,'Coefficient modes tau',10x,'y*',9x,
5069  &'cth',9x,'tau''',7x,'sigma')
5070  5100 FORMAT(1x,'Warning: requested subprocess ',i3,' has no allowed ',
5071  &'phase space.'/1x,'Process switched off!')
5072  5200 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,d12.4)
5073  5300 FORMAT(1x,'Warning: requested subprocess ',i3,' has vanishing ',
5074  &'cross-section.'/1x,'Process switched off!')
5075  5400 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)
5076  5500 FORMAT(1x,1p,8d11.3)
5077  5600 FORMAT(1x,'Result for ',a4,':',7f9.4)
5078  5700 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',
5079  &'MOD MOV VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')
5080  5800 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,d12.4)
5081  5900 FORMAT(1x,'Error: no requested process has non-vanishing ',
5082  &'cross-section.'/1x,'Execution stopped!')
5083  6000 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',
5084  &'cross-section maximum search',1x,8('*'))
5085  6100 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I ISUB ',
5086  &'Subprocess name',15x,'I Maximum value I'/11x,'I',38x,'I',
5087  &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')
5088  6200 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,d12.4,3x,'I')
5089  6300 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))
5090 
5091  RETURN
5092  END
5093 
5094 C*********************************************************************
5095 
5096 C...PYPILE
5097 C...Initializes multiplicity distribution and selects mutliplicity
5098 C...of pileup events, i.e. several events occuring at the same
5099 C...beam crossing.
5100 
5101  SUBROUTINE pypile(MPILE)
5102 
5103 C...Double precision and integer declarations.
5104  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5105  INTEGER pyk,pychge,pycomp
5106 C...Commonblocks.
5107  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5108  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5109  common/pyint1/mint(400),vint(400)
5110  common/pyint7/sigt(0:6,0:6,0:5)
5111  SAVE /pydat1/,/pypars/,/pyint1/,/pyint7/
5112 C...Local arrays and saved variables.
5113  dimension wti(0:200)
5114  SAVE imin,imax,wti,wts
5115 
5116 C...Sum of allowed cross-sections for pileup events.
5117  IF(mpile.EQ.1) THEN
5118  vint(131)=sigt(0,0,5)
5119  IF(mstp(132).GE.2) vint(131)=vint(131)+sigt(0,0,4)
5120  IF(mstp(132).GE.3) vint(131)=vint(131)+sigt(0,0,2)+sigt(0,0,3)
5121  IF(mstp(132).GE.4) vint(131)=vint(131)+sigt(0,0,1)
5122  IF(mstp(133).LE.0) RETURN
5123 
5124 C...Initialize multiplicity distribution at maximum.
5125  xnave=vint(131)*parp(131)
5126  IF(xnave.GT.120d0) WRITE(mstu(11),5000) xnave
5127  inave=max(1,min(200,nint(xnave)))
5128  wti(inave)=1d0
5129  wts=wti(inave)
5130  wtn=wti(inave)*inave
5131 
5132 C...Find shape of multiplicity distribution below maximum.
5133  imin=inave
5134  DO 100 i=inave-1,1,-1
5135  IF(mstp(133).EQ.1) wti(i)=wti(i+1)*(i+1)/xnave
5136  IF(mstp(133).GE.2) wti(i)=wti(i+1)*i/xnave
5137  IF(wti(i).LT.1d-6) goto 110
5138  wts=wts+wti(i)
5139  wtn=wtn+wti(i)*i
5140  imin=i
5141  100 CONTINUE
5142 
5143 C...Find shape of multiplicity distribution above maximum.
5144  110 imax=inave
5145  DO 120 i=inave+1,200
5146  IF(mstp(133).EQ.1) wti(i)=wti(i-1)*xnave/i
5147  IF(mstp(133).GE.2) wti(i)=wti(i-1)*xnave/(i-1)
5148  IF(wti(i).LT.1d-6) goto 130
5149  wts=wts+wti(i)
5150  wtn=wtn+wti(i)*i
5151  imax=i
5152  120 CONTINUE
5153  130 vint(132)=xnave
5154  vint(133)=wtn/wts
5155  IF(mstp(133).EQ.1.AND.imin.EQ.1) vint(134)=
5156  & wts/(wts+wti(1)/xnave)
5157  IF(mstp(133).EQ.1.AND.imin.GT.1) vint(134)=1d0
5158  IF(mstp(133).GE.2) vint(134)=xnave
5159 
5160 C...Pick multiplicity of pileup events.
5161  ELSE
5162  IF(mstp(133).LE.0) THEN
5163  mint(81)=max(1,mstp(134))
5164  ELSE
5165  wtr=wts*pyr(0)
5166  DO 140 i=imin,imax
5167  mint(81)=i
5168  wtr=wtr-wti(i)
5169  IF(wtr.LE.0d0) goto 150
5170  140 CONTINUE
5171  150 CONTINUE
5172  ENDIF
5173  ENDIF
5174 
5175 C...Format statement for error message.
5176  5000 FORMAT(1x,'Warning: requested average number of events per bunch',
5177  &'crossing too large, ',1p,d12.4)
5178 
5179  RETURN
5180  END
5181 
5182 C*********************************************************************
5183 
5184 C...PYSAVE
5185 C...Saves and restores parameter and cross section values for the
5186 C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
5187 C...choice between alternatives.
5188 
5189  SUBROUTINE pysave(ISAVE,IGA)
5190 
5191 C...Double precision and integer declarations.
5192  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5193  INTEGER pyk,pychge,pycomp
5194 C...Commonblocks.
5195  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5196  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5197  common/pyint1/mint(400),vint(400)
5198  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5199  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
5200  SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint5/
5201 C...Local arrays and saved variables.
5202  dimension ncp(10),nsubcp(10,20),msubcp(10,20),coefcp(10,20,20),
5203  &ngencp(10,0:20,3),xseccp(10,0:20,3),intcp(10,20),recp(10,20)
5204  SAVE ncp,nsubcp,msubcp,coefcp,ngencp,xseccp,intcp,recp
5205 
5206 C...Save list of subprocesses and cross-section information.
5207  IF(isave.EQ.1) THEN
5208  icp=0
5209  DO 120 i=1,500
5210  IF(msub(i).EQ.0.AND.i.NE.96.AND.i.NE.97) goto 120
5211  icp=icp+1
5212  nsubcp(iga,icp)=i
5213  msubcp(iga,icp)=msub(i)
5214  DO 100 j=1,20
5215  coefcp(iga,icp,j)=coef(i,j)
5216  100 CONTINUE
5217  DO 110 j=1,3
5218  ngencp(iga,icp,j)=ngen(i,j)
5219  xseccp(iga,icp,j)=xsec(i,j)
5220  110 CONTINUE
5221  120 CONTINUE
5222  ncp(iga)=icp
5223  DO 130 j=1,3
5224  ngencp(iga,0,j)=ngen(0,j)
5225  xseccp(iga,0,j)=xsec(0,j)
5226  130 CONTINUE
5227 C...Save various common process variables.
5228  DO 140 j=1,10
5229  intcp(iga,j)=mint(40+j)
5230  140 CONTINUE
5231  intcp(iga,11)=mint(101)
5232  intcp(iga,12)=mint(102)
5233  intcp(iga,13)=mint(107)
5234  intcp(iga,14)=mint(108)
5235  intcp(iga,15)=mint(123)
5236  recp(iga,1)=ckin(3)
5237 
5238 C...Save cross-section information only.
5239  ELSEIF(isave.EQ.2) THEN
5240  DO 160 icp=1,ncp(iga)
5241  i=nsubcp(iga,icp)
5242  DO 150 j=1,3
5243  ngencp(iga,icp,j)=ngen(i,j)
5244  xseccp(iga,icp,j)=xsec(i,j)
5245  150 CONTINUE
5246  160 CONTINUE
5247  DO 170 j=1,3
5248  ngencp(iga,0,j)=ngen(0,j)
5249  xseccp(iga,0,j)=xsec(0,j)
5250  170 CONTINUE
5251 
5252 C...Choose between allowed alternatives.
5253  ELSEIF(isave.EQ.3.OR.isave.EQ.4) THEN
5254  IF(isave.EQ.4) THEN
5255  xsumcp=0d0
5256  DO 180 ig=1,mint(121)
5257  xsumcp=xsumcp+xseccp(ig,0,1)
5258  180 CONTINUE
5259  xsumcp=xsumcp*pyr(0)
5260  DO 190 ig=1,mint(121)
5261  iga=ig
5262  xsumcp=xsumcp-xseccp(ig,0,1)
5263  IF(xsumcp.LE.0d0) goto 200
5264  190 CONTINUE
5265  200 CONTINUE
5266  ENDIF
5267 
5268 C...Restore cross-section information.
5269  DO 210 i=1,500
5270  msub(i)=0
5271  210 CONTINUE
5272  DO 240 icp=1,ncp(iga)
5273  i=nsubcp(iga,icp)
5274  msub(i)=msubcp(iga,icp)
5275  DO 220 j=1,20
5276  coef(i,j)=coefcp(iga,icp,j)
5277  220 CONTINUE
5278  DO 230 j=1,3
5279  ngen(i,j)=ngencp(iga,icp,j)
5280  xsec(i,j)=xseccp(iga,icp,j)
5281  230 CONTINUE
5282  240 CONTINUE
5283  DO 250 j=1,3
5284  ngen(0,j)=ngencp(iga,0,j)
5285  xsec(0,j)=xseccp(iga,0,j)
5286  250 CONTINUE
5287 
5288 C...Restore various common process variables.
5289  DO 260 j=1,10
5290  mint(40+j)=intcp(iga,j)
5291  260 CONTINUE
5292  mint(101)=intcp(iga,11)
5293  mint(102)=intcp(iga,12)
5294  mint(107)=intcp(iga,13)
5295  mint(108)=intcp(iga,14)
5296  mint(123)=intcp(iga,15)
5297  ckin(3)=recp(iga,1)
5298  ckin(1)=2d0*ckin(3)
5299 
5300 C...Sum up cross-section info (for PYSTAT).
5301  ELSEIF(isave.EQ.5) THEN
5302  DO 270 i=1,500
5303  msub(i)=0
5304  ngen(i,1)=0
5305  ngen(i,3)=0
5306  xsec(i,3)=0d0
5307  270 CONTINUE
5308  ngen(0,1)=0
5309  ngen(0,2)=0
5310  ngen(0,3)=0
5311  xsec(0,3)=0
5312  DO 290 ig=1,mint(121)
5313  DO 280 icp=1,ncp(ig)
5314  i=nsubcp(ig,icp)
5315  IF(msubcp(ig,icp).EQ.1) msub(i)=1
5316  ngen(i,1)=ngen(i,1)+ngencp(ig,icp,1)
5317  ngen(i,3)=ngen(i,3)+ngencp(ig,icp,3)
5318  xsec(i,3)=xsec(i,3)+xseccp(ig,icp,3)
5319  280 CONTINUE
5320  ngen(0,1)=ngen(0,1)+ngencp(ig,0,1)
5321  ngen(0,2)=ngen(0,2)+ngencp(ig,0,2)
5322  ngen(0,3)=ngen(0,3)+ngencp(ig,0,3)
5323  xsec(0,3)=xsec(0,3)+xseccp(ig,0,3)
5324  290 CONTINUE
5325  ENDIF
5326 
5327  RETURN
5328  END
5329 
5330 C*********************************************************************
5331 
5332 C...PYRAND
5333 C...Generates quantities characterizing the high-pT scattering at the
5334 C...parton level according to the matrix elements. Chooses incoming,
5335 C...reacting partons, their momentum fractions and one of the possible
5336 C...subprocesses.
5337 
5338  SUBROUTINE pyrand
5339 
5340 C...Double precision and integer declarations.
5341  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5342  INTEGER pyk,pychge,pycomp
5343 C...Parameter statement to help give large particle numbers.
5344  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
5345 C...Commonblocks.
5346  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5347  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5348  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
5349  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5350  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5351  common/pyint1/mint(400),vint(400)
5352  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5353  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
5354  common/pyint4/mwid(500),wids(500,5)
5355  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
5356  common/pyint7/sigt(0:6,0:6,0:5)
5357  common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
5358  common/pymssm/imss(0:99),rmss(0:99)
5359  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
5360  &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,/pyuppr/,/pymssm/
5361 C...Local arrays.
5362  dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)
5363 
5364 C...Parameters and data used in elastic/diffractive treatment.
5365  DATA eps/0.0808d0/, alp/0.25d0/, cres/2d0/, pmrc/1.062d0/,
5366  &smp/0.880d0/, bhad/2.3d0,1.4d0,1.4d0,0.23d0/
5367 
5368 C...Initial values, specifically for (first) semihard interaction.
5369  mint(10)=0
5370  mint(17)=0
5371  mint(18)=0
5372  vint(143)=1d0
5373  vint(144)=1d0
5374  mfail=0
5375  IF(mstp(171).EQ.1.AND.mstp(172).EQ.2) mfail=1
5376  isub=0
5377  loop=0
5378  100 loop=loop+1
5379  mint(51)=0
5380 
5381 C...Choice of process type - first event of pileup.
5382  IF(mint(82).EQ.1.AND.(isub.LE.90.OR.isub.GT.96)) THEN
5383 
5384 C...For gamma-p or gamma-gamma first pick between alternatives.
5385  IF(mint(121).GT.1) CALL pysave(4,iga)
5386  mint(122)=iga
5387 
5388 C...For gamma + gamma with different nature, flip at random.
5389  IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
5390  & pyr(0).GT.0.5d0) THEN
5391  mintsv=mint(41)
5392  mint(41)=mint(42)
5393  mint(42)=mintsv
5394  mintsv=mint(45)
5395  mint(45)=mint(46)
5396  mint(46)=mintsv
5397  mintsv=mint(107)
5398  mint(107)=mint(108)
5399  mint(108)=mintsv
5400  IF(mint(47).EQ.2.OR.mint(47).EQ.3) mint(47)=5-mint(47)
5401  ENDIF
5402 
5403 C...Pick process type.
5404  rsub=xsec(0,1)*pyr(0)
5405  DO 110 i=1,500
5406  IF(msub(i).NE.1) goto 110
5407  isub=i
5408  rsub=rsub-xsec(i,1)
5409  IF(rsub.LE.0d0) goto 120
5410  110 CONTINUE
5411  120 IF(isub.EQ.95) isub=96
5412  IF(isub.EQ.96) CALL pymult(2)
5413 
5414 C...Choice of inclusive process type - pileup events.
5415  ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN
5416  rsub=vint(131)*pyr(0)
5417  isub=96
5418  IF(rsub.GT.sigt(0,0,5)) isub=94
5419  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)) isub=93
5420  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)) isub=92
5421  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)+sigt(0,0,2))
5422  & isub=91
5423  IF(isub.EQ.96) CALL pymult(2)
5424  ENDIF
5425  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+1
5426  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+1
5427  IF(isub.EQ.96.AND.loop.EQ.1.AND.mint(82).EQ.1)
5428  &ngen(97,1)=ngen(97,1)+1
5429  mint(1)=isub
5430  istsb=iset(isub)
5431 
5432 C...Random choice of flavour for some SUSY processes.
5433  IF(isub.GE.201.AND.isub.LE.280) THEN
5434 C...~e_L ~nu_e or ~mu_L ~nu_mu.
5435  IF(isub.EQ.210) THEN
5436  kfpr(isub,1)=ksusy1+11+2*int(0.5d0+pyr(0))
5437  kfpr(isub,2)=kfpr(isub,1)+1
5438 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
5439  ELSEIF(isub.EQ.213) THEN
5440  kfpr(isub,1)=ksusy1+12+2*int(0.5d0+pyr(0))
5441  kfpr(isub,2)=kfpr(isub,1)
5442 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
5443  ELSEIF(isub.GE.246.AND.isub.LE.259) THEN
5444  IF(mod(isub,2).EQ.0) THEN
5445  kfpr(isub,1)=ksusy1+1+int(5d0*pyr(0))
5446  ELSE
5447  kfpr(isub,1)=ksusy2+1+int(5d0*pyr(0))
5448  ENDIF
5449 C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
5450  ELSEIF(isub.GE.271.AND.isub.LE.276) THEN
5451  IF(isub.EQ.271.OR.isub.EQ.274) THEN
5452  ksu1=ksusy1
5453  ksu2=ksusy1
5454  ELSEIF(isub.EQ.272.OR.isub.EQ.275) THEN
5455  ksu1=ksusy2
5456  ksu2=ksusy2
5457  ELSEIF(pyr(0).LT.0.5d0) THEN
5458  ksu1=ksusy1
5459  ksu2=ksusy2
5460  ELSE
5461  ksu1=ksusy2
5462  ksu2=ksusy1
5463  ENDIF
5464  kfpr(isub,1)=ksu1+1+int(5d0*pyr(0))
5465  kfpr(isub,2)=ksu2+1+int(5d0*pyr(0))
5466 C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b.
5467  ELSEIF(isub.EQ.277.OR.isub.EQ.279) THEN
5468  kfpr(isub,1)=ksusy1+1+int(5d0*pyr(0))
5469  kfpr(isub,2)=kfpr(isub,1)
5470  ELSEIF(isub.EQ.278.OR.isub.EQ.280) THEN
5471  kfpr(isub,1)=ksusy2+1+int(5d0*pyr(0))
5472  kfpr(isub,2)=kfpr(isub,1)
5473  ENDIF
5474  ENDIF
5475 
5476 C...Find resonances (explicit or implicit in cross-section).
5477  mint(72)=0
5478  kfr1=0
5479  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
5480  kfr1=kfpr(isub,1)
5481  ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165.OR.
5482  & isub.EQ.171.OR.isub.EQ.176) THEN
5483  kfr1=23
5484  ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172.OR.
5485  & isub.EQ.177) THEN
5486  kfr1=24
5487  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
5488  kfr1=25
5489  IF(mstp(46).EQ.5) THEN
5490  kfr1=30
5491  pmas(30,1)=parp(45)
5492  pmas(30,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
5493  ENDIF
5494  ELSEIF(isub.EQ.194) THEN
5495  kfr1=54
5496  ENDIF
5497  ckmx=ckin(2)
5498  IF(ckmx.LE.0d0) ckmx=vint(1)
5499  kcr1=pycomp(kfr1)
5500  IF(kfr1.NE.0) THEN
5501  IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
5502  & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
5503  ENDIF
5504  IF(kfr1.NE.0) THEN
5505  taur1=pmas(kcr1,1)**2/vint(2)
5506  gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
5507  mint(72)=1
5508  mint(73)=kfr1
5509  vint(73)=taur1
5510  vint(74)=gamr1
5511  ENDIF
5512  IF(isub.EQ.141.OR.isub.EQ.194) THEN
5513  kfr2=23
5514  IF(isub.EQ.194) kfr2=56
5515  kcr2=pycomp(kfr2)
5516  taur2=pmas(kcr2,1)**2/vint(2)
5517  gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
5518  IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
5519  & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) kfr2=0
5520  IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
5521  mint(72)=2
5522  mint(74)=kfr2
5523  vint(75)=taur2
5524  vint(76)=gamr2
5525  ELSEIF(kfr2.NE.0) THEN
5526  kfr1=kfr2
5527  taur1=taur2
5528  gamr1=gamr2
5529  mint(72)=1
5530  mint(73)=kfr1
5531  vint(73)=taur1
5532  vint(74)=gamr1
5533  ENDIF
5534  ENDIF
5535 
5536 C...Find product masses and minimum pT of process,
5537 C...optionally with broadening according to a truncated Breit-Wigner.
5538  vint(63)=0d0
5539  vint(64)=0d0
5540  mint(71)=0
5541  vint(71)=ckin(3)
5542  IF(mint(82).GE.2) vint(71)=0d0
5543  vint(80)=1d0
5544  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
5545  nbw=0
5546  DO 140 i=1,2
5547  pmmn(i)=0d0
5548  IF(kfpr(isub,i).EQ.0) THEN
5549  ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
5550  & parp(41)) THEN
5551  vint(62+i)=pmas(pycomp(kfpr(isub,i)),1)**2
5552  ELSE
5553  nbw=nbw+1
5554 C...This prevents SUSY/t particles from becoming too light.
5555  kflw=kfpr(isub,i)
5556  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
5557  kcw=pycomp(kflw)
5558  pmmn(i)=pmas(kcw,1)
5559  DO 130 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
5560  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
5561  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
5562  & pmas(pycomp(kfdp(idc,2)),1)
5563  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
5564  & pmas(pycomp(kfdp(idc,3)),1)
5565  pmmn(i)=min(pmmn(i),pmsum)
5566  ENDIF
5567  130 CONTINUE
5568  ELSEIF(kflw.EQ.6) THEN
5569  pmmn(i)=pmas(24,1)+pmas(5,1)
5570  ENDIF
5571  ENDIF
5572  140 CONTINUE
5573  IF(nbw.GE.1) THEN
5574  ckin41=ckin(41)
5575  ckin43=ckin(43)
5576  ckin(41)=max(pmmn(1),ckin(41))
5577  ckin(43)=max(pmmn(2),ckin(43))
5578  CALL pyofsh(4,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
5579  ckin(41)=ckin41
5580  ckin(43)=ckin43
5581  IF(mint(51).EQ.1) THEN
5582  IF(mint(121).GT.1) CALL pysave(2,iga)
5583  IF(mfail.EQ.1) THEN
5584  msti(61)=1
5585  RETURN
5586  ENDIF
5587  goto 100
5588  ENDIF
5589  vint(63)=pqm3**2
5590  vint(64)=pqm4**2
5591  ENDIF
5592  IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1
5593  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
5594  ENDIF
5595 
5596 C...Prepare for additional variable choices in 2 -> 3.
5597  IF(istsb.EQ.5) THEN
5598  vint(201)=0d0
5599  IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
5600  vint(206)=vint(201)
5601  vint(204)=pmas(23,1)
5602  IF(isub.EQ.124) vint(204)=pmas(24,1)
5603  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
5604  & isub.EQ.186.OR.isub.EQ.187) vint(204)=vint(201)
5605  vint(209)=vint(204)
5606  ENDIF
5607 
5608 C...Select incoming VDM particle (rho/omega/phi/J/psi).
5609  IF(istsb.NE.0.AND.(mint(101).GE.2.OR.mint(102).GE.2).AND.
5610  &(mint(123).EQ.2.OR.mint(123).EQ.5.OR.mint(123).EQ.7)) THEN
5611  vrn=pyr(0)*sigt(0,0,5)
5612  IF(mint(101).LE.1) THEN
5613  i1mn=0
5614  i1mx=0
5615  ELSE
5616  i1mn=1
5617  i1mx=mint(101)
5618  ENDIF
5619  IF(mint(102).LE.1) THEN
5620  i2mn=0
5621  i2mx=0
5622  ELSE
5623  i2mn=1
5624  i2mx=mint(102)
5625  ENDIF
5626  DO 160 i1=i1mn,i1mx
5627  kfv1=110*i1+3
5628  DO 150 i2=i2mn,i2mx
5629  kfv2=110*i2+3
5630  vrn=vrn-sigt(i1,i2,5)
5631  IF(vrn.LE.0d0) goto 170
5632  150 CONTINUE
5633  160 CONTINUE
5634  170 IF(mint(101).GE.2) mint(103)=kfv1
5635  IF(mint(102).GE.2) mint(104)=kfv2
5636  ENDIF
5637 
5638  IF(istsb.EQ.0) THEN
5639 C...Elastic scattering or single or double diffractive scattering.
5640 
5641 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
5642  mint(103)=mint(11)
5643  mint(104)=mint(12)
5644  pmm(1)=vint(3)
5645  pmm(2)=vint(4)
5646  IF(mint(101).GE.2.OR.mint(102).GE.2) THEN
5647  jj=isub-90
5648  vrn=pyr(0)*sigt(0,0,jj)
5649  IF(mint(101).LE.1) THEN
5650  i1mn=0
5651  i1mx=0
5652  ELSE
5653  i1mn=1
5654  i1mx=mint(101)
5655  ENDIF
5656  IF(mint(102).LE.1) THEN
5657  i2mn=0
5658  i2mx=0
5659  ELSE
5660  i2mn=1
5661  i2mx=mint(102)
5662  ENDIF
5663  DO 190 i1=i1mn,i1mx
5664  kfv1=110*i1+3
5665  DO 180 i2=i2mn,i2mx
5666  kfv2=110*i2+3
5667  vrn=vrn-sigt(i1,i2,jj)
5668  IF(vrn.LE.0d0) goto 200
5669  180 CONTINUE
5670  190 CONTINUE
5671  200 IF(mint(101).GE.2) THEN
5672  mint(103)=kfv1
5673  pmm(1)=pymass(kfv1)
5674  ENDIF
5675  IF(mint(102).GE.2) THEN
5676  mint(104)=kfv2
5677  pmm(2)=pymass(kfv2)
5678  ENDIF
5679  ENDIF
5680 
5681 C...Side/sides of diffractive system.
5682  mint(17)=0
5683  mint(18)=0
5684  IF(isub.EQ.92.OR.isub.EQ.94) mint(17)=1
5685  IF(isub.EQ.93.OR.isub.EQ.94) mint(18)=1
5686 
5687 C...Find masses of particles and minimal masses of diffractive states.
5688  DO 210 jt=1,2
5689  pdif(jt)=pmm(jt)
5690  vint(66+jt)=pdif(jt)
5691  IF(mint(16+jt).EQ.1) pdif(jt)=pdif(jt)+parp(102)
5692  210 CONTINUE
5693  sh=vint(2)
5694  sqm1=pmm(1)**2
5695  sqm2=pmm(2)**2
5696  sqm3=pdif(1)**2
5697  sqm4=pdif(2)**2
5698  smres1=(pmm(1)+pmrc)**2
5699  smres2=(pmm(2)+pmrc)**2
5700 
5701 C...Find elastic slope and lower limit diffractive slope.
5702  iha=max(2,iabs(mint(103))/110)
5703  IF(iha.GE.5) iha=1
5704  ihb=max(2,iabs(mint(104))/110)
5705  IF(ihb.GE.5) ihb=1
5706  IF(isub.EQ.91) THEN
5707  bmn=2d0*bhad(iha)+2d0*bhad(ihb)+4d0*sh**eps-4.2d0
5708  ELSEIF(isub.EQ.92) THEN
5709  bmn=max(2d0,2d0*bhad(ihb))
5710  ELSEIF(isub.EQ.93) THEN
5711  bmn=max(2d0,2d0*bhad(iha))
5712  ELSEIF(isub.EQ.94) THEN
5713  bmn=2d0*alp*4d0
5714  ENDIF
5715 
5716 C...Determine maximum possible t range and coefficient of generation.
5717  sqla12=(sh-sqm1-sqm2)**2-4d0*sqm1*sqm2
5718  sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
5719  tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
5720  thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
5721  thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
5722  & (sqm1*sqm4-sqm2*sqm3)/sh
5723  thl=-0.5d0*(tha+thb)
5724  thu=thc/thl
5725  thrnd=exp(max(-50d0,bmn*(thl-thu)))-1d0
5726 
5727 C...Select diffractive mass/masses according to dm^2/m^2.
5728  220 DO 230 jt=1,2
5729  IF(mint(16+jt).EQ.0) THEN
5730  pdif(2+jt)=pdif(jt)
5731  ELSE
5732  pmmin=pdif(jt)
5733  pmmax=max(vint(2+jt),vint(1)-pdif(3-jt))
5734  pdif(2+jt)=pmmin*(pmmax/pmmin)**pyr(0)
5735  ENDIF
5736  230 CONTINUE
5737  sqm3=pdif(3)**2
5738  sqm4=pdif(4)**2
5739 
5740 C..Additional mass factors, including resonance enhancement.
5741  IF(pdif(3)+pdif(4).GE.vint(1)) goto 220
5742  IF(isub.EQ.92) THEN
5743  fsd=(1d0-sqm3/sh)*(1d0+cres*smres1/(smres1+sqm3))
5744  IF(fsd.LT.pyr(0)*(1d0+cres)) goto 220
5745  ELSEIF(isub.EQ.93) THEN
5746  fsd=(1d0-sqm4/sh)*(1d0+cres*smres2/(smres2+sqm4))
5747  IF(fsd.LT.pyr(0)*(1d0+cres)) goto 220
5748  ELSEIF(isub.EQ.94) THEN
5749  fdd=(1d0-(pdif(3)+pdif(4))**2/sh)*(sh*smp/
5750  & (sh*smp+sqm3*sqm4))*(1d0+cres*smres1/(smres1+sqm3))*
5751  & (1d0+cres*smres2/(smres2+sqm4))
5752  IF(fdd.LT.pyr(0)*(1d0+cres)**2) goto 220
5753  ENDIF
5754 
5755 C...Select t according to exp(Bmn*t) and correct to right slope.
5756  th=thu+log(1d0+thrnd*pyr(0))/bmn
5757  IF(isub.GE.92) THEN
5758  IF(isub.EQ.92) THEN
5759  badd=2d0*alp*log(sh/sqm3)
5760  IF(bhad(ihb).LT.1d0) badd=max(0d0,badd+2d0*bhad(ihb)-2d0)
5761  ELSEIF(isub.EQ.93) THEN
5762  badd=2d0*alp*log(sh/sqm4)
5763  IF(bhad(iha).LT.1d0) badd=max(0d0,badd+2d0*bhad(iha)-2d0)
5764  ELSEIF(isub.EQ.94) THEN
5765  badd=2d0*alp*(log(exp(4d0)+sh/(alp*sqm3*sqm4))-4d0)
5766  ENDIF
5767  IF(exp(max(-50d0,badd*(th-thu))).LT.pyr(0)) goto 220
5768  ENDIF
5769 
5770 C...Check whether m^2 and t choices are consistent.
5771  sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
5772  tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
5773  thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
5774  IF(thb.LE.1d-8) goto 220
5775  thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
5776  & (sqm1*sqm4-sqm2*sqm3)/sh
5777  thlm=-0.5d0*(tha+thb)
5778  thum=thc/thlm
5779  IF(th.LT.thlm.OR.th.GT.thum) goto 220
5780 
5781 C...Information to output.
5782  vint(21)=1d0
5783  vint(22)=0d0
5784  vint(23)=min(1d0,max(-1d0,(tha+2d0*th)/thb))
5785  vint(45)=th
5786  vint(59)=2d0*sqrt(max(0d0,-(thc+tha*th+th**2)))/thb
5787  vint(63)=pdif(3)**2
5788  vint(64)=pdif(4)**2
5789 
5790 C...Note: in the following, by In is meant the integral over the
5791 C...quantity multiplying coefficient cn.
5792 C...Choose tau according to h1(tau)/tau, where
5793 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
5794 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
5795 C...I1/I5*c5*1/(tau+tau_R') +
5796 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
5797 C...I1/I7*c7*tau/(1.-tau), and
5798 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
5799  ELSEIF(istsb.GE.1.AND.istsb.LE.5) THEN
5800  CALL pyklim(1)
5801  IF(mint(51).NE.0) THEN
5802  IF(mint(121).GT.1) CALL pysave(2,iga)
5803  IF(mfail.EQ.1) THEN
5804  msti(61)=1
5805  RETURN
5806  ENDIF
5807  goto 100
5808  ENDIF
5809  rtau=pyr(0)
5810  mtau=1
5811  IF(rtau.GT.coef(isub,1)) mtau=2
5812  IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3
5813  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4
5814  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))
5815  & mtau=5
5816  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
5817  & coef(isub,5)) mtau=6
5818  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
5819  & coef(isub,5)+coef(isub,6)) mtau=7
5820  CALL pykmap(1,mtau,pyr(0))
5821 
5822 C...2 -> 3, 4 processes:
5823 C...Choose tau' according to h4(tau,tau')/tau', where
5824 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
5825 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
5826  IF(istsb.GE.3.AND.istsb.LE.5) THEN
5827  CALL pyklim(4)
5828  IF(mint(51).NE.0) THEN
5829  IF(mint(121).GT.1) CALL pysave(2,iga)
5830  IF(mfail.EQ.1) THEN
5831  msti(61)=1
5832  RETURN
5833  ENDIF
5834  goto 100
5835  ENDIF
5836  rtaup=pyr(0)
5837  mtaup=1
5838  IF(rtaup.GT.coef(isub,18)) mtaup=2
5839  IF(rtaup.GT.coef(isub,18)+coef(isub,19)) mtaup=3
5840  CALL pykmap(4,mtaup,pyr(0))
5841  ENDIF
5842 
5843 C...Choose y* according to h2(y*), where
5844 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
5845 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
5846 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
5847 C...and c1 + c2 + c3 + c4 + c5 = 1.
5848  CALL pyklim(2)
5849  IF(mint(51).NE.0) THEN
5850  IF(mint(121).GT.1) CALL pysave(2,iga)
5851  IF(mfail.EQ.1) THEN
5852  msti(61)=1
5853  RETURN
5854  ENDIF
5855  goto 100
5856  ENDIF
5857  ryst=pyr(0)
5858  myst=1
5859  IF(ryst.GT.coef(isub,8)) myst=2
5860  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
5861  IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)) myst=4
5862  IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)+
5863  & coef(isub,11)) myst=5
5864  CALL pykmap(2,myst,pyr(0))
5865 
5866 C...2 -> 2 processes:
5867 C...Choose cos(theta-hat) (cth) according to h3(cth), where
5868 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
5869 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
5870 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
5871 C...and c0 + c1 + c2 + c3 + c4 = 1.
5872  CALL pyklim(3)
5873  IF(mint(51).NE.0) THEN
5874  IF(mint(121).GT.1) CALL pysave(2,iga)
5875  IF(mfail.EQ.1) THEN
5876  msti(61)=1
5877  RETURN
5878  ENDIF
5879  goto 100
5880  ENDIF
5881  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
5882  rcth=pyr(0)
5883  mcth=1
5884  IF(rcth.GT.coef(isub,13)) mcth=2
5885  IF(rcth.GT.coef(isub,13)+coef(isub,14)) mcth=3
5886  IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)) mcth=4
5887  IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)+
5888  & coef(isub,16)) mcth=5
5889  CALL pykmap(3,mcth,pyr(0))
5890  ENDIF
5891 
5892 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
5893  IF(istsb.EQ.5) THEN
5894  CALL pykmap(5,0,0d0)
5895  IF(mint(51).NE.0) THEN
5896  IF(mint(121).GT.1) CALL pysave(2,iga)
5897  IF(mfail.EQ.1) THEN
5898  msti(61)=1
5899  RETURN
5900  ENDIF
5901  goto 100
5902  ENDIF
5903  ENDIF
5904 
5905 C...Low-pT or multiple interactions (first semihard interaction).
5906  ELSEIF(istsb.EQ.9) THEN
5907  CALL pymult(3)
5908  isub=mint(1)
5909 
5910 C...Generate user-defined process: kinematics plus weight.
5911  ELSEIF(istsb.EQ.11) THEN
5912  msti(51)=0
5913  CALL pyupev(isub,sigs)
5914  IF(nup.LE.0) THEN
5915  mint(51)=2
5916  msti(51)=1
5917  IF(mint(82).EQ.1) THEN
5918  ngen(0,1)=ngen(0,1)-1
5919  ngen(0,2)=ngen(0,2)-1
5920  ngen(isub,1)=ngen(isub,1)-1
5921  ENDIF
5922  IF(mint(121).GT.1) CALL pysave(2,iga)
5923  RETURN
5924  ENDIF
5925 
5926 C...Construct 'trivial' kinematical variables needed.
5927  kfl1=kup(1,2)
5928  kfl2=kup(2,2)
5929  vint(41)=2d0*pup(1,4)/vint(1)
5930  vint(42)=2d0*pup(2,4)/vint(1)
5931  vint(21)=vint(41)*vint(42)
5932  vint(22)=0.5d0*log(vint(41)/vint(42))
5933  vint(44)=vint(21)*vint(2)
5934  vint(43)=sqrt(max(0d0,vint(44)))
5935  vint(56)=q2up(0)
5936  vint(55)=sqrt(max(0d0,vint(56)))
5937 
5938 C...Construct other kinematical variables needed (approximately).
5939  vint(23)=0d0
5940  vint(26)=vint(21)
5941  vint(45)=-0.5d0*vint(44)
5942  vint(46)=-0.5d0*vint(44)
5943  vint(49)=vint(43)
5944  vint(50)=vint(44)
5945  vint(51)=vint(55)
5946  vint(52)=vint(56)
5947  vint(53)=vint(55)
5948  vint(54)=vint(56)
5949  vint(25)=0d0
5950  vint(48)=0d0
5951  DO 240 iup=3,nup
5952  IF(kup(iup,1).EQ.1) vint(25)=vint(25)+2d0*(pup(iup,5)**2+
5953  & pup(iup,1)**2+pup(iup,2)**2)/vint(1)
5954  IF(kup(iup,1).EQ.1) vint(48)=vint(48)+0.5d0*(pup(iup,1)**2+
5955  & pup(iup,2)**2)
5956  240 CONTINUE
5957  vint(47)=sqrt(vint(48))
5958 
5959 C...Calculate parton distribution weights.
5960  IF(mint(47).GE.2) THEN
5961  DO 260 i=3-min(2,mint(45)),min(2,mint(46))
5962  mint(105)=mint(102+i)
5963  mint(109)=mint(106+i)
5964  IF(mstp(57).LE.1) THEN
5965  CALL pypdfu(mint(10+i),vint(40+i),q2up(0),xpq)
5966  ELSE
5967  CALL pypdfl(mint(10+i),vint(40+i),q2up(0),xpq)
5968  ENDIF
5969  DO 250 kfl=-25,25
5970  xsfx(i,kfl)=xpq(kfl)
5971  250 CONTINUE
5972  260 CONTINUE
5973  ENDIF
5974  ENDIF
5975 
5976 C...Choose azimuthal angle.
5977  vint(24)=paru(2)*pyr(0)
5978 
5979 C...Check against user cuts on kinematics at parton level.
5980  mint(51)=0
5981  IF((isub.LE.90.OR.isub.GT.100).AND.istsb.LE.10) CALL pyklim(0)
5982  IF(mint(51).NE.0) THEN
5983  IF(mint(121).GT.1) CALL pysave(2,iga)
5984  IF(mfail.EQ.1) THEN
5985  msti(61)=1
5986  RETURN
5987  ENDIF
5988  goto 100
5989  ENDIF
5990  IF(mint(82).EQ.1.AND.mstp(141).GE.1.AND.istsb.LE.10) THEN
5991  mcut=0
5992  IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)
5993  & CALL pykcut(mcut)
5994  IF(mcut.NE.0) THEN
5995  IF(mint(121).GT.1) CALL pysave(2,iga)
5996  IF(mfail.EQ.1) THEN
5997  msti(61)=1
5998  RETURN
5999  ENDIF
6000  goto 100
6001  ENDIF
6002  ENDIF
6003 
6004 C...Calculate differential cross-section for different subprocesses.
6005  IF(istsb.LE.10) CALL pysigh(nchn,sigs)
6006  sigsor=sigs
6007  siglpt=sigt(0,0,5)
6008 
6009 C...Multiply cross-section by user-defined weights.
6010  IF(mstp(173).EQ.1) THEN
6011  sigs=parp(173)*sigs
6012  DO 270 ichn=1,nchn
6013  sigh(ichn)=parp(173)*sigh(ichn)
6014  270 CONTINUE
6015  siglpt=parp(173)*siglpt
6016  ENDIF
6017  wtxs=1d0
6018  sigswt=sigs
6019  vint(99)=1d0
6020  vint(100)=1d0
6021  IF(mint(82).EQ.1.AND.mstp(142).GE.1) THEN
6022  IF(isub.NE.96.AND.msub(91)+msub(92)+msub(93)+msub(94)+
6023  & msub(95).EQ.0) CALL pyevwt(wtxs)
6024  sigswt=wtxs*sigs
6025  vint(99)=wtxs
6026  IF(mstp(142).EQ.1) vint(100)=1d0/wtxs
6027  ENDIF
6028 
6029 C...Calculations for Monte Carlo estimate of all cross-sections.
6030  IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN
6031  IF(mstp(142).LE.1) THEN
6032  xsec(isub,2)=xsec(isub,2)+sigs
6033  ELSE
6034  xsec(isub,2)=xsec(isub,2)+sigswt
6035  ENDIF
6036  ELSEIF(mint(82).EQ.1) THEN
6037  xsec(isub,2)=xsec(isub,2)+sigs
6038  ENDIF
6039  IF((isub.EQ.95.OR.isub.EQ.96).AND.loop.EQ.1.AND.mint(82).EQ.1)
6040  &xsec(97,2)=xsec(97,2)+siglpt
6041 
6042 C...Multiple interactions: store results of cross-section calculation.
6043  IF(mint(50).EQ.1.AND.mstp(82).GE.3) THEN
6044  vint(153)=sigsor
6045  CALL pymult(4)
6046  ENDIF
6047 
6048 C...Check that weight not negative.
6049  viol=sigswt/xsec(isub,1)
6050  IF(isub.EQ.96.AND.mstp(173).EQ.1) viol=viol/parp(174)
6051  IF(mstp(123).LE.0) THEN
6052  IF(viol.LT.-1d-3) THEN
6053  WRITE(mstu(11),5000) viol,ngen(0,3)+1
6054  IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
6055  & vint(22),vint(23),vint(26)
6056  stop
6057  ENDIF
6058  ELSE
6059  IF(viol.LT.min(-1d-3,vint(109))) THEN
6060  vint(109)=viol
6061  WRITE(mstu(11),5200) viol,ngen(0,3)+1
6062  IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
6063  & vint(22),vint(23),vint(26)
6064  ENDIF
6065  ENDIF
6066 
6067 C...Weighting using estimate of maximum of differential cross-section.
6068  IF(mfail.EQ.0) THEN
6069  IF(viol.LT.pyr(0)) THEN
6070  IF(mint(121).GT.1) CALL pysave(2,iga)
6071  goto 100
6072  ENDIF
6073  ELSEIF(isub.NE.95.AND.isub.NE.96) THEN
6074  IF(viol.LT.pyr(0)) THEN
6075  msti(61)=1
6076  IF(mint(121).GT.1) CALL pysave(2,iga)
6077  RETURN
6078  ENDIF
6079  ELSE
6080  ratnd=siglpt/xsec(95,1)
6081  IF(loop.EQ.1.AND.ratnd.LT.pyr(0)) THEN
6082  msti(61)=1
6083  IF(mint(121).GT.1) CALL pysave(2,iga)
6084  RETURN
6085  ENDIF
6086  viol=viol/ratnd
6087  IF(viol.LT.pyr(0)) THEN
6088  IF(mint(121).GT.1) CALL pysave(2,iga)
6089  goto 100
6090  ENDIF
6091  ENDIF
6092 
6093 C...Check for possible violation of estimated maximum of differential
6094 C...cross-section used in weighting.
6095  IF(mstp(123).LE.0) THEN
6096  IF(viol.GT.1d0) THEN
6097  WRITE(mstu(11),5300) viol,ngen(0,3)+1
6098  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
6099  & vint(22),vint(23),vint(26)
6100  stop
6101  ENDIF
6102  ELSEIF(mstp(123).EQ.1) THEN
6103  IF(viol.GT.vint(108)) THEN
6104  vint(108)=viol
6105  IF(viol.GT.1d0) THEN
6106  mint(10)=1
6107  WRITE(mstu(11),5400) viol,ngen(0,3)+1
6108  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
6109  & vint(22),vint(23),vint(26)
6110  ENDIF
6111  ENDIF
6112  ELSEIF(viol.GT.vint(108)) THEN
6113  vint(108)=viol
6114  IF(viol.GT.1d0) THEN
6115  mint(10)=1
6116  xdif=xsec(isub,1)*(viol-1d0)
6117  xsec(isub,1)=xsec(isub,1)+xdif
6118  IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))
6119  & xsec(0,1)=xsec(0,1)+xdif
6120  WRITE(mstu(11),5400) viol,ngen(0,3)+1
6121  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
6122  & vint(22),vint(23),vint(26)
6123  IF(isub.LE.9) THEN
6124  WRITE(mstu(11),5500) isub,xsec(isub,1)
6125  ELSEIF(isub.LE.99) THEN
6126  WRITE(mstu(11),5600) isub,xsec(isub,1)
6127  ELSE
6128  WRITE(mstu(11),5700) isub,xsec(isub,1)
6129  ENDIF
6130  vint(108)=1d0
6131  ENDIF
6132  ENDIF
6133 
6134 C...Multiple interactions: choose impact parameter.
6135  vint(148)=1d0
6136  IF(mint(50).EQ.1.AND.(isub.LE.90.OR.isub.GE.96).AND.
6137  &mstp(82).GE.3) THEN
6138  CALL pymult(5)
6139  IF(vint(150).LT.pyr(0)) THEN
6140  IF(mint(121).GT.1) CALL pysave(2,iga)
6141  IF(mfail.EQ.1) THEN
6142  msti(61)=1
6143  RETURN
6144  ENDIF
6145  goto 100
6146  ENDIF
6147  ENDIF
6148  IF(mint(82).EQ.1) ngen(0,2)=ngen(0,2)+1
6149  IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN
6150  IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+1
6151  IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1
6152  ENDIF
6153  IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1
6154 
6155 C...Choose flavour of reacting partons (and subprocess).
6156  IF(istsb.GE.11) goto 290
6157  rsigs=sigs*pyr(0)
6158  qt2=vint(48)
6159  rqqbar=parp(87)*(1d0-(qt2/(qt2+(parp(88)*parp(82))**2))**2)
6160  IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.
6161  &pyr(0).GT.rqqbar)) THEN
6162  DO 280 ichn=1,nchn
6163  kfl1=isig(ichn,1)
6164  kfl2=isig(ichn,2)
6165  mint(2)=isig(ichn,3)
6166  rsigs=rsigs-sigh(ichn)
6167  IF(rsigs.LE.0d0) goto 290
6168  280 CONTINUE
6169 
6170 C...Multiple interactions: choose qqbar preferentially at small pT.
6171  ELSEIF(isub.EQ.96) THEN
6172  mint(105)=mint(103)
6173  mint(109)=mint(107)
6174  CALL pyspli(mint(11),21,kfl1,kfldum)
6175  mint(105)=mint(104)
6176  mint(109)=mint(108)
6177  CALL pyspli(mint(12),21,kfl2,kfldum)
6178  mint(1)=11
6179  mint(2)=1
6180  IF(kfl1.EQ.kfl2.AND.pyr(0).LT.0.5d0) mint(2)=2
6181 
6182 C...Low-pT: choose string drawing configuration.
6183  ELSE
6184  kfl1=21
6185  kfl2=21
6186  rsigs=6d0*pyr(0)
6187  mint(2)=1
6188  IF(rsigs.GT.1d0) mint(2)=2
6189  IF(rsigs.GT.2d0) mint(2)=3
6190  ENDIF
6191 
6192 C...Reassign QCD process. Partons before initial state radiation.
6193  290 IF(mint(2).GT.10) THEN
6194  mint(1)=mint(2)/10
6195  mint(2)=mod(mint(2),10)
6196  ENDIF
6197  IF(mint(82).EQ.1.AND.mstp(111).GE.0) ngen(mint(1),2)=
6198  &ngen(mint(1),2)+1
6199  mint(15)=kfl1
6200  mint(16)=kfl2
6201  mint(13)=mint(15)
6202  mint(14)=mint(16)
6203  vint(141)=vint(41)
6204  vint(142)=vint(42)
6205  vint(151)=0d0
6206  vint(152)=0d0
6207 
6208 C...Calculate x value of photon for parton inside photon inside e.
6209  DO 320 jt=1,2
6210  mint(18+jt)=0
6211  vint(154+jt)=0d0
6212  mspli=0
6213  IF(jt.EQ.1.AND.mint(43).LE.2) mspli=1
6214  IF(jt.EQ.2.AND.mod(mint(43),2).EQ.1) mspli=1
6215  IF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) mspli=mspli+1
6216  IF(mspli.EQ.2) THEN
6217  kflh=mint(14+jt)
6218  xhrd=vint(140+jt)
6219  q2hrd=vint(54)
6220  mint(105)=mint(102+jt)
6221  mint(109)=mint(106+jt)
6222  IF(mstp(57).LE.1) THEN
6223  CALL pypdfu(22,xhrd,q2hrd,xpq)
6224  ELSE
6225  CALL pypdfl(22,xhrd,q2hrd,xpq)
6226  ENDIF
6227  wtmx=4d0*xpq(kflh)
6228  IF(mstp(13).EQ.2) THEN
6229  q2pms=q2hrd/pmas(11,1)**2
6230  wtmx=wtmx*log(max(2d0,q2pms*(1d0-xhrd)/xhrd**2))
6231  ENDIF
6232  300 xe=xhrd**pyr(0)
6233  xg=min(0.999999d0,xhrd/xe)
6234  IF(mstp(57).LE.1) THEN
6235  CALL pypdfu(22,xg,q2hrd,xpq)
6236  ELSE
6237  CALL pypdfl(22,xg,q2hrd,xpq)
6238  ENDIF
6239  wt=(1d0+(1d0-xe)**2)*xpq(kflh)
6240  IF(mstp(13).EQ.2) wt=wt*log(max(2d0,q2pms*(1d0-xe)/xe**2))
6241  IF(wt.LT.pyr(0)*wtmx) goto 300
6242  mint(18+jt)=1
6243  vint(154+jt)=xe
6244  DO 310 kfls=-25,25
6245  xsfx(jt,kfls)=xpq(kfls)
6246  310 CONTINUE
6247  ENDIF
6248  320 CONTINUE
6249 
6250 C...Pick scale where photon is resolved.
6251  IF(mint(107).EQ.3) vint(283)=parp(15)**2*
6252  &(vint(54)/parp(15)**2)**pyr(0)
6253  IF(mint(108).EQ.3) vint(284)=parp(15)**2*
6254  &(vint(54)/parp(15)**2)**pyr(0)
6255  IF(mint(121).GT.1) CALL pysave(2,iga)
6256 
6257 C...Format statements for differential cross-section maximum violations.
6258  5000 FORMAT(/1x,'Error: negative cross-section fraction',1p,d11.3,1x,
6259  &'in event',1x,i7,'D0'/1x,'Execution stopped!')
6260  5100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,
6261  &d11.3,', y* =',d11.3,', cthe = ',0p,f11.7,', tau'' =',1p,d11.3)
6262  5200 FORMAT(/1x,'Warning: negative cross-section fraction',1p,d11.3,1x,
6263  &'in event',1x,i7)
6264  5300 FORMAT(/1x,'Error: maximum violated by',1p,d11.3,1x,
6265  &'in event',1x,i7,'D0'/1x,'Execution stopped!')
6266  5400 FORMAT(/1x,'Advisory warning: maximum violated by',1p,d11.3,1x,
6267  &'in event',1x,i7)
6268  5500 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,d11.3)
6269  5600 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,d11.3)
6270  5700 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,d11.3)
6271 
6272  RETURN
6273  END
6274 
6275 C*********************************************************************
6276 
6277 C...PYSCAT
6278 C...Finds outgoing flavours and event type; sets up the kinematics
6279 C...and colour flow of the hard scattering
6280 
6281  SUBROUTINE pyscat
6282 
6283 C...Double precision and integer declarations
6284  IMPLICIT DOUBLE PRECISION(a-h, o-z)
6285  INTEGER pyk,pychge,pycomp
6286 C...Parameter statement to help give large particle numbers.
6287  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
6288 C...Commonblocks
6289  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
6290  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6291  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6292  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
6293  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
6294  common/pypars/mstp(200),parp(200),msti(200),pari(200)
6295  common/pyint1/mint(400),vint(400)
6296  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
6297  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
6298  common/pyint4/mwid(500),wids(500,5)
6299  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
6300  common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
6301  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
6302  &sfmix(16,4)
6303  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
6304  &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyuppr/,/pyssmt/
6305 C...Local arrays and saved variables
6306  dimension wdtp(0:200),wdte(0:200,0:5),pmq(2),z(2),cthe(2),
6307  &phi(2),kuppo(20),vintsv(41:66)
6308  SAVE vintsv
6309 
6310 C...Read out process
6311  isub=mint(1)
6312  isubsv=isub
6313 
6314 C...Restore information for low-pT processes
6315  IF(isub.EQ.95.AND.mint(57).GE.1) THEN
6316  DO 100 j=41,66
6317  100 vint(j)=vintsv(j)
6318  ENDIF
6319 
6320 C...Convert H' or A process into equivalent H one
6321  ihigg=1
6322  kfhigg=25
6323  IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
6324  &isub.LE.190)) THEN
6325  ihigg=2
6326  IF(mod(isub-1,10).GE.5) ihigg=3
6327  kfhigg=33+ihigg
6328  IF(isub.EQ.151.OR.isub.EQ.156) isub=3
6329  IF(isub.EQ.152.OR.isub.EQ.157) isub=102
6330  IF(isub.EQ.153.OR.isub.EQ.158) isub=103
6331  IF(isub.EQ.171.OR.isub.EQ.176) isub=24
6332  IF(isub.EQ.172.OR.isub.EQ.177) isub=26
6333  IF(isub.EQ.173.OR.isub.EQ.178) isub=123
6334  IF(isub.EQ.174.OR.isub.EQ.179) isub=124
6335  IF(isub.EQ.181.OR.isub.EQ.186) isub=121
6336  IF(isub.EQ.182.OR.isub.EQ.187) isub=122
6337  ENDIF
6338 
6339 C...Choice of subprocess, number of documentation lines
6340  idoc=6+iset(isub)
6341  IF(isub.EQ.95) idoc=8
6342  IF(iset(isub).EQ.5) idoc=9
6343  IF(iset(isub).EQ.11) idoc=4+nup
6344  mint(3)=idoc-6
6345  IF(idoc.GE.9.AND.iset(isub).LE.4) idoc=idoc+2
6346  mint(4)=idoc
6347  ipu1=mint(84)+1
6348  ipu2=mint(84)+2
6349  ipu3=mint(84)+3
6350  ipu4=mint(84)+4
6351  ipu5=mint(84)+5
6352  ipu6=mint(84)+6
6353 
6354 C...Reset K, P and V vectors. Store incoming particles
6355  DO 120 jt=1,mstp(126)+20
6356  i=mint(83)+jt
6357  DO 110 j=1,5
6358  k(i,j)=0
6359  p(i,j)=0d0
6360  v(i,j)=0d0
6361  110 CONTINUE
6362  120 CONTINUE
6363  DO 140 jt=1,2
6364  i=mint(83)+jt
6365  k(i,1)=21
6366  k(i,2)=mint(10+jt)
6367  DO 130 j=1,5
6368  p(i,j)=vint(285+5*jt+j)
6369  130 CONTINUE
6370  140 CONTINUE
6371  mint(6)=2
6372  kfres=0
6373 
6374 C...Store incoming partons in their CM-frame
6375  sh=vint(44)
6376  shr=sqrt(sh)
6377  shp=vint(26)*vint(2)
6378  shpr=sqrt(shp)
6379  shuser=shr
6380  IF(iset(isub).GE.3.AND.iset(isub).LE.5) shuser=shpr
6381  DO 150 jt=1,2
6382  i=mint(84)+jt
6383  k(i,1)=14
6384  k(i,2)=mint(14+jt)
6385  k(i,3)=mint(83)+2+jt
6386  p(i,3)=0.5d0*shuser*(-1d0)**(jt-1)
6387  p(i,4)=0.5d0*shuser
6388  150 CONTINUE
6389 
6390 C...Copy incoming partons to documentation lines
6391  DO 170 jt=1,2
6392  i1=mint(83)+4+jt
6393  i2=mint(84)+jt
6394  k(i1,1)=21
6395  k(i1,2)=k(i2,2)
6396  k(i1,3)=i1-2
6397  DO 160 j=1,5
6398  p(i1,j)=p(i2,j)
6399  160 CONTINUE
6400  170 CONTINUE
6401 
6402 C...Choose new quark/lepton flavour for relevant annihilation graphs
6403  IF(isub.EQ.12.OR.isub.EQ.53.OR.isub.EQ.54.OR.isub.EQ.58) THEN
6404  iglga=21
6405  IF(isub.EQ.58) iglga=22
6406  CALL pywidt(iglga,sh,wdtp,wdte)
6407  180 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
6408  DO 190 i=1,mdcy(iglga,3)
6409  kflf=kfdp(i+mdcy(iglga,2)-1,1)
6410  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
6411  IF(rkfl.LE.0d0) goto 200
6412  190 CONTINUE
6413  200 CONTINUE
6414  IF(isub.EQ.12.AND.mstp(5).EQ.1.AND.iabs(mint(15)).LE.2.AND.
6415  & iabs(kflf).GE.3) THEN
6416  facqqb=vint(58)**2*4d0/9d0*(vint(45)**2+vint(46)**2)/
6417  & vint(44)**2
6418  faccib=vint(46)**2/paru(155)**4
6419  IF(facqqb/(facqqb+faccib).LT.pyr(0)) goto 180
6420  ELSEIF(isub.EQ.54) THEN
6421  IF((kchg(pycomp(kflf),1)/2d0)**2.LT.pyr(0)) goto 180
6422  ELSEIF(isub.EQ.58) THEN
6423  IF((kchg(pycomp(kflf),1)/3d0)**2.LT.pyr(0)) goto 180
6424  ENDIF
6425  ENDIF
6426 
6427 C...Final state flavours and colour flow: default values
6428  js=1
6429  mint(21)=mint(15)
6430  mint(22)=mint(16)
6431  mint(23)=0
6432  mint(24)=0
6433  kcc=20
6434  kcs=isign(1,mint(15))
6435 
6436  IF(iset(isub).EQ.11) THEN
6437 C...User-defined processes: find products
6438  irup=0
6439  DO 210 iup=3,nup
6440  IF(kup(iup,1).NE.1) THEN
6441  ELSEIF(irup.LE.5) THEN
6442  irup=irup+1
6443  mint(20+irup)=kup(iup,2)
6444  ENDIF
6445  210 CONTINUE
6446 
6447  ELSEIF(isub.LE.10) THEN
6448  IF(isub.EQ.1) THEN
6449 C...f + fbar -> gamma*/Z0
6450  kfres=23
6451 
6452  ELSEIF(isub.EQ.2) THEN
6453 C...f + fbar' -> W+/-
6454  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
6455  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
6456  kfres=isign(24,kch1+kch2)
6457 
6458  ELSEIF(isub.EQ.3) THEN
6459 C...f + fbar -> h0 (or H0, or A0)
6460  kfres=kfhigg
6461 
6462  ELSEIF(isub.EQ.4) THEN
6463 C...gamma + W+/- -> W+/-
6464 
6465  ELSEIF(isub.EQ.5) THEN
6466 C...Z0 + Z0 -> h0
6467  xh=sh/shp
6468  mint(21)=mint(15)
6469  mint(22)=mint(16)
6470  pmq(1)=pymass(mint(21))
6471  pmq(2)=pymass(mint(22))
6472  220 jt=int(1.5d0+pyr(0))
6473  zmin=2d0*pmq(jt)/shpr
6474  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
6475  & (shpr*(shpr-pmq(3-jt)))
6476  zmax=min(1d0-xh,zmax)
6477  z(jt)=zmin+(zmax-zmin)*pyr(0)
6478  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
6479  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 220
6480  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
6481  IF(sqc1.LT.1.d-8) goto 220
6482  c1=sqrt(sqc1)
6483  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
6484  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
6485  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
6486  z(3-jt)=1d0-xh/(1d0-z(jt))
6487  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
6488  IF(sqc1.LT.1.d-8) goto 220
6489  c1=sqrt(sqc1)
6490  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
6491  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
6492  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
6493  phir=paru(2)*pyr(0)
6494  cphi=cos(phir)
6495  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
6496  & sqrt(1d0-cthe(2)**2)*cphi
6497  z1=2d0-z(jt)
6498  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
6499  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
6500  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
6501  & pmq(3-jt)**2/shp))
6502  zmin=2d0*pmq(3-jt)/shpr
6503  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
6504  zmax=min(1d0-xh,zmax)
6505  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 220
6506  kcc=22
6507  kfres=25
6508 
6509  ELSEIF(isub.EQ.6) THEN
6510 C...Z0 + W+/- -> W+/-
6511 
6512  ELSEIF(isub.EQ.7) THEN
6513 C...W+ + W- -> Z0
6514 
6515  ELSEIF(isub.EQ.8) THEN
6516 C...W+ + W- -> h0
6517  xh=sh/shp
6518  230 DO 260 jt=1,2
6519  i=mint(14+jt)
6520  ia=iabs(i)
6521  IF(ia.LE.10) THEN
6522  rvckm=vint(180+i)*pyr(0)
6523  DO 240 j=1,mstp(1)
6524  ib=2*j-1+mod(ia,2)
6525  ipm=(5-isign(1,i))/2
6526  idc=j+mdcy(ia,2)+2
6527  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 240
6528  mint(20+jt)=isign(ib,i)
6529  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
6530  IF(rvckm.LE.0d0) goto 250
6531  240 CONTINUE
6532  ELSE
6533  ib=2*((ia+1)/2)-1+mod(ia,2)
6534  mint(20+jt)=isign(ib,i)
6535  ENDIF
6536  250 pmq(jt)=pymass(mint(20+jt))
6537  260 CONTINUE
6538  jt=int(1.5d0+pyr(0))
6539  zmin=2d0*pmq(jt)/shpr
6540  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
6541  & (shpr*(shpr-pmq(3-jt)))
6542  zmax=min(1d0-xh,zmax)
6543  IF(zmin.GE.zmax) goto 230
6544  z(jt)=zmin+(zmax-zmin)*pyr(0)
6545  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
6546  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 230
6547  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
6548  IF(sqc1.LT.1.d-8) goto 230
6549  c1=sqrt(sqc1)
6550  c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
6551  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
6552  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
6553  z(3-jt)=1d0-xh/(1d0-z(jt))
6554  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
6555  IF(sqc1.LT.1.d-8) goto 230
6556  c1=sqrt(sqc1)
6557  c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
6558  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
6559  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
6560  phir=paru(2)*pyr(0)
6561  cphi=cos(phir)
6562  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
6563  & sqrt(1d0-cthe(2)**2)*cphi
6564  z1=2d0-z(jt)
6565  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
6566  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
6567  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
6568  & pmq(3-jt)**2/shp))
6569  zmin=2d0*pmq(3-jt)/shpr
6570  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
6571  zmax=min(1d0-xh,zmax)
6572  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 230
6573  kcc=22
6574  kfres=25
6575 
6576  ELSEIF(isub.EQ.10) THEN
6577 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
6578  IF(mint(2).EQ.1) THEN
6579  kcc=22
6580  ELSE
6581 C...W exchange: need to mix flavours according to CKM matrix
6582  DO 280 jt=1,2
6583  i=mint(14+jt)
6584  ia=iabs(i)
6585  IF(ia.LE.10) THEN
6586  rvckm=vint(180+i)*pyr(0)
6587  DO 270 j=1,mstp(1)
6588  ib=2*j-1+mod(ia,2)
6589  ipm=(5-isign(1,i))/2
6590  idc=j+mdcy(ia,2)+2
6591  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 270
6592  mint(20+jt)=isign(ib,i)
6593  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
6594  IF(rvckm.LE.0d0) goto 280
6595  270 CONTINUE
6596  ELSE
6597  ib=2*((ia+1)/2)-1+mod(ia,2)
6598  mint(20+jt)=isign(ib,i)
6599  ENDIF
6600  280 CONTINUE
6601  kcc=22
6602  ENDIF
6603  ENDIF
6604 
6605  ELSEIF(isub.LE.20) THEN
6606  IF(isub.EQ.11) THEN
6607 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
6608  kcc=mint(2)
6609  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
6610 
6611  ELSEIF(isub.EQ.12) THEN
6612 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
6613  mint(21)=isign(kflf,mint(15))
6614  mint(22)=-mint(21)
6615  kcc=4
6616 
6617  ELSEIF(isub.EQ.13) THEN
6618 C...f + fbar -> g + g; th arbitrary
6619  mint(21)=21
6620  mint(22)=21
6621  kcc=mint(2)+4
6622 
6623  ELSEIF(isub.EQ.14) THEN
6624 C...f + fbar -> g + gamma; th arbitrary
6625  IF(pyr(0).GT.0.5d0) js=2
6626  mint(20+js)=21
6627  mint(23-js)=22
6628  kcc=17+js
6629 
6630  ELSEIF(isub.EQ.15) THEN
6631 C...f + fbar -> g + Z0; th arbitrary
6632  IF(pyr(0).GT.0.5d0) js=2
6633  mint(20+js)=21
6634  mint(23-js)=23
6635  kcc=17+js
6636 
6637  ELSEIF(isub.EQ.16) THEN
6638 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6639  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
6640  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
6641  IF(mint(15)*(kch1+kch2).LT.0) js=2
6642  mint(20+js)=21
6643  mint(23-js)=isign(24,kch1+kch2)
6644  kcc=17+js
6645 
6646  ELSEIF(isub.EQ.17) THEN
6647 C...f + fbar -> g + h0; th arbitrary
6648  IF(pyr(0).GT.0.5d0) js=2
6649  mint(20+js)=21
6650  mint(23-js)=25
6651  kcc=17+js
6652 
6653  ELSEIF(isub.EQ.18) THEN
6654 C...f + fbar -> gamma + gamma; th arbitrary
6655  mint(21)=22
6656  mint(22)=22
6657 
6658  ELSEIF(isub.EQ.19) THEN
6659 C...f + fbar -> gamma + Z0; th arbitrary
6660  IF(pyr(0).GT.0.5d0) js=2
6661  mint(20+js)=22
6662  mint(23-js)=23
6663 
6664  ELSEIF(isub.EQ.20) THEN
6665 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
6666 C...(p(fbar')-p(W+))**2
6667  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
6668  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
6669  IF(mint(15)*(kch1+kch2).LT.0) js=2
6670  mint(20+js)=22
6671  mint(23-js)=isign(24,kch1+kch2)
6672  ENDIF
6673 
6674  ELSEIF(isub.LE.30) THEN
6675  IF(isub.EQ.21) THEN
6676 C...f + fbar -> gamma + h0; th arbitrary
6677  IF(pyr(0).GT.0.5d0) js=2
6678  mint(20+js)=22
6679  mint(23-js)=25
6680 
6681  ELSEIF(isub.EQ.22) THEN
6682 C...f + fbar -> Z0 + Z0; th arbitrary
6683  mint(21)=23
6684  mint(22)=23
6685 
6686  ELSEIF(isub.EQ.23) THEN
6687 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6688  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
6689  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
6690  IF(mint(15)*(kch1+kch2).LT.0) js=2
6691  mint(20+js)=23
6692  mint(23-js)=isign(24,kch1+kch2)
6693 
6694  ELSEIF(isub.EQ.24) THEN
6695 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
6696  IF(pyr(0).GT.0.5d0) js=2
6697  mint(20+js)=23
6698  mint(23-js)=kfhigg
6699 
6700  ELSEIF(isub.EQ.25) THEN
6701 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
6702  mint(21)=-isign(24,mint(15))
6703  mint(22)=-mint(21)
6704 
6705  ELSEIF(isub.EQ.26) THEN
6706 C...f + fbar' -> W+/- + h0 (or H0, or A0);
6707 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6708  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
6709  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
6710  IF(mint(15)*(kch1+kch2).GT.0) js=2
6711  mint(20+js)=isign(24,kch1+kch2)
6712  mint(23-js)=kfhigg
6713 
6714  ELSEIF(isub.EQ.27) THEN
6715 C...f + fbar -> h0 + h0
6716 
6717  ELSEIF(isub.EQ.28) THEN
6718 C...f + g -> f + g; th = (p(f)-p(f))**2
6719  kcc=mint(2)+6
6720  IF(mint(15).EQ.21) kcc=kcc+2
6721  IF(mint(15).NE.21) kcs=isign(1,mint(15))
6722  IF(mint(16).NE.21) kcs=isign(1,mint(16))
6723 
6724  ELSEIF(isub.EQ.29) THEN
6725 C...f + g -> f + gamma; th = (p(f)-p(f))**2
6726  IF(mint(15).EQ.21) js=2
6727  mint(23-js)=22
6728  kcc=15+js
6729  kcs=isign(1,mint(14+js))
6730 
6731  ELSEIF(isub.EQ.30) THEN
6732 C...f + g -> f + Z0; th = (p(f)-p(f))**2
6733  IF(mint(15).EQ.21) js=2
6734  mint(23-js)=23
6735  kcc=15+js
6736  kcs=isign(1,mint(14+js))
6737  ENDIF
6738 
6739  ELSEIF(isub.LE.40) THEN
6740  IF(isub.EQ.31) THEN
6741 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
6742  IF(mint(15).EQ.21) js=2
6743  i=mint(14+js)
6744  ia=iabs(i)
6745  mint(23-js)=isign(24,kchg(ia,1)*i)
6746  rvckm=vint(180+i)*pyr(0)
6747  DO 290 j=1,mstp(1)
6748  ib=2*j-1+mod(ia,2)
6749  ipm=(5-isign(1,i))/2
6750  idc=j+mdcy(ia,2)+2
6751  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 290
6752  mint(20+js)=isign(ib,i)
6753  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
6754  IF(rvckm.LE.0d0) goto 300
6755  290 CONTINUE
6756  300 kcc=15+js
6757  kcs=isign(1,mint(14+js))
6758 
6759  ELSEIF(isub.EQ.32) THEN
6760 C...f + g -> f + h0; th = (p(f)-p(f))**2
6761  IF(mint(15).EQ.21) js=2
6762  mint(23-js)=25
6763  kcc=15+js
6764  kcs=isign(1,mint(14+js))
6765 
6766  ELSEIF(isub.EQ.33) THEN
6767 C...f + gamma -> f + g; th=(p(f)-p(f))**2
6768  IF(mint(15).EQ.22) js=2
6769  mint(23-js)=21
6770  kcc=24+js
6771  kcs=isign(1,mint(14+js))
6772 
6773  ELSEIF(isub.EQ.34) THEN
6774 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
6775  IF(mint(15).EQ.22) js=2
6776  kcc=22
6777  kcs=isign(1,mint(14+js))
6778 
6779  ELSEIF(isub.EQ.35) THEN
6780 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
6781  IF(mint(15).EQ.22) js=2
6782  mint(23-js)=23
6783  kcc=22
6784 
6785  ELSEIF(isub.EQ.36) THEN
6786 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
6787  IF(mint(15).EQ.22) js=2
6788  i=mint(14+js)
6789  ia=iabs(i)
6790  mint(23-js)=isign(24,kchg(ia,1)*i)
6791  IF(ia.LE.10) THEN
6792  rvckm=vint(180+i)*pyr(0)
6793  DO 310 j=1,mstp(1)
6794  ib=2*j-1+mod(ia,2)
6795  ipm=(5-isign(1,i))/2
6796  idc=j+mdcy(ia,2)+2
6797  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 310
6798  mint(20+js)=isign(ib,i)
6799  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
6800  IF(rvckm.LE.0d0) goto 320
6801  310 CONTINUE
6802  ELSE
6803  ib=2*((ia+1)/2)-1+mod(ia,2)
6804  mint(20+js)=isign(ib,i)
6805  ENDIF
6806  320 kcc=22
6807 
6808  ELSEIF(isub.EQ.37) THEN
6809 C...f + gamma -> f + h0
6810 
6811  ELSEIF(isub.EQ.38) THEN
6812 C...f + Z0 -> f + g
6813 
6814  ELSEIF(isub.EQ.39) THEN
6815 C...f + Z0 -> f + gamma
6816 
6817  ELSEIF(isub.EQ.40) THEN
6818 C...f + Z0 -> f + Z0
6819  ENDIF
6820 
6821  ELSEIF(isub.LE.50) THEN
6822  IF(isub.EQ.41) THEN
6823 C...f + Z0 -> f' + W+/-
6824 
6825  ELSEIF(isub.EQ.42) THEN
6826 C...f + Z0 -> f + h0
6827 
6828  ELSEIF(isub.EQ.43) THEN
6829 C...f + W+/- -> f' + g
6830 
6831  ELSEIF(isub.EQ.44) THEN
6832 C...f + W+/- -> f' + gamma
6833 
6834  ELSEIF(isub.EQ.45) THEN
6835 C...f + W+/- -> f' + Z0
6836 
6837  ELSEIF(isub.EQ.46) THEN
6838 C...f + W+/- -> f' + W+/-
6839 
6840  ELSEIF(isub.EQ.47) THEN
6841 C...f + W+/- -> f' + h0
6842 
6843  ELSEIF(isub.EQ.48) THEN
6844 C...f + h0 -> f + g
6845 
6846  ELSEIF(isub.EQ.49) THEN
6847 C...f + h0 -> f + gamma
6848 
6849  ELSEIF(isub.EQ.50) THEN
6850 C...f + h0 -> f + Z0
6851  ENDIF
6852 
6853  ELSEIF(isub.LE.60) THEN
6854  IF(isub.EQ.51) THEN
6855 C...f + h0 -> f' + W+/-
6856 
6857  ELSEIF(isub.EQ.52) THEN
6858 C...f + h0 -> f + h0
6859 
6860  ELSEIF(isub.EQ.53) THEN
6861 C...g + g -> f + fbar; th arbitrary
6862  kcs=(-1)**int(1.5d0+pyr(0))
6863  mint(21)=isign(kflf,kcs)
6864  mint(22)=-mint(21)
6865  kcc=mint(2)+10
6866 
6867  ELSEIF(isub.EQ.54) THEN
6868 C...g + gamma -> f + fbar; th arbitrary
6869  kcs=(-1)**int(1.5d0+pyr(0))
6870  mint(21)=isign(kflf,kcs)
6871  mint(22)=-mint(21)
6872  kcc=27
6873  IF(mint(16).EQ.21) kcc=28
6874 
6875  ELSEIF(isub.EQ.55) THEN
6876 C...g + Z0 -> f + fbar
6877 
6878  ELSEIF(isub.EQ.56) THEN
6879 C...g + W+/- -> f + fbar'
6880 
6881  ELSEIF(isub.EQ.57) THEN
6882 C...g + h0 -> f + fbar
6883 
6884  ELSEIF(isub.EQ.58) THEN
6885 C...gamma + gamma -> f + fbar; th arbitrary
6886  kcs=(-1)**int(1.5d0+pyr(0))
6887  mint(21)=isign(kflf,kcs)
6888  mint(22)=-mint(21)
6889  kcc=21
6890 
6891  ELSEIF(isub.EQ.59) THEN
6892 C...gamma + Z0 -> f + fbar
6893 
6894  ELSEIF(isub.EQ.60) THEN
6895 C...gamma + W+/- -> f + fbar'
6896  ENDIF
6897 
6898  ELSEIF(isub.LE.70) THEN
6899  IF(isub.EQ.61) THEN
6900 C...gamma + h0 -> f + fbar
6901 
6902  ELSEIF(isub.EQ.62) THEN
6903 C...Z0 + Z0 -> f + fbar
6904 
6905  ELSEIF(isub.EQ.63) THEN
6906 C...Z0 + W+/- -> f + fbar'
6907 
6908  ELSEIF(isub.EQ.64) THEN
6909 C...Z0 + h0 -> f + fbar
6910 
6911  ELSEIF(isub.EQ.65) THEN
6912 C...W+ + W- -> f + fbar
6913 
6914  ELSEIF(isub.EQ.66) THEN
6915 C...W+/- + h0 -> f + fbar'
6916 
6917  ELSEIF(isub.EQ.67) THEN
6918 C...h0 + h0 -> f + fbar
6919 
6920  ELSEIF(isub.EQ.68) THEN
6921 C...g + g -> g + g; th arbitrary
6922  kcc=mint(2)+12
6923  kcs=(-1)**int(1.5d0+pyr(0))
6924 
6925  ELSEIF(isub.EQ.69) THEN
6926 C...gamma + gamma -> W+ + W-; th arbitrary
6927  mint(21)=24
6928  mint(22)=-24
6929  kcc=21
6930 
6931  ELSEIF(isub.EQ.70) THEN
6932 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
6933  IF(mint(15).EQ.22) mint(21)=23
6934  IF(mint(16).EQ.22) mint(22)=23
6935  kcc=21
6936  ENDIF
6937 
6938  ELSEIF(isub.LE.80) THEN
6939  IF(isub.EQ.71.OR.isub.EQ.72) THEN
6940 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
6941  xh=sh/shp
6942  mint(21)=mint(15)
6943  mint(22)=mint(16)
6944  pmq(1)=pymass(mint(21))
6945  pmq(2)=pymass(mint(22))
6946  330 jt=int(1.5d0+pyr(0))
6947  zmin=2d0*pmq(jt)/shpr
6948  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
6949  & (shpr*(shpr-pmq(3-jt)))
6950  zmax=min(1d0-xh,zmax)
6951  z(jt)=zmin+(zmax-zmin)*pyr(0)
6952  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
6953  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 330
6954  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
6955  IF(sqc1.LT.1.d-8) goto 330
6956  c1=sqrt(sqc1)
6957  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
6958  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
6959  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
6960  z(3-jt)=1d0-xh/(1d0-z(jt))
6961  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
6962  IF(sqc1.LT.1.d-8) goto 330
6963  c1=sqrt(sqc1)
6964  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
6965  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
6966  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
6967  phir=paru(2)*pyr(0)
6968  cphi=cos(phir)
6969  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
6970  & sqrt(1d0-cthe(2)**2)*cphi
6971  z1=2d0-z(jt)
6972  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
6973  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
6974  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
6975  & pmq(3-jt)**2/shp))
6976  zmin=2d0*pmq(3-jt)/shpr
6977  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
6978  zmax=min(1d0-xh,zmax)
6979  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 330
6980  kcc=22
6981 
6982  ELSEIF(isub.EQ.73) THEN
6983 C...Z0 + W+/- -> Z0 + W+/-
6984  js=mint(2)
6985  xh=sh/shp
6986  340 jt=3-mint(2)
6987  i=mint(14+jt)
6988  ia=iabs(i)
6989  IF(ia.LE.10) THEN
6990  rvckm=vint(180+i)*pyr(0)
6991  DO 350 j=1,mstp(1)
6992  ib=2*j-1+mod(ia,2)
6993  ipm=(5-isign(1,i))/2
6994  idc=j+mdcy(ia,2)+2
6995  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 350
6996  mint(20+jt)=isign(ib,i)
6997  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
6998  IF(rvckm.LE.0d0) goto 360
6999  350 CONTINUE
7000  ELSE
7001  ib=2*((ia+1)/2)-1+mod(ia,2)
7002  mint(20+jt)=isign(ib,i)
7003  ENDIF
7004  360 pmq(jt)=pymass(mint(20+jt))
7005  mint(23-jt)=mint(17-jt)
7006  pmq(3-jt)=pymass(mint(23-jt))
7007  jt=int(1.5d0+pyr(0))
7008  zmin=2d0*pmq(jt)/shpr
7009  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
7010  & (shpr*(shpr-pmq(3-jt)))
7011  zmax=min(1d0-xh,zmax)
7012  IF(zmin.GE.zmax) goto 340
7013  z(jt)=zmin+(zmax-zmin)*pyr(0)
7014  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
7015  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 340
7016  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
7017  IF(sqc1.LT.1.d-8) goto 340
7018  c1=sqrt(sqc1)
7019  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
7020  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7021  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
7022  z(3-jt)=1d0-xh/(1d0-z(jt))
7023  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
7024  IF(sqc1.LT.1.d-8) goto 340
7025  c1=sqrt(sqc1)
7026  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
7027  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7028  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
7029  phir=paru(2)*pyr(0)
7030  cphi=cos(phir)
7031  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
7032  & sqrt(1d0-cthe(2)**2)*cphi
7033  z1=2d0-z(jt)
7034  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
7035  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
7036  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
7037  & pmq(3-jt)**2/shp))
7038  zmin=2d0*pmq(3-jt)/shpr
7039  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
7040  zmax=min(1d0-xh,zmax)
7041  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 340
7042  kcc=22
7043 
7044  ELSEIF(isub.EQ.74) THEN
7045 C...Z0 + h0 -> Z0 + h0
7046 
7047  ELSEIF(isub.EQ.75) THEN
7048 C...W+ + W- -> gamma + gamma
7049 
7050  ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
7051 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
7052  xh=sh/shp
7053  370 DO 400 jt=1,2
7054  i=mint(14+jt)
7055  ia=iabs(i)
7056  IF(ia.LE.10) THEN
7057  rvckm=vint(180+i)*pyr(0)
7058  DO 380 j=1,mstp(1)
7059  ib=2*j-1+mod(ia,2)
7060  ipm=(5-isign(1,i))/2
7061  idc=j+mdcy(ia,2)+2
7062  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 380
7063  mint(20+jt)=isign(ib,i)
7064  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
7065  IF(rvckm.LE.0d0) goto 390
7066  380 CONTINUE
7067  ELSE
7068  ib=2*((ia+1)/2)-1+mod(ia,2)
7069  mint(20+jt)=isign(ib,i)
7070  ENDIF
7071  390 pmq(jt)=pymass(mint(20+jt))
7072  400 CONTINUE
7073  jt=int(1.5d0+pyr(0))
7074  zmin=2d0*pmq(jt)/shpr
7075  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
7076  & (shpr*(shpr-pmq(3-jt)))
7077  zmax=min(1d0-xh,zmax)
7078  IF(zmin.GE.zmax) goto 370
7079  z(jt)=zmin+(zmax-zmin)*pyr(0)
7080  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
7081  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 370
7082  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
7083  IF(sqc1.LT.1.d-8) goto 370
7084  c1=sqrt(sqc1)
7085  c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
7086  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7087  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
7088  z(3-jt)=1d0-xh/(1d0-z(jt))
7089  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
7090  IF(sqc1.LT.1.d-8) goto 370
7091  c1=sqrt(sqc1)
7092  c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
7093  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
7094  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
7095  phir=paru(2)*pyr(0)
7096  cphi=cos(phir)
7097  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
7098  & sqrt(1d0-cthe(2)**2)*cphi
7099  z1=2d0-z(jt)
7100  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
7101  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
7102  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
7103  & pmq(3-jt)**2/shp))
7104  zmin=2d0*pmq(3-jt)/shpr
7105  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
7106  zmax=min(1d0-xh,zmax)
7107  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 370
7108  kcc=22
7109 
7110  ELSEIF(isub.EQ.78) THEN
7111 C...W+/- + h0 -> W+/- + h0
7112 
7113  ELSEIF(isub.EQ.79) THEN
7114 C...h0 + h0 -> h0 + h0
7115 
7116  ELSEIF(isub.EQ.80) THEN
7117 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
7118  IF(mint(15).EQ.22) js=2
7119  i=mint(14+js)
7120  ia=iabs(i)
7121  mint(23-js)=isign(211,kchg(ia,1)*i)
7122  ib=3-ia
7123  mint(20+js)=isign(ib,i)
7124  kcc=22
7125  ENDIF
7126 
7127  ELSEIF(isub.LE.90) THEN
7128  IF(isub.EQ.81) THEN
7129 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
7130  mint(21)=isign(mint(55),mint(15))
7131  mint(22)=-mint(21)
7132  kcc=4
7133 
7134  ELSEIF(isub.EQ.82) THEN
7135 C...g + g -> Q + Qbar; th arbitrary
7136  kcs=(-1)**int(1.5d0+pyr(0))
7137  mint(21)=isign(mint(55),kcs)
7138  mint(22)=-mint(21)
7139  kcc=mint(2)+10
7140 
7141  ELSEIF(isub.EQ.83) THEN
7142 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
7143  kfold=mint(16)
7144  IF(mint(2).EQ.2) kfold=mint(15)
7145  kfaold=iabs(kfold)
7146  IF(kfaold.GT.10) THEN
7147  kfanew=kfaold+2*mod(kfaold,2)-1
7148  ELSE
7149  rckm=vint(180+kfold)*pyr(0)
7150  ipm=(5-isign(1,kfold))/2
7151  kfanew=-mod(kfaold+1,2)
7152  410 kfanew=kfanew+2
7153  idc=mdcy(kfaold,2)+(kfanew+1)/2+2
7154  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) THEN
7155  IF(mod(kfaold,2).EQ.0) rckm=rckm-
7156  & vckm(kfaold/2,(kfanew+1)/2)
7157  IF(mod(kfaold,2).EQ.1) rckm=rckm-
7158  & vckm(kfanew/2,(kfaold+1)/2)
7159  ENDIF
7160  IF(kfanew.LE.6.AND.rckm.GT.0d0) goto 410
7161  ENDIF
7162  IF(mint(2).EQ.1) THEN
7163  mint(21)=isign(mint(55),mint(15))
7164  mint(22)=isign(kfanew,mint(16))
7165  ELSE
7166  mint(21)=isign(kfanew,mint(15))
7167  mint(22)=isign(mint(55),mint(16))
7168  js=2
7169  ENDIF
7170  kcc=22
7171 
7172  ELSEIF(isub.EQ.84) THEN
7173 C...g + gamma -> Q + Qbar; th arbitary
7174  kcs=(-1)**int(1.5d0+pyr(0))
7175  mint(21)=isign(mint(55),kcs)
7176  mint(22)=-mint(21)
7177  kcc=27
7178  IF(mint(16).EQ.21) kcc=28
7179 
7180  ELSEIF(isub.EQ.85) THEN
7181 C...gamma + gamma -> F + Fbar; th arbitary
7182  kcs=(-1)**int(1.5d0+pyr(0))
7183  mint(21)=isign(mint(56),kcs)
7184  mint(22)=-mint(21)
7185  kcc=21
7186 
7187  ELSEIF(isub.GE.86.AND.isub.LE.89) THEN
7188 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
7189  mint(21)=kfpr(isub,1)
7190  mint(22)=kfpr(isub,2)
7191  kcc=24
7192  kcs=(-1)**int(1.5d0+pyr(0))
7193  ENDIF
7194 
7195  ELSEIF(isub.LE.100) THEN
7196  IF(isub.EQ.95) THEN
7197 C...Low-pT ( = energyless g + g -> g + g)
7198  kcc=mint(2)+12
7199  kcs=(-1)**int(1.5d0+pyr(0))
7200 
7201  ELSEIF(isub.EQ.96) THEN
7202 C...Multiple interactions (should be reassigned to QCD process)
7203  ENDIF
7204 
7205  ELSEIF(isub.LE.110) THEN
7206  IF(isub.EQ.101) THEN
7207 C...g + g -> gamma*/Z0
7208  kcc=21
7209  kfres=22
7210 
7211  ELSEIF(isub.EQ.102) THEN
7212 C...g + g -> h0 (or H0, or A0)
7213  kcc=21
7214  kfres=kfhigg
7215 
7216  ELSEIF(isub.EQ.103) THEN
7217 C...gamma + gamma -> h0 (or H0, or A0)
7218  kcc=21
7219  kfres=kfhigg
7220 
7221  ELSEIF(isub.EQ.110) THEN
7222 C...f + fbar -> gamma + h0; th arbitrary
7223  IF(pyr(0).GT.0.5d0) js=2
7224  mint(20+js)=22
7225  mint(23-js)=kfhigg
7226  ENDIF
7227 
7228  ELSEIF(isub.LE.120) THEN
7229  IF(isub.EQ.111) THEN
7230 C...f + fbar -> g + h0; th arbitrary
7231  IF(pyr(0).GT.0.5d0) js=2
7232  mint(20+js)=21
7233  mint(23-js)=25
7234  kcc=17+js
7235 
7236  ELSEIF(isub.EQ.112) THEN
7237 C...f + g -> f + h0; th = (p(f) - p(f))**2
7238  IF(mint(15).EQ.21) js=2
7239  mint(23-js)=25
7240  kcc=15+js
7241  kcs=isign(1,mint(14+js))
7242 
7243  ELSEIF(isub.EQ.113) THEN
7244 C...g + g -> g + h0; th arbitrary
7245  IF(pyr(0).GT.0.5d0) js=2
7246  mint(23-js)=25
7247  kcc=22+js
7248  kcs=(-1)**int(1.5d0+pyr(0))
7249 
7250  ELSEIF(isub.EQ.114) THEN
7251 C...g + g -> gamma + gamma; th arbitrary
7252  IF(pyr(0).GT.0.5d0) js=2
7253  mint(21)=22
7254  mint(22)=22
7255  kcc=21
7256 
7257  ELSEIF(isub.EQ.115) THEN
7258 C...g + g -> g + gamma; th arbitrary
7259  IF(pyr(0).GT.0.5d0) js=2
7260  mint(23-js)=22
7261  kcc=22+js
7262  kcs=(-1)**int(1.5d0+pyr(0))
7263 
7264  ELSEIF(isub.EQ.116) THEN
7265 C...g + g -> gamma + Z0
7266 
7267  ELSEIF(isub.EQ.117) THEN
7268 C...g + g -> Z0 + Z0
7269 
7270  ELSEIF(isub.EQ.118) THEN
7271 C...g + g -> W+ + W-
7272  ENDIF
7273 
7274  ELSEIF(isub.LE.140) THEN
7275  IF(isub.EQ.121) THEN
7276 C...g + g -> Q + Qbar + h0
7277  kcs=(-1)**int(1.5d0+pyr(0))
7278  mint(21)=isign(kfpr(isubsv,2),kcs)
7279  mint(22)=-mint(21)
7280  kcc=11+int(0.5d0+pyr(0))
7281  kfres=kfhigg
7282 
7283  ELSEIF(isub.EQ.122) THEN
7284 C...q + qbar -> Q + Qbar + h0
7285  mint(21)=isign(kfpr(isubsv,2),mint(15))
7286  mint(22)=-mint(21)
7287  kcc=4
7288  kfres=kfhigg
7289 
7290  ELSEIF(isub.EQ.123) THEN
7291 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
7292 C...inner process)
7293  kcc=22
7294  kfres=kfhigg
7295 
7296  ELSEIF(isub.EQ.124) THEN
7297 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
7298 C...inner process)
7299  DO 430 jt=1,2
7300  i=mint(14+jt)
7301  ia=iabs(i)
7302  IF(ia.LE.10) THEN
7303  rvckm=vint(180+i)*pyr(0)
7304  DO 420 j=1,mstp(1)
7305  ib=2*j-1+mod(ia,2)
7306  ipm=(5-isign(1,i))/2
7307  idc=j+mdcy(ia,2)+2
7308  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 420
7309  mint(20+jt)=isign(ib,i)
7310  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
7311  IF(rvckm.LE.0d0) goto 430
7312  420 CONTINUE
7313  ELSE
7314  ib=2*((ia+1)/2)-1+mod(ia,2)
7315  mint(20+jt)=isign(ib,i)
7316  ENDIF
7317  430 CONTINUE
7318  kcc=22
7319  kfres=kfhigg
7320 
7321  ELSEIF(isub.EQ.131) THEN
7322 C...g + g -> Z0 + q + qbar
7323  ENDIF
7324 
7325  ELSEIF(isub.LE.160) THEN
7326  IF(isub.EQ.141) THEN
7327 C...f + fbar -> gamma*/Z0/Z'0
7328  kfres=32
7329 
7330  ELSEIF(isub.EQ.142) THEN
7331 C...f + fbar' -> W'+/-
7332  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7333  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7334  kfres=isign(34,kch1+kch2)
7335 
7336  ELSEIF(isub.EQ.143) THEN
7337 C...f + fbar' -> H+/-
7338  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7339  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7340  kfres=isign(37,kch1+kch2)
7341 
7342  ELSEIF(isub.EQ.144) THEN
7343 C...f + fbar' -> R
7344  kfres=isign(40,mint(15)+mint(16))
7345 
7346  ELSEIF(isub.EQ.145) THEN
7347 C...q + l -> LQ (leptoquark)
7348  IF(iabs(mint(16)).LE.8) js=2
7349  kfres=isign(39,mint(14+js))
7350  kcc=28+js
7351  kcs=isign(1,mint(14+js))
7352 
7353  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
7354 C...q + g -> q* (excited quark)
7355  IF(mint(15).EQ.21) js=2
7356  kfres=isign(kfpr(isub,1),mint(14+js))
7357  kcc=30+js
7358  kcs=isign(1,mint(14+js))
7359 
7360  ELSEIF(isub.EQ.149) THEN
7361 C...g + g -> eta_techni
7362  kfres=38
7363  kcc=23
7364  kcs=(-1)**int(1.5d0+pyr(0))
7365  ENDIF
7366 
7367  ELSEIF(isub.LE.200) THEN
7368  IF(isub.EQ.161) THEN
7369 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
7370  IF(mint(15).EQ.21) js=2
7371  i=mint(14+js)
7372  ia=iabs(i)
7373  mint(23-js)=isign(37,kchg(ia,1)*i)
7374  ib=ia+mod(ia,2)-mod(ia+1,2)
7375  mint(20+js)=isign(ib,i)
7376  kcc=15+js
7377  kcs=isign(1,mint(14+js))
7378 
7379  ELSEIF(isub.EQ.162) THEN
7380 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
7381  IF(mint(15).EQ.21) js=2
7382  mint(20+js)=isign(39,mint(14+js))
7383  kflql=kfdp(mdcy(39,2),2)
7384  mint(23-js)=-isign(kflql,mint(14+js))
7385  kcc=15+js
7386  kcs=isign(1,mint(14+js))
7387 
7388  ELSEIF(isub.EQ.163) THEN
7389 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
7390  kcs=(-1)**int(1.5d0+pyr(0))
7391  mint(21)=isign(39,kcs)
7392  mint(22)=-mint(21)
7393  kcc=mint(2)+10
7394 
7395  ELSEIF(isub.EQ.164) THEN
7396 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
7397  mint(21)=isign(39,mint(15))
7398  mint(22)=-mint(21)
7399  kcc=4
7400 
7401  ELSEIF(isub.EQ.165) THEN
7402 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
7403  mint(21)=isign(kfpr(isub,1),mint(15))
7404  mint(22)=-mint(21)
7405 
7406  ELSEIF(isub.EQ.166) THEN
7407 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
7408  IF(mod(mint(15),2).EQ.0) THEN
7409  mint(21)=isign(kfpr(isub,1)+1,mint(15))
7410  mint(22)=isign(kfpr(isub,1),mint(16))
7411  ELSE
7412  mint(21)=isign(kfpr(isub,1),mint(15))
7413  mint(22)=isign(kfpr(isub,1)+1,mint(16))
7414  ENDIF
7415 
7416  ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
7417 C...q + q' -> q" + q* (excited quark)
7418  kfqstr=kfpr(isub,2)
7419  kfqexc=mod(kfqstr,kexcit)
7420  js=mint(2)
7421  mint(20+js)=isign(kfqstr,mint(14+js))
7422  IF(iabs(mint(15)).NE.kfqexc.AND.iabs(mint(16)).NE.kfqexc)
7423  & mint(23-js)=isign(kfqexc,mint(17-js))
7424  kcc=22
7425 
7426  ELSEIF(isub.EQ.191) THEN
7427 C...f + fbar -> rho_tech0.
7428  kfres=54
7429 
7430  ELSEIF(isub.EQ.192) THEN
7431 C...f + fbar' -> rho_tech+/-
7432  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7433  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7434  kfres=isign(55,kch1+kch2)
7435 
7436  ELSEIF(isub.EQ.193) THEN
7437 C...f + fbar -> omega_tech0.
7438  kfres=56
7439 
7440  ELSEIF(isub.EQ.194) THEN
7441 C...f + fbar -> f' + fbar' via mixture of s-channel
7442 C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
7443  mint(21)=isign(kfpr(isub,1),mint(15))
7444  mint(22)=-mint(21)
7445  ENDIF
7446 
7447 CMRENNA++
7448  ELSEIF(isub.LE.215) THEN
7449  IF(isub.EQ.201) THEN
7450 C...f + fbar -> ~e_L + ~e_Lbar
7451  mint(21)=isign(ksusy1+11,kcs)
7452  mint(22)=-mint(21)
7453 
7454  ELSEIF(isub.EQ.202) THEN
7455 C...f + fbar -> ~e_R + ~e_Rbar
7456  mint(21)=isign(ksusy2+11,kcs)
7457  mint(22)=-mint(21)
7458 
7459  ELSEIF(isub.EQ.203) THEN
7460 C...f + fbar -> ~e_R + ~e_Lbar
7461  kcs=1
7462  IF(mint(2).EQ.2) kcs=-1
7463  mint(21)=isign(ksusy1+11,kcs)
7464  mint(22)=-isign(ksusy2+11,kcs)
7465 
7466  ELSEIF(isub.EQ.204) THEN
7467 C...f + fbar -> ~mu_L + ~mu_Lbar
7468  mint(21)=isign(ksusy1+13,kcs)
7469  mint(22)=-mint(21)
7470 
7471  ELSEIF(isub.EQ.205) THEN
7472 C...f + fbar -> ~mu_R + ~mu_Rbar
7473  mint(21)=isign(ksusy2+13,kcs)
7474  mint(22)=-mint(21)
7475 
7476  ELSEIF(isub.EQ.206) THEN
7477 C...f + fbar -> ~mu_L + ~mu_Rbar
7478  kcs=1
7479  IF(mint(2).EQ.2) kcs=-1
7480  mint(21)=isign(ksusy1+13,kcs)
7481  mint(22)=-isign(ksusy2+13,kcs)
7482 
7483  ELSEIF(isub.EQ.207) THEN
7484 C...f + fbar -> ~tau_1 + ~tau_1bar
7485  mint(21)=isign(ksusy1+15,kcs)
7486  mint(22)=-mint(21)
7487 
7488  ELSEIF(isub.EQ.208) THEN
7489 C...f + fbar -> ~tau_2 + ~tau_2bar
7490  mint(21)=isign(ksusy2+15,kcs)
7491  mint(22)=-mint(21)
7492 
7493  ELSEIF(isub.EQ.209) THEN
7494 C...f + fbar -> ~tau_1 + ~tau_2bar
7495  kcs=1
7496  IF(mint(2).EQ.2) kcs=-1
7497  mint(21)=isign(ksusy1+15,kcs)
7498  mint(22)=-isign(ksusy2+15,kcs)
7499 
7500  ELSEIF(isub.EQ.210) THEN
7501 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
7502  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7503  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7504  mint(21)=-isign(kfpr(isub,1),kch1+kch2)
7505  mint(22)=isign(kfpr(isub,2),kch1+kch2)
7506 
7507  ELSEIF(isub.EQ.211) THEN
7508 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
7509  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7510  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7511  mint(21)=-isign(ksusy1+15,kch1+kch2)
7512  mint(22)=isign(ksusy1+16,kch1+kch2)
7513 
7514  ELSEIF(isub.EQ.212) THEN
7515 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
7516  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7517  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7518  mint(21)=-isign(ksusy2+15,kch1+kch2)
7519  mint(22)=isign(ksusy1+16,kch1+kch2)
7520 
7521  ELSEIF(isub.EQ.213) THEN
7522 C...f + fbar -> ~nul + ~nulbar
7523  mint(21)=isign(kfpr(isub,1),kcs)
7524  mint(22)=-mint(21)
7525 
7526  ELSEIF(isub.EQ.214) THEN
7527 C...f + fbar -> ~nutau + ~nutaubar
7528  mint(21)=isign(ksusy1+16,kcs)
7529  mint(22)=-mint(21)
7530  ENDIF
7531 
7532  ELSEIF(isub.LE.225) THEN
7533  IF(isub.EQ.216) THEN
7534 C...f + fbar -> ~chi01 + ~chi01
7535  mint(21)=ksusy1+22
7536  mint(22)=ksusy1+22
7537 
7538  ELSEIF(isub.EQ.217) THEN
7539 C...f + fbar -> ~chi02 + ~chi02
7540  mint(21)=ksusy1+23
7541  mint(22)=ksusy1+23
7542 
7543  ELSEIF(isub.EQ.218 ) THEN
7544 C...f + fbar -> ~chi03 + ~chi03
7545  mint(21)=ksusy1+25
7546  mint(22)=ksusy1+25
7547 
7548  ELSEIF(isub.EQ.219 ) THEN
7549 C...f + fbar -> ~chi04 + ~chi04
7550  mint(21)=ksusy1+35
7551  mint(22)=ksusy1+35
7552 
7553  ELSEIF(isub.EQ.220 ) THEN
7554 C...f + fbar -> ~chi01 + ~chi02
7555  IF(pyr(0).GT.0.5d0) js=2
7556  mint(20+js)=ksusy1+22
7557  mint(23-js)=ksusy1+23
7558 
7559  ELSEIF(isub.EQ.221 ) THEN
7560 C...f + fbar -> ~chi01 + ~chi03
7561  IF(pyr(0).GT.0.5d0) js=2
7562  mint(20+js)=ksusy1+22
7563  mint(23-js)=ksusy1+25
7564 
7565  ELSEIF(isub.EQ.222) THEN
7566 C...f + fbar -> ~chi01 + ~chi04
7567  IF(pyr(0).GT.0.5d0) js=2
7568  mint(20+js)=ksusy1+22
7569  mint(23-js)=ksusy1+35
7570 
7571  ELSEIF(isub.EQ.223) THEN
7572 C...f + fbar -> ~chi02 + ~chi03
7573  IF(pyr(0).GT.0.5d0) js=2
7574  mint(20+js)=ksusy1+23
7575  mint(23-js)=ksusy1+25
7576 
7577  ELSEIF(isub.EQ.224) THEN
7578 C...f + fbar -> ~chi02 + ~chi04
7579  IF(pyr(0).GT.0.5d0) js=2
7580  mint(20+js)=ksusy1+23
7581  mint(23-js)=ksusy1+35
7582 
7583  ELSEIF(isub.EQ.225) THEN
7584 C...f + fbar -> ~chi03 + ~chi04
7585  IF(pyr(0).GT.0.5d0) js=2
7586  mint(20+js)=ksusy1+25
7587  mint(23-js)=ksusy1+35
7588  ENDIF
7589 
7590  ELSEIF(isub.LE.236) THEN
7591  IF(isub.EQ.226) THEN
7592 C...f + fbar -> ~chi+-1 + ~chi-+1
7593 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
7594  mint(21)=isign(ksusy1+24,mint(15))
7595  mint(22)=-mint(21)
7596 
7597  ELSEIF(isub.EQ.227) THEN
7598 C...f + fbar -> ~chi+-2 + ~chi-+2
7599  mint(21)=isign(ksusy1+37,mint(15))
7600  mint(22)=-mint(21)
7601 
7602  ELSEIF(isub.EQ.228) THEN
7603 C...f + fbar -> ~chi+-1 + ~chi-+2
7604 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
7605 C...js=1 if pyr<.5, js=2 if pyr>.5
7606 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
7607 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
7608 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
7609 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
7610  kch1=isign(1,mint(15))
7611  kch2=int(1-kch1)/2
7612  IF(mint(2).EQ.1) THEN
7613  mint(22-kch2)= -(ksusy1+24)
7614  mint(21+kch2)= ksusy1+37
7615  IF(kch2.EQ.0) js=2
7616  ELSE
7617  mint(21+kch2)= ksusy1+24
7618  mint(22-kch2)= -(ksusy1+37)
7619  IF(kch2.EQ.1) js=2
7620  ENDIF
7621 
7622  ELSEIF(isub.EQ.229) THEN
7623 C...q + qbar' -> ~chi01 + ~chi+-1
7624 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
7625  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7626  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7627 C...CHECK THIS
7628  IF(mod(mint(15),2).NE.0) js=2
7629  mint(20+js)=ksusy1+22
7630  mint(23-js)=isign(ksusy1+24,kch1+kch2)
7631 
7632  ELSEIF(isub.EQ.230) THEN
7633 C...q + qbar' -> ~chi02 + ~chi+-1
7634  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7635  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7636  IF(mod(mint(15),2).NE.0) js=2
7637  mint(20+js)=ksusy1+23
7638  mint(23-js)=isign(ksusy1+24,kch1+kch2)
7639 
7640  ELSEIF(isub.EQ.231) THEN
7641 C...q + qbar' -> ~chi03 + ~chi+-1
7642  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7643  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7644  IF(mod(mint(15),2).NE.0) js=2
7645  mint(20+js)=ksusy1+25
7646  mint(23-js)=isign(ksusy1+24,kch1+kch2)
7647 
7648  ELSEIF(isub.EQ.232) THEN
7649 C...q + qbar' -> ~chi04 + ~chi+-1
7650  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7651  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7652  IF(mod(mint(15),2).NE.0) js=2
7653  mint(20+js)=ksusy1+35
7654  mint(23-js)=isign(ksusy1+24,kch1+kch2)
7655 
7656  ELSEIF(isub.EQ.233) THEN
7657 C...q + qbar' -> ~chi01 + ~chi+-2
7658  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7659  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7660  IF(mod(mint(15),2).NE.0) js=2
7661  mint(20+js)=ksusy1+22
7662  mint(23-js)=isign(ksusy1+37,kch1+kch2)
7663 
7664  ELSEIF(isub.EQ.234) THEN
7665 C...q + qbar' -> ~chi02 + ~chi+-2
7666  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7667  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7668  IF(mod(mint(15),2).NE.0) js=2
7669  mint(20+js)=ksusy1+23
7670  mint(23-js)=isign(ksusy1+37,kch1+kch2)
7671 
7672  ELSEIF(isub.EQ.235) THEN
7673 C...q + qbar' -> ~chi03 + ~chi+-2
7674  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7675  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7676  IF(mod(mint(15),2).NE.0) js=2
7677  mint(20+js)=ksusy1+25
7678  mint(23-js)=isign(ksusy1+37,kch1+kch2)
7679 
7680  ELSEIF(isub.EQ.236) THEN
7681 C...q + qbar' -> ~chi04 + ~chi+-2
7682  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7683  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7684  IF(mod(mint(15),2).NE.0) js=2
7685  mint(20+js)=ksusy1+35
7686  mint(23-js)=isign(ksusy1+37,kch1+kch2)
7687  ENDIF
7688 
7689  ELSEIF(isub.LE.245) THEN
7690  IF(isub.EQ.237) THEN
7691 C...q + qbar -> ~chi01 + ~g
7692 C...th arbitrary
7693  IF(pyr(0).GT.0.5d0) js=2
7694  mint(20+js)=ksusy1+21
7695  mint(23-js)=ksusy1+22
7696  kcc=17+js
7697 
7698  ELSEIF(isub.EQ.238) THEN
7699 C...q + qbar -> ~chi02 + ~g
7700 C...th arbitrary
7701  IF(pyr(0).GT.0.5d0) js=2
7702  mint(20+js)=ksusy1+21
7703  mint(23-js)=ksusy1+23
7704  kcc=17+js
7705 
7706  ELSEIF(isub.EQ.239) THEN
7707 C...q + qbar -> ~chi03 + ~g
7708 C...th arbitrary
7709  IF(pyr(0).GT.0.5d0) js=2
7710  mint(20+js)=ksusy1+21
7711  mint(23-js)=ksusy1+25
7712  kcc=17+js
7713 
7714  ELSEIF(isub.EQ.240) THEN
7715 C...q + qbar -> ~chi04 + ~g
7716 C...th arbitrary
7717  IF(pyr(0).GT.0.5d0) js=2
7718  mint(20+js)=ksusy1+21
7719  mint(23-js)=ksusy1+35
7720  kcc=17+js
7721 
7722  ELSEIF(isub.EQ.241) THEN
7723 C...q + qbar' -> ~chi+-1 + ~g
7724 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7725 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7726 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7727 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7728 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7729  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7730  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7731  js=1
7732  IF(mint(15)*(kch1+kch2).GT.0) js=2
7733  mint(20+js)=ksusy1+21
7734  mint(23-js)=isign(ksusy1+24,kch1+kch2)
7735  kcc=17+js
7736 
7737  ELSEIF(isub.EQ.242) THEN
7738 C...q + qbar' -> ~chi+-2 + ~g
7739 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7740 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7741 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7742 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7743 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7744  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
7745  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
7746  js=1
7747  IF(mint(15)*(kch1+kch2).GT.0) js=2
7748  mint(20+js)=ksusy1+21
7749  mint(23-js)=isign(ksusy1+37,kch1+kch2)
7750  kcc=17+js
7751 
7752  ELSEIF(isub.EQ.243) THEN
7753 C...q + qbar -> ~g + ~g ; th arbitrary
7754  mint(21)=ksusy1+21
7755  mint(22)=ksusy1+21
7756  kcc=mint(2)+4
7757 
7758  ELSEIF(isub.EQ.244) THEN
7759 C...g + g -> ~g + ~g ; th arbitrary
7760  kcc=mint(2)+12
7761  kcs=(-1)**int(1.5d0+pyr(0))
7762  mint(21)=ksusy1+21
7763  mint(22)=ksusy1+21
7764  ENDIF
7765 
7766  ELSEIF(isub.LE.260) THEN
7767  IF(isub.EQ.246) THEN
7768 C...qj + g -> ~qj_L + ~chi01
7769  IF(mint(15).EQ.21) js=2
7770  i=mint(14+js)
7771  ia=iabs(i)
7772  mint(20+js)=isign(ksusy1+ia,i)
7773  mint(23-js)=ksusy1+22
7774  kcc=15+js
7775  kcs=isign(1,mint(14+js))
7776 
7777  ELSEIF(isub.EQ.247) THEN
7778 C...qj + g -> ~qj_R + ~chi01
7779  IF(mint(15).EQ.21) js=2
7780  i=mint(14+js)
7781  ia=iabs(i)
7782  mint(20+js)=isign(ksusy2+ia,i)
7783  mint(23-js)=ksusy1+22
7784  kcc=15+js
7785  kcs=isign(1,mint(14+js))
7786 
7787  ELSEIF(isub.EQ.248) THEN
7788 C...qj + g -> ~qj_L + ~chi02
7789  IF(mint(15).EQ.21) js=2
7790  i=mint(14+js)
7791  ia=iabs(i)
7792  mint(20+js)=isign(ksusy1+ia,i)
7793  mint(23-js)=ksusy1+23
7794  kcc=15+js
7795  kcs=isign(1,mint(14+js))
7796 
7797  ELSEIF(isub.EQ.249) THEN
7798 C...qj + g -> ~qj_R + ~chi02
7799  IF(mint(15).EQ.21) js=2
7800  i=mint(14+js)
7801  ia=iabs(i)
7802  mint(20+js)=isign(ksusy2+ia,i)
7803  mint(23-js)=ksusy1+23
7804  kcc=15+js
7805  kcs=isign(1,mint(14+js))
7806 
7807  ELSEIF(isub.EQ.250) THEN
7808 C...qj + g -> ~qj_L + ~chi03
7809  IF(mint(15).EQ.21) js=2
7810  i=mint(14+js)
7811  ia=iabs(i)
7812  mint(20+js)=isign(ksusy1+ia,i)
7813  mint(23-js)=ksusy1+25
7814  kcc=15+js
7815  kcs=isign(1,mint(14+js))
7816 
7817  ELSEIF(isub.EQ.251) THEN
7818 C...qj + g -> ~qj_R + ~chi03
7819  IF(mint(15).EQ.21) js=2
7820  i=mint(14+js)
7821  ia=iabs(i)
7822  mint(20+js)=isign(ksusy2+ia,i)
7823  mint(23-js)=ksusy1+25
7824  kcc=15+js
7825  kcs=isign(1,mint(14+js))
7826 
7827  ELSEIF(isub.EQ.252) THEN
7828 C...qj + g -> ~qj_L + ~chi04
7829  IF(mint(15).EQ.21) js=2
7830  i=mint(14+js)
7831  ia=iabs(i)
7832  mint(20+js)=isign(ksusy1+ia,i)
7833  mint(23-js)=ksusy1+35
7834  kcc=15+js
7835  kcs=isign(1,mint(14+js))
7836 
7837  ELSEIF(isub.EQ.253) THEN
7838 C...qj + g -> ~qj_R + ~chi04
7839  IF(mint(15).EQ.21) js=2
7840  i=mint(14+js)
7841  ia=iabs(i)
7842  mint(20+js)=isign(ksusy2+ia,i)
7843  mint(23-js)=ksusy1+35
7844  kcc=15+js
7845  kcs=isign(1,mint(14+js))
7846 
7847  ELSEIF(isub.EQ.254) THEN
7848 C...qj + g -> ~qk_L + ~chi+-1
7849  IF(mint(15).EQ.21) js=2
7850  i=mint(14+js)
7851  ia=iabs(i)
7852  mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
7853  ib=-ia+int((ia+1)/2)*4-1
7854  mint(20+js)=isign(ksusy1+ib,i)
7855  kcc=15+js
7856  kcs=isign(1,mint(14+js))
7857 
7858  ELSEIF(isub.EQ.255) THEN
7859 C...qj + g -> ~qk_L + ~chi+-1
7860  IF(mint(15).EQ.21) js=2
7861  i=mint(14+js)
7862  ia=iabs(i)
7863  mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
7864  ib=-ia+int((ia+1)/2)*4-1
7865  mint(20+js)=isign(ksusy2+ib,i)
7866  kcc=15+js
7867  kcs=isign(1,mint(14+js))
7868 
7869  ELSEIF(isub.EQ.256) THEN
7870 C...qj + g -> ~qk_L + ~chi+-2
7871  IF(mint(15).EQ.21) js=2
7872  i=mint(14+js)
7873  ia=iabs(i)
7874  ib=-ia+int((ia+1)/2)*4-1
7875  mint(20+js)=isign(ksusy1+ib,i)
7876  mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
7877  kcc=15+js
7878  kcs=isign(1,mint(14+js))
7879 
7880  ELSEIF(isub.EQ.257) THEN
7881 C...qj + g -> ~qk_R + ~chi+-2
7882  IF(mint(15).EQ.21) js=2
7883  i=mint(14+js)
7884  ia=iabs(i)
7885  ib=-ia+int((ia+1)/2)*4-1
7886  mint(20+js)=isign(ksusy2+ib,i)
7887  mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
7888  kcc=15+js
7889  kcs=isign(1,mint(14+js))
7890 
7891  ELSEIF(isub.EQ.258) THEN
7892 C...qj + g -> ~qj_L + ~g
7893  IF(mint(15).EQ.21) js=2
7894  i=mint(14+js)
7895  ia=iabs(i)
7896  mint(20+js)=isign(ksusy1+ia,i)
7897  mint(23-js)=ksusy1+21
7898  kcc=mint(2)+6
7899  IF(js.EQ.2) kcc=kcc+2
7900  kcs=isign(1,i)
7901 
7902  ELSEIF(isub.EQ.259) THEN
7903 C...qj + g -> ~qj_R + ~g
7904  IF(mint(15).EQ.21) js=2
7905  i=mint(14+js)
7906  ia=iabs(i)
7907  mint(20+js)=isign(ksusy2+ia,i)
7908  mint(23-js)=ksusy1+21
7909  kcc=mint(2)+6
7910  IF(js.EQ.2) kcc=kcc+2
7911  kcs=isign(1,i)
7912  ENDIF
7913 
7914  ELSEIF(isub.LE.270) THEN
7915  IF(isub.EQ.261) THEN
7916 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
7917  mint(21)=isign(kfpr(isub,1),kcs)
7918  mint(22)=-mint(21)
7919 C...Correct color combination
7920  IF(mint(43).EQ.4) kcc=4
7921 
7922  ELSEIF(isub.EQ.262) THEN
7923 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
7924  mint(21)=isign(kfpr(isub,1),kcs)
7925  mint(22)=-mint(21)
7926 C...Correct color combination
7927  IF(mint(43).EQ.4) kcc=4
7928 
7929  ELSEIF(isub.EQ.263) THEN
7930 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
7931  IF((kcs.GT.0.AND.mint(2).EQ.1).OR.
7932  & (kcs.LT.0.AND.mint(2).EQ.2)) THEN
7933  mint(21)=isign(kfpr(isub,1),kcs)
7934  mint(22)=-isign(kfpr(isub,2),kcs)
7935  ELSE
7936  js=2
7937  mint(21)=isign(kfpr(isub,2),kcs)
7938  mint(22)=-isign(kfpr(isub,1),kcs)
7939  ENDIF
7940 C...Correct color combination
7941  IF(mint(43).EQ.4) kcc=4
7942 
7943  ELSEIF(isub.EQ.264) THEN
7944 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
7945  kcs=(-1)**int(1.5d0+pyr(0))
7946  mint(21)=isign(kfpr(isub,1),kcs)
7947  mint(22)=-mint(21)
7948  kcc=mint(2)+10
7949 
7950  ELSEIF(isub.EQ.265) THEN
7951 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
7952  kcs=(-1)**int(1.5d0+pyr(0))
7953  mint(21)=isign(kfpr(isub,1),kcs)
7954  mint(22)=-mint(21)
7955  kcc=mint(2)+10
7956  ENDIF
7957 
7958  ELSEIF(isub.LE.280) THEN
7959  IF(isub.EQ.271) THEN
7960 C...qi + qj -> ~qi_L + ~qj_L
7961  kcc=mint(2)
7962  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
7963  mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
7964  mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
7965 
7966  ELSEIF(isub.EQ.272) THEN
7967 C...qi + qj -> ~qi_R + ~qj_R
7968  kcc=mint(2)
7969  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
7970  mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
7971  mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
7972 
7973  ELSEIF(isub.EQ.273) THEN
7974 C...qi + qj -> ~qi_L + ~qj_R
7975  mint(21)=isign(kfpr(isub,1),mint(15))
7976  mint(22)=isign(kfpr(isub,2),mint(16))
7977  kcc=mint(2)
7978  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
7979 
7980  ELSEIF(isub.EQ.274) THEN
7981 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
7982  mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
7983  mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
7984  kcc=mint(2)
7985  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
7986 
7987  ELSEIF(isub.EQ.275) THEN
7988 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
7989  mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
7990  mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
7991  kcc=mint(2)
7992  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
7993 
7994  ELSEIF(isub.EQ.276) THEN
7995 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
7996  mint(21)=isign(kfpr(isub,1),mint(15))
7997  mint(22)=isign(kfpr(isub,2),mint(16))
7998  kcc=mint(2)
7999  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
8000 
8001  ELSEIF(isub.EQ.277) THEN
8002 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
8003  isgn=1
8004  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
8005  mint(21)=isgn*isign(kfpr(isub,1),kcs)
8006  mint(22)=-mint(21)
8007  IF(mint(43).EQ.4) kcc=4
8008 
8009  ELSEIF(isub.EQ.278) THEN
8010 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
8011  isgn=1
8012  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
8013  mint(21)=isgn*isign(kfpr(isub,1),kcs)
8014  mint(22)=-mint(21)
8015  IF(mint(43).EQ.4) kcc=4
8016 
8017  ELSEIF(isub.EQ.279) THEN
8018 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
8019 C...pure LL + RR
8020  kcs=(-1)**int(1.5d0+pyr(0))
8021  mint(21)=isign(kfpr(isub,1),kcs)
8022  mint(22)=-mint(21)
8023  kcc=mint(2)+10
8024 
8025  ELSEIF(isub.EQ.280) THEN
8026 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
8027  kcs=(-1)**int(1.5d0+pyr(0))
8028  mint(21)=isign(kfpr(isub,1),kcs)
8029  mint(22)=-mint(21)
8030  kcc=mint(2)+10
8031  ENDIF
8032 
8033 CMRENNA--
8034  ENDIF
8035 
8036  IF(iset(isub).EQ.11) THEN
8037 C...Store documentation for user-defined processes
8038  bezup=(pup(1,4)-pup(2,4))/(pup(1,4)+pup(2,4))
8039  kuppo(1)=mint(83)+5
8040  kuppo(2)=mint(83)+6
8041  i=mint(83)+6
8042  DO 450 iup=3,nup
8043  kuppo(iup)=0
8044  IF(mstp(128).GE.2.AND.kup(iup,3).NE.0) THEN
8045  idoc=idoc-1
8046  mint(4)=mint(4)-1
8047  goto 450
8048  ENDIF
8049  i=i+1
8050  kuppo(iup)=i
8051  k(i,1)=21
8052  k(i,2)=kup(iup,2)
8053  k(i,3)=0
8054  IF(kup(iup,3).NE.0) k(i,3)=kuppo(kup(iup,3))
8055  k(i,4)=0
8056  k(i,5)=0
8057  DO 440 j=1,5
8058  p(i,j)=pup(iup,j)
8059  440 CONTINUE
8060  450 CONTINUE
8061  CALL pyrobo(mint(83)+7,mint(83)+4+nup,0d0,vint(24),0d0,0d0,
8062  & -bezup)
8063 
8064 C...Store final state partons for user-defined processes
8065  n=ipu2
8066  DO 470 iup=3,nup
8067  n=n+1
8068  k(n,1)=1
8069  IF(kup(iup,1).NE.1) k(n,1)=11
8070  k(n,2)=kup(iup,2)
8071  IF(mstp(128).LE.0.OR.kup(iup,3).EQ.0) THEN
8072  k(n,3)=kuppo(iup)
8073  ELSE
8074  k(n,3)=mint(84)+kup(iup,3)
8075  ENDIF
8076  k(n,4)=0
8077  k(n,5)=0
8078  DO 460 j=1,5
8079  p(n,j)=pup(iup,j)
8080  460 CONTINUE
8081  470 CONTINUE
8082  CALL pyrobo(ipu3,n,0d0,vint(24),0d0,0d0,-bezup)
8083 
8084 C...Arrange colour flow for user-defined processes
8085  n=mint(84)
8086  DO 480 iup=1,nup
8087  n=n+1
8088  IF(kchg(pycomp(k(n,2)),2).EQ.0) goto 480
8089  IF(k(n,1).EQ.1) k(n,1)=3
8090  IF(k(n,1).EQ.11) k(n,1)=14
8091  IF(kup(iup,4).NE.0) k(n,4)=k(n,4)+mstu(5)*(kup(iup,4)+
8092  & mint(84))
8093  IF(kup(iup,5).NE.0) k(n,5)=k(n,5)+mstu(5)*(kup(iup,5)+
8094  & mint(84))
8095  IF(kup(iup,6).NE.0) k(n,4)=k(n,4)+kup(iup,6)+mint(84)
8096  IF(kup(iup,7).NE.0) k(n,5)=k(n,5)+kup(iup,7)+mint(84)
8097  480 CONTINUE
8098 
8099  ELSEIF(idoc.EQ.7) THEN
8100 C...Resonance not decaying; store kinematics
8101  i=mint(83)+7
8102  k(ipu3,1)=1
8103  k(ipu3,2)=kfres
8104  k(ipu3,3)=i
8105  p(ipu3,4)=shuser
8106  p(ipu3,5)=shuser
8107  k(i,1)=21
8108  k(i,2)=kfres
8109  p(i,4)=shuser
8110  p(i,5)=shuser
8111  n=ipu3
8112  mint(21)=kfres
8113  mint(22)=0
8114 
8115 C...Special cases: colour flow in coloured resonances
8116  kcres=pycomp(kfres)
8117  IF(kchg(kcres,2).NE.0) THEN
8118  k(ipu3,1)=3
8119  DO 490 j=1,2
8120  jc=j
8121  IF(kcs.EQ.-1) jc=3-j
8122  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
8123  & mint(84)+icol(kcc,1,jc)
8124  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
8125  & mint(84)+icol(kcc,2,jc)
8126  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
8127  & mstu(5)*(mint(84)+icol(kcc,3,jc))
8128  490 CONTINUE
8129  ELSE
8130  k(ipu1,4)=ipu2
8131  k(ipu1,5)=ipu2
8132  k(ipu2,4)=ipu1
8133  k(ipu2,5)=ipu1
8134  ENDIF
8135 
8136  ELSEIF(idoc.EQ.8) THEN
8137 C...2 -> 2 processes: store outgoing partons in their CM-frame
8138  DO 500 jt=1,2
8139  i=mint(84)+2+jt
8140  kca=pycomp(mint(20+jt))
8141  k(i,1)=1
8142  IF(kchg(kca,2).NE.0) k(i,1)=3
8143  k(i,2)=mint(20+jt)
8144  k(i,3)=mint(83)+idoc+jt-2
8145  kfaa=iabs(k(i,2))
8146  IF(mwid(kca).NE.0.AND.kfpr(isubsv,1).NE.0) THEN
8147  p(i,5)=sqrt(vint(63+mod(js+jt,2)))
8148  ELSEIF(mwid(kca).NE.0.AND.kfpr(isubsv,2).NE.0) THEN
8149  p(i,5)=sqrt(vint(64))
8150  ELSE
8151  p(i,5)=pymass(k(i,2))
8152  ENDIF
8153  IF((kfaa.EQ.6.OR.kfaa.EQ.7.OR.kfaa.EQ.8).AND.
8154  & p(i,5).LT.parp(42)) p(i,5)=pymass(k(i,2))
8155  500 CONTINUE
8156  IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN
8157  kfa1=iabs(mint(21))
8158  kfa2=iabs(mint(22))
8159  IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))
8160  & THEN
8161  mint(51)=1
8162  RETURN
8163  ENDIF
8164  p(ipu3,5)=0d0
8165  p(ipu4,5)=0d0
8166  ENDIF
8167  p(ipu3,4)=0.5d0*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)
8168  p(ipu3,3)=sqrt(max(0d0,p(ipu3,4)**2-p(ipu3,5)**2))
8169  p(ipu4,4)=shr-p(ipu3,4)
8170  p(ipu4,3)=-p(ipu3,3)
8171  n=ipu4
8172  mint(7)=mint(83)+7
8173  mint(8)=mint(83)+8
8174 
8175 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
8176  CALL pyrobo(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)
8177 
8178  ELSEIF(idoc.EQ.9) THEN
8179 C...2 -> 3 processes: store outgoing partons in their CM frame
8180  DO 510 jt=1,2
8181  i=mint(84)+2+jt
8182  kca=pycomp(mint(20+jt))
8183  k(i,1)=1
8184  IF(kchg(kca,2).NE.0) k(i,1)=3
8185  k(i,2)=mint(20+jt)
8186  k(i,3)=mint(83)+idoc+jt-3
8187  IF(iabs(k(i,2)).LE.22) THEN
8188  p(i,5)=pymass(k(i,2))
8189  ELSE
8190  p(i,5)=sqrt(vint(63+mod(js+jt,2)))
8191  ENDIF
8192  pt=sqrt(max(0d0,vint(197+5*jt)-p(i,5)**2+vint(196+5*jt)**2))
8193  p(i,1)=pt*cos(vint(198+5*jt))
8194  p(i,2)=pt*sin(vint(198+5*jt))
8195  510 CONTINUE
8196  k(ipu5,1)=1
8197  k(ipu5,2)=kfres
8198  k(ipu5,3)=mint(83)+idoc
8199  p(ipu5,5)=shr
8200  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
8201  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
8202  pms1=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
8203  pms2=p(ipu4,5)**2+p(ipu4,1)**2+p(ipu4,2)**2
8204  pms3=p(ipu5,5)**2+p(ipu5,1)**2+p(ipu5,2)**2
8205  pmt3=sqrt(pms3)
8206  p(ipu5,3)=pmt3*sinh(vint(211))
8207  p(ipu5,4)=pmt3*cosh(vint(211))
8208  pms12=(shpr-p(ipu5,4))**2-p(ipu5,3)**2
8209  sql12=(pms12-pms1-pms2)**2-4d0*pms1*pms2
8210  IF(sql12.LE.0d0) THEN
8211  mint(51)=1
8212  RETURN
8213  ENDIF
8214  p(ipu3,3)=(-p(ipu5,3)*(pms12+pms1-pms2)+
8215  & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
8216  p(ipu4,3)=-p(ipu3,3)-p(ipu5,3)
8217  p(ipu3,4)=sqrt(pms1+p(ipu3,3)**2)
8218  p(ipu4,4)=sqrt(pms2+p(ipu4,3)**2)
8219  mint(23)=kfres
8220  n=ipu5
8221  mint(7)=mint(83)+7
8222  mint(8)=mint(83)+8
8223 
8224  ELSEIF(idoc.EQ.11) THEN
8225 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
8226  phi(1)=paru(2)*pyr(0)
8227  phi(2)=phi(1)-phir
8228  DO 520 jt=1,2
8229  i=mint(84)+2+jt
8230  k(i,1)=1
8231  IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
8232  k(i,2)=mint(20+jt)
8233  k(i,3)=mint(83)+idoc+jt-2
8234  p(i,5)=pymass(k(i,2))
8235  IF(0.5d0*shpr*z(jt).LE.p(i,5)) THEN
8236  mint(51)=1
8237  RETURN
8238  ENDIF
8239  pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
8240  ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
8241  p(i,1)=ptabs*cos(phi(jt))
8242  p(i,2)=ptabs*sin(phi(jt))
8243  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
8244  p(i,4)=0.5d0*shpr*z(jt)
8245  izw=mint(83)+6+jt
8246  k(izw,1)=21
8247  k(izw,2)=23
8248  IF(isub.EQ.8) k(izw,2)=isign(24,pychge(mint(14+jt)))
8249  k(izw,3)=izw-2
8250  p(izw,1)=-p(i,1)
8251  p(izw,2)=-p(i,2)
8252  p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
8253  p(izw,4)=0.5d0*shpr*(1d0-z(jt))
8254  p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
8255  520 CONTINUE
8256  i=mint(83)+9
8257  k(ipu5,1)=1
8258  k(ipu5,2)=kfres
8259  k(ipu5,3)=i
8260  p(ipu5,5)=shr
8261  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
8262  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
8263  p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)
8264  p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)
8265  k(i,1)=21
8266  k(i,2)=kfres
8267  DO 530 j=1,5
8268  p(i,j)=p(ipu5,j)
8269  530 CONTINUE
8270  n=ipu5
8271  mint(23)=kfres
8272 
8273  ELSEIF(idoc.EQ.12) THEN
8274 C...Z0 and W+/- scattering: store bosons and outgoing partons
8275  phi(1)=paru(2)*pyr(0)
8276  phi(2)=phi(1)-phir
8277  jtran=int(1.5d0+pyr(0))
8278  DO 540 jt=1,2
8279  i=mint(84)+2+jt
8280  k(i,1)=1
8281  IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
8282  k(i,2)=mint(20+jt)
8283  k(i,3)=mint(83)+idoc+jt-2
8284  p(i,5)=pymass(k(i,2))
8285  IF(0.5d0*shpr*z(jt).LE.p(i,5)) p(i,5)=0d0
8286  pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
8287  ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
8288  p(i,1)=ptabs*cos(phi(jt))
8289  p(i,2)=ptabs*sin(phi(jt))
8290  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
8291  p(i,4)=0.5d0*shpr*z(jt)
8292  izw=mint(83)+6+jt
8293  k(izw,1)=21
8294  IF(mint(14+jt).EQ.mint(20+jt)) THEN
8295  k(izw,2)=23
8296  ELSE
8297  k(izw,2)=isign(24,pychge(mint(14+jt))-pychge(mint(20+jt)))
8298  ENDIF
8299  k(izw,3)=izw-2
8300  p(izw,1)=-p(i,1)
8301  p(izw,2)=-p(i,2)
8302  p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
8303  p(izw,4)=0.5d0*shpr*(1d0-z(jt))
8304  p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
8305  ipu=mint(84)+4+jt
8306  k(ipu,1)=3
8307  k(ipu,2)=kfpr(isub,jt)
8308  IF(isub.EQ.72.AND.jt.EQ.jtran) k(ipu,2)=-k(ipu,2)
8309  IF(isub.EQ.73.OR.isub.EQ.77) k(ipu,2)=k(izw,2)
8310  k(ipu,3)=mint(83)+8+jt
8311  IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN
8312  p(ipu,5)=pymass(k(ipu,2))
8313  ELSE
8314  p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))
8315  ENDIF
8316  mint(22+jt)=k(ipu,2)
8317  540 CONTINUE
8318 C...Find rotation and boost for hard scattering subsystem
8319  i1=mint(83)+7
8320  i2=mint(83)+8
8321  bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))
8322  beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))
8323  bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))
8324  gamcm=(p(i1,4)+p(i2,4))/shr
8325  bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)
8326  px=p(i1,1)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bexcm
8327  py=p(i1,2)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*beycm
8328  pz=p(i1,3)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bezcm
8329  thecm=pyangl(pz,sqrt(px**2+py**2))
8330  phicm=pyangl(px,py)
8331 C...Store hard scattering subsystem. Rotate and boost it
8332  sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4d0*p(ipu5,5)**2*
8333  & p(ipu6,5)**2
8334  pabs=sqrt(max(0d0,sqlam/(4d0*sh)))
8335  cthwz=vint(23)
8336  sthwz=sqrt(max(0d0,1d0-cthwz**2))
8337  phiwz=vint(24)-phicm
8338  p(ipu5,1)=pabs*sthwz*cos(phiwz)
8339  p(ipu5,2)=pabs*sthwz*sin(phiwz)
8340  p(ipu5,3)=pabs*cthwz
8341  p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)
8342  p(ipu6,1)=-p(ipu5,1)
8343  p(ipu6,2)=-p(ipu5,2)
8344  p(ipu6,3)=-p(ipu5,3)
8345  p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)
8346  CALL pyrobo(ipu5,ipu6,thecm,phicm,bexcm,beycm,bezcm)
8347  DO 560 jt=1,2
8348  i1=mint(83)+8+jt
8349  i2=mint(84)+4+jt
8350  k(i1,1)=21
8351  k(i1,2)=k(i2,2)
8352  DO 550 j=1,5
8353  p(i1,j)=p(i2,j)
8354  550 CONTINUE
8355  560 CONTINUE
8356  n=ipu6
8357  mint(7)=mint(83)+9
8358  mint(8)=mint(83)+10
8359  ENDIF
8360 
8361  IF(iset(isub).EQ.11) THEN
8362  ELSEIF(idoc.GE.8) THEN
8363 C...Store colour connection indices
8364  DO 570 j=1,2
8365  jc=j
8366  IF(kcs.EQ.-1) jc=3-j
8367  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
8368  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)
8369  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
8370  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)
8371  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
8372  & mstu(5)*(mint(84)+icol(kcc,3,jc))
8373  IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
8374  & mstu(5)*(mint(84)+icol(kcc,4,jc))
8375  570 CONTINUE
8376 
8377 C...Copy outgoing partons to documentation lines
8378  imax=2
8379  IF(idoc.EQ.9) imax=3
8380  DO 590 i=1,imax
8381  i1=mint(83)+idoc-imax+i
8382  i2=mint(84)+2+i
8383  k(i1,1)=21
8384  k(i1,2)=k(i2,2)
8385  IF(idoc.LE.9) k(i1,3)=0
8386  IF(idoc.GE.11) k(i1,3)=mint(83)+2+i
8387  DO 580 j=1,5
8388  p(i1,j)=p(i2,j)
8389  580 CONTINUE
8390  590 CONTINUE
8391 
8392  ELSEIF(idoc.EQ.9) THEN
8393 C...Store colour connection indices
8394  DO 600 j=1,2
8395  jc=j
8396  IF(kcs.EQ.-1) jc=3-j
8397  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
8398  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)+
8399  & max(0,min(1,icol(kcc,1,jc)-2))
8400  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
8401  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)+
8402  & max(0,min(1,icol(kcc,2,jc)-2))
8403  IF(icol(kcc,3,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
8404  & mstu(5)*(mint(84)+icol(kcc,3,jc))
8405  IF(icol(kcc,4,jc).NE.0.AND.k(ipu5,1).EQ.3) k(ipu5,j+3)=
8406  & mstu(5)*(mint(84)+icol(kcc,4,jc))
8407  600 CONTINUE
8408 
8409 C...Copy outgoing partons to documentation lines
8410  DO 620 i=1,3
8411  i1=mint(83)+idoc-3+i
8412  i2=mint(84)+2+i
8413  k(i1,1)=21
8414  k(i1,2)=k(i2,2)
8415  k(i1,3)=0
8416  DO 610 j=1,5
8417  p(i1,j)=p(i2,j)
8418  610 CONTINUE
8419  620 CONTINUE
8420  ENDIF
8421 
8422 C...Low-pT events: remove gluons used for string drawing purposes
8423  IF(isub.EQ.95) THEN
8424  k(ipu3,1)=k(ipu3,1)+10
8425  k(ipu4,1)=k(ipu4,1)+10
8426  DO 630 j=41,66
8427  vintsv(j)=vint(j)
8428  vint(j)=0d0
8429  630 CONTINUE
8430  DO 650 i=mint(83)+5,mint(83)+8
8431  DO 640 j=1,5
8432  p(i,j)=0d0
8433  640 CONTINUE
8434  650 CONTINUE
8435  ENDIF
8436 
8437  RETURN
8438  END
8439 
8440 C*********************************************************************
8441 
8442 C...PYSSPA
8443 C...Generates spacelike parton showers.
8444 
8445  SUBROUTINE pysspa(IPU1,IPU2)
8446 
8447 C...Double precision and integer declarations.
8448  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8449  INTEGER pyk,pychge,pycomp
8450 C...Commonblocks.
8451  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
8452  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8453  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
8454  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8455  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8456  common/pyint1/mint(400),vint(400)
8457  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
8458  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
8459  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
8460  &/pyint2/,/pyint3/
8461 C...Local arrays and data.
8462  dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevcsv(2),tevesv(2),
8463  &xfs(2,-25:25),xfa(-25:25),xfb(-25:25),xfn(-25:25),wtapc(-25:25),
8464  &wtape(-25:25),wtsf(-25:25),the2(2),alam(2),dq2(3),dpc(3),dpd(4),
8465  &dpb(4),robo(5),more(2),kfbeam(2),q2mncs(2),kcfi(2),nfis(2),
8466  &thefis(2,2),isfi(2)
8467  DATA is/2*0/
8468 
8469 C...Read out basic information; set global Q^2 scale.
8470  ipus1=ipu1
8471  ipus2=ipu2
8472  isub=mint(1)
8473  q2mx=vint(56)
8474  IF(iset(isub).EQ.2) q2mx=parp(67)*vint(56)
8475 
8476 C...Initialize QCD evolution and check phase space.
8477  q2mnc=parp(62)**2
8478  q2mncs(1)=q2mnc
8479  IF(mstp(66).EQ.1.AND.mint(107).EQ.3)
8480  &q2mncs(1)=max(q2mnc,vint(283))
8481  q2mncs(2)=q2mnc
8482  IF(mstp(66).EQ.1.AND.mint(108).EQ.3)
8483  &q2mncs(2)=max(q2mnc,vint(284))
8484  mcev=0
8485  xec0=2d0*parp(65)/vint(1)
8486  alams=paru(112)
8487  paru(112)=parp(61)
8488  fq2c=1d0
8489  tcmx=0d0
8490  IF(mint(47).GE.2.AND.(mint(47).NE.5.OR.mstp(12).GE.1)) THEN
8491  mcev=1
8492  IF(mstp(64).EQ.1) fq2c=parp(63)
8493  IF(mstp(64).EQ.2) fq2c=parp(64)
8494  tcmx=log(fq2c*q2mx/parp(61)**2)
8495  IF(q2mx.LT.max(q2mnc,2d0*parp(61)**2).OR.tcmx.LT.0.2d0)
8496  & mcev=0
8497  ENDIF
8498 
8499 C...Initialize QED evolution and check phase space.
8500  q2mne=parp(68)**2
8501  meev=0
8502  xee=1d-6
8503  spme=pmas(11,1)**2
8504  temx=0d0
8505  fwte=10d0
8506  IF(mint(45).EQ.3.OR.mint(46).EQ.3) THEN
8507  meev=1
8508  temx=log(q2mx/spme)
8509  IF(q2mx.LE.q2mne.OR.temx.LT.0.2d0) meev=0
8510  ENDIF
8511  IF(mcev.EQ.0.AND.meev.EQ.0) RETURN
8512 
8513 C...Initial values: flavours, momenta, virtualities.
8514  ns=n
8515  100 n=ns
8516  DO 120 jt=1,2
8517  more(jt)=1
8518  kfbeam(jt)=mint(10+jt)
8519  IF(mint(18+jt).EQ.1)kfbeam(jt)=22
8520  kfls(jt)=mint(14+jt)
8521  kfls(jt+2)=kfls(jt)
8522  xs(jt)=vint(40+jt)
8523  IF(mint(18+jt).EQ.1) xs(jt)=vint(40+jt)/vint(154+jt)
8524  zs(jt)=1d0
8525  q2s(jt)=q2mx
8526  tevcsv(jt)=tcmx
8527  alam(jt)=parp(61)
8528  the2(jt)=100d0
8529  tevesv(jt)=temx
8530  DO 110 kfl=-25,25
8531  xfs(jt,kfl)=xsfx(jt,kfl)
8532  110 CONTINUE
8533  120 CONTINUE
8534  dsh=vint(44)
8535  IF(iset(isub).GE.3.AND.iset(isub).LE.5) dsh=vint(26)*vint(2)
8536 
8537 C...Find if interference with final state partons.
8538  mfis=0
8539  IF(mstp(67).GE.1.AND.mstp(67).LE.3) mfis=mstp(67)
8540  IF(mfis.NE.0) THEN
8541  DO 140 i=1,2
8542  kcfi(i)=0
8543  kca=pycomp(iabs(kfls(i)))
8544  IF(kca.NE.0) kcfi(i)=kchg(kca,2)*isign(1,kfls(i))
8545  nfis(i)=0
8546  IF(kcfi(i).NE.0) THEN
8547  IF(i.EQ.1) ipfs=ipus1
8548  IF(i.EQ.2) ipfs=ipus2
8549  DO 130 j=1,2
8550  icsi=mod(k(ipfs,3+j),mstu(5))
8551  IF(icsi.GT.0.AND.icsi.NE.ipus1.AND.icsi.NE.ipus2.AND.
8552  & (kcfi(i).EQ.(-1)**(j+1).OR.kcfi(i).EQ.2)) THEN
8553  nfis(i)=nfis(i)+1
8554  thefis(i,nfis(i))=pyangl(p(icsi,3),sqrt(p(icsi,1)**2+
8555  & p(icsi,2)**2))
8556  IF(i.EQ.2) thefis(i,nfis(i))=paru(1)-thefis(i,nfis(i))
8557  ENDIF
8558  130 CONTINUE
8559  ENDIF
8560  140 CONTINUE
8561  IF(nfis(1)+nfis(2).EQ.0) mfis=0
8562  ENDIF
8563 
8564 C...Pick up leg with highest virtuality.
8565  150 n=n+1
8566  jt=1
8567  IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2
8568  IF(more(jt).EQ.0) jt=3-jt
8569  kflb=kfls(jt)
8570  xb=xs(jt)
8571  DO 160 kfl=-25,25
8572  xfb(kfl)=xfs(jt,kfl)
8573  160 CONTINUE
8574  dshr=2d0*sqrt(dsh)
8575  dshz=dsh/zs(jt)
8576 
8577 C...Check if allowed to branch.
8578  mcev=0
8579  IF(iabs(kflb).LE.10.OR.kflb.EQ.21) THEN
8580  mcev=1
8581  xec=max(xec0,xb*(1d0/(1d0-parp(66))-1d0))
8582  IF(xb.GE.1d0-2d0*xec) mcev=0
8583  ENDIF
8584  meev=0
8585  IF(mint(44+jt).EQ.3) THEN
8586  meev=1
8587  IF(xb.GE.1d0-2d0*xee) meev=0
8588  IF((iabs(kflb).LE.10.OR.kflb.EQ.21).AND.xb.GE.1d0-2d0*xec)
8589  & meev=0
8590 C***Currently kill QED shower for resolved photoproduction.
8591  IF(mint(18+jt).EQ.1) meev=0
8592 C***Currently kill shower for W inside electron.
8593  IF(iabs(kflb).EQ.24) THEN
8594  mcev=0
8595  meev=0
8596  ENDIF
8597  ENDIF
8598  IF(mcev.EQ.0.AND.meev.EQ.0) THEN
8599  q2b=0d0
8600  goto 250
8601  ENDIF
8602 
8603 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
8604  q2b=q2s(jt)
8605  tevcb=tevcsv(jt)
8606  teveb=tevesv(jt)
8607  IF(mstp(62).LE.1) THEN
8608  IF(zs(jt).GT.0.99999d0) THEN
8609  q2b=q2s(jt)
8610  ELSE
8611  q2b=0.5d0*(1d0/zs(jt)+1d0)*q2s(jt)+0.5d0*(1d0/zs(jt)-1d0)*
8612  & (q2s(3-jt)-dsh+sqrt((dsh+q2s(1)+q2s(2))**2+
8613  & 8d0*q2s(1)*q2s(2)*zs(jt)/(1d0-zs(jt))))
8614  ENDIF
8615  IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
8616  IF(meev.EQ.1) teveb=log(q2b/spme)
8617  ENDIF
8618  IF(mcev.EQ.1) THEN
8619  alsdum=pyalps(fq2c*q2b)
8620  tevcb=tevcb+2d0*log(alam(jt)/paru(117))
8621  alam(jt)=paru(117)
8622  b0=(33d0-2d0*mstu(118))/6d0
8623  ENDIF
8624  tevcbs=tevcb
8625  tevebs=teveb
8626 
8627 C...Select side for interference with final state partons.
8628  IF(mfis.GE.1.AND.n.LE.ns+2) THEN
8629  ifi=n-ns
8630  isfi(ifi)=0
8631  IF(iabs(kcfi(ifi)).EQ.1.AND.nfis(ifi).EQ.1) THEN
8632  isfi(ifi)=1
8633  ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.1) THEN
8634  IF(pyr(0).GT.0.5d0) isfi(ifi)=1
8635  ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.2) THEN
8636  isfi(ifi)=1
8637  IF(pyr(0).GT.0.5d0) isfi(ifi)=2
8638  ENDIF
8639  ENDIF
8640 
8641 C...Calculate Altarelli-Parisi weights.
8642  DO 170 kfl=-25,25
8643  wtapc(kfl)=0d0
8644  wtape(kfl)=0d0
8645  wtsf(kfl)=0d0
8646  170 CONTINUE
8647 C...q -> q, g -> q.
8648  IF(iabs(kflb).LE.10) THEN
8649  wtapc(kflb)=(8d0/3d0)*log((1d0-xec-xb)*(xb+xec)/(xec*(1d0-xec)))
8650  wtapc(21)=0.5d0*(xb/(xb+xec)-xb/(1d0-xec))
8651 C...f -> f, gamma -> f.
8652  ELSEIF(iabs(kflb).LE.20) THEN
8653  wtapf1=log((1d0-xee-xb)*(xb+xee)/(xee*(1d0-xee)))
8654  wtapf2=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))
8655  wtape(kflb)=2d0*(wtapf1+wtapf2)
8656  IF(mstp(12).GE.1) wtape(22)=xb/(xb+xee)-xb/(1d0-xee)
8657 C...f -> g, g -> g.
8658  ELSEIF(kflb.EQ.21) THEN
8659  wtapq=(16d0/3d0)*(sqrt((1d0-xec)/xb)-sqrt((xb+xec)/xb))
8660  DO 180 kfl=1,mstp(58)
8661  wtapc(kfl)=wtapq
8662  wtapc(-kfl)=wtapq
8663  180 CONTINUE
8664  wtapc(21)=6d0*log((1d0-xec-xb)/xec)
8665 C...f -> gamma, W+, W-.
8666  ELSEIF(kflb.EQ.22) THEN
8667  wtapf=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))/xb
8668  wtape(11)=wtapf
8669  wtape(-11)=wtapf
8670  ELSEIF(kflb.EQ.24) THEN
8671  wtape(-11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
8672  & (xee*(xb+xee)))/xb
8673  ELSEIF(kflb.EQ.-24) THEN
8674  wtape(11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
8675  & (xee*(xb+xee)))/xb
8676  ENDIF
8677 
8678 C...Calculate parton distribution weights and sum.
8679  ntry=0
8680  190 ntry=ntry+1
8681  IF(ntry.GT.500) THEN
8682  mint(51)=1
8683  RETURN
8684  ENDIF
8685  wtsumc=0d0
8686  wtsume=0d0
8687  xfbo=max(1d-10,xfb(kflb))
8688  DO 200 kfl=-25,25
8689  wtsf(kfl)=xfb(kfl)/xfbo
8690  wtsumc=wtsumc+wtapc(kfl)*wtsf(kfl)
8691  wtsume=wtsume+wtape(kfl)*wtsf(kfl)
8692  200 CONTINUE
8693  wtsumc=max(0.0001d0,wtsumc)
8694  wtsume=max(0.0001d0/fwte,wtsume)
8695 
8696 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
8697  ntry2=0
8698  210 ntry2=ntry2+1
8699  IF(ntry2.GT.500) THEN
8700  mint(51)=1
8701  RETURN
8702  ENDIF
8703  IF(mcev.EQ.1) THEN
8704  IF(mstp(64).LE.0) THEN
8705  tevcb=tevcb+log(pyr(0))*paru(2)/(paru(111)*wtsumc)
8706  ELSEIF(mstp(64).EQ.1) THEN
8707  tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/wtsumc))
8708  ELSE
8709  tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/(5d0*wtsumc)))
8710  ENDIF
8711  ENDIF
8712  IF(meev.EQ.1) THEN
8713  teveb=teveb*exp(max(-50d0,log(pyr(0))*paru(2)/
8714  & (paru(101)*fwte*wtsume*temx)))
8715  ENDIF
8716 
8717 C...Translate t into Q2 scale; choose between QCD and QED evolution.
8718  220 IF(mcev.EQ.1) q2cb=alam(jt)**2*exp(max(-50d0,tevcb))/fq2c
8719  IF(meev.EQ.1) q2eb=spme*exp(max(-50d0,teveb))
8720  mce=0
8721  IF(mcev.EQ.0.AND.meev.EQ.0) THEN
8722  ELSEIF(mcev.EQ.1.AND.meev.EQ.0) THEN
8723  IF(q2cb.GT.q2mncs(jt)) mce=1
8724  ELSEIF(mcev.EQ.0.AND.meev.EQ.1) THEN
8725  IF(q2eb.GT.q2mne) mce=2
8726  ELSEIF(q2mncs(jt).GT.q2mne) THEN
8727  mce=1
8728  IF(q2eb.GT.q2cb.OR.q2cb.LE.q2mncs(jt)) mce=2
8729  IF(mce.EQ.2.AND.q2eb.LE.q2mne) mce=0
8730  ELSE
8731  mce=2
8732  IF(q2cb.GT.q2eb.OR.q2eb.LE.q2mne) mce=1
8733  IF(mce.EQ.1.AND.q2cb.LE.q2mncs(jt)) mce=0
8734  ENDIF
8735 
8736 C...Evolution possibly ended. Update t values.
8737  IF(mce.EQ.0) THEN
8738  q2b=0d0
8739  goto 250
8740  ELSEIF(mce.EQ.1) THEN
8741  q2b=q2cb
8742  q2ref=fq2c*q2b
8743  IF(meev.EQ.1) teveb=log(q2b/spme)
8744  ELSE
8745  q2b=q2eb
8746  q2ref=q2b
8747  IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
8748  ENDIF
8749 
8750 C...Select flavour for branching parton.
8751  IF(mce.EQ.1) wtran=pyr(0)*wtsumc
8752  IF(mce.EQ.2) wtran=pyr(0)*wtsume
8753  kfla=-25
8754  230 kfla=kfla+1
8755  IF(mce.EQ.1) wtran=wtran-wtapc(kfla)*wtsf(kfla)
8756  IF(mce.EQ.2) wtran=wtran-wtape(kfla)*wtsf(kfla)
8757  IF(kfla.LE.24.AND.wtran.GT.0d0) goto 230
8758  IF(kfla.EQ.25) THEN
8759  q2b=0d0
8760  goto 250
8761  ENDIF
8762 
8763 C...Choose z value and corrective weight.
8764  wtz=0d0
8765 C...q -> q + g.
8766  IF(iabs(kfla).LE.10.AND.iabs(kflb).LE.10) THEN
8767  z=1d0-((1d0-xb-xec)/(1d0-xec))*
8768  & (xec*(1d0-xec)/((xb+xec)*(1d0-xb-xec)))**pyr(0)
8769  wtz=0.5d0*(1d0+z**2)
8770 C...q -> g + q.
8771  ELSEIF(iabs(kfla).LE.10.AND.kflb.EQ.21) THEN
8772  z=xb/(sqrt(xb+xec)+pyr(0)*(sqrt(1d0-xec)-sqrt(xb+xec)))**2
8773  wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
8774 C...f -> f + gamma.
8775  ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
8776  IF(wtapf1.GT.pyr(0)*(wtapf1+wtapf2)) THEN
8777  z=1d0-((1d0-xb-xee)/(1d0-xee))*
8778  & (xee*(1d0-xee)/((xb+xee)*(1d0-xb-xee)))**pyr(0)
8779  ELSE
8780  z=xb+xb*(xee/(1d0-xee))*
8781  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
8782  ENDIF
8783  wtz=0.5d0*(1d0+z**2)*(z-xb)/(1d0-xb)
8784 C...f -> gamma + f.
8785  ELSEIF(iabs(kfla).LE.20.AND.kflb.EQ.22) THEN
8786  z=xb+xb*(xee/(1d0-xee))*
8787  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
8788  wtz=0.5d0*(1d0+(1d0-z)**2)*xb*(z-xb)/z
8789 C...f -> W+- + f'.
8790  ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).EQ.24) THEN
8791  z=xb+xb*(xee/(1d0-xee))*
8792  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
8793  wtz=0.5d0*(1d0+(1d0-z)**2)*(xb*(z-xb)/z)*
8794  & (q2b/(q2b+pmas(24,1)**2))
8795 C...g -> q + qbar.
8796  ELSEIF(kfla.EQ.21.AND.iabs(kflb).LE.10) THEN
8797  z=xb/(1d0-xec)+pyr(0)*(xb/(xb+xec)-xb/(1d0-xec))
8798  wtz=1d0-2d0*z*(1d0-z)
8799 C...g -> g + g.
8800  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
8801  z=1d0/(1d0+((1d0-xec-xb)/xb)*(xec/(1d0-xec-xb))**pyr(0))
8802  wtz=(1d0-z*(1d0-z))**2
8803 C...gamma -> f + fbar.
8804  ELSEIF(kfla.EQ.22.AND.iabs(kflb).LE.20) THEN
8805  z=xb/(1d0-xee)+pyr(0)*(xb/(xb+xee)-xb/(1d0-xee))
8806  wtz=1d0-2d0*z*(1d0-z)
8807  ENDIF
8808  IF(mce.EQ.2) wtz=(wtz/fwte)*(teveb/temx)
8809 
8810 C...Option with resummation of soft gluon emission as effective z shift.
8811  IF(mce.EQ.1) THEN
8812  IF(mstp(65).GE.1) THEN
8813  rsoft=6d0
8814  IF(kflb.NE.21) rsoft=8d0/3d0
8815  z=z*(tevcb/tevcsv(jt))**(rsoft*xec/((xb+xec)*b0))
8816  IF(z.LE.xb) goto 210
8817  ENDIF
8818 
8819 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
8820  IF(mstp(64).GE.2) THEN
8821  IF((1d0-z)*q2b.LT.q2mncs(jt)) goto 210
8822  alprat=tevcb/(tevcb+log(1d0-z))
8823  IF(alprat.LT.5d0*pyr(0)) goto 210
8824  IF(alprat.GT.5d0) wtz=wtz*alprat/5d0
8825  ENDIF
8826 
8827 C...Impose angular constraint in first branching from interference
8828 C...with final state partons.
8829  IF(mfis.GE.1.AND.n.LE.ns+2.AND.ntry2.LT.200) THEN
8830  the2d=(4d0*q2b)/(dsh*(1d0-z))
8831  IF(n.EQ.ns+1.AND.isfi(1).GE.1) THEN
8832  IF(the2d.GT.thefis(1,isfi(1))**2) goto 210
8833  ELSEIF(n.EQ.ns+2.AND.isfi(2).GE.1) THEN
8834  IF(the2d.GT.thefis(2,isfi(2))**2) goto 210
8835  ENDIF
8836  ENDIF
8837 
8838 C...Option with angular ordering requirement.
8839  IF(mstp(62).GE.3.AND.ntry2.LT.200) THEN
8840  the2t=(4d0*z**2*q2b)/(vint(2)*(1d0-z)*xb**2)
8841  IF(the2t.GT.the2(jt)) goto 210
8842  ENDIF
8843  ENDIF
8844 
8845 C...Weighting with new parton distributions.
8846  mint(105)=mint(102+jt)
8847  mint(109)=mint(106+jt)
8848  IF(mstp(57).LE.1) THEN
8849  CALL pypdfu(kfbeam(jt),xb,q2ref,xfn)
8850  ELSE
8851  CALL pypdfl(kfbeam(jt),xb,q2ref,xfn)
8852  ENDIF
8853  xfbn=xfn(kflb)
8854  IF(xfbn.LT.1d-20) THEN
8855  IF(kfla.EQ.kflb) THEN
8856  tevcb=tevcbs
8857  teveb=tevebs
8858  wtapc(kflb)=0d0
8859  wtape(kflb)=0d0
8860  goto 190
8861  ELSEIF(mce.EQ.1.AND.tevcbs-tevcb.GT.0.2d0) THEN
8862  tevcb=0.5d0*(tevcbs+tevcb)
8863  goto 220
8864  ELSEIF(mce.EQ.2.AND.tevebs-teveb.GT.0.2d0) THEN
8865  teveb=0.5d0*(tevebs+teveb)
8866  goto 220
8867  ELSE
8868  xfbn=1d-10
8869  xfn(kflb)=xfbn
8870  ENDIF
8871  ENDIF
8872  DO 240 kfl=-25,25
8873  xfb(kfl)=xfn(kfl)
8874  240 CONTINUE
8875  xa=xb/z
8876  IF(mstp(57).LE.1) THEN
8877  CALL pypdfu(kfbeam(jt),xa,q2ref,xfa)
8878  ELSE
8879  CALL pypdfl(kfbeam(jt),xa,q2ref,xfa)
8880  ENDIF
8881  xfan=xfa(kfla)
8882  IF(xfan.LT.1d-20) goto 190
8883  wtsfa=wtsf(kfla)
8884  IF(wtz*xfan/xfbn.LT.pyr(0)*wtsfa) goto 190
8885 
8886 C...Define two hard scatterers in their CM-frame.
8887  250 IF(n.EQ.ns+2) THEN
8888  dq2(jt)=q2b
8889  dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr
8890  DO 270 jr=1,2
8891  i=ns+jr
8892  IF(jr.EQ.1) ipo=ipus1
8893  IF(jr.EQ.2) ipo=ipus2
8894  DO 260 j=1,5
8895  k(i,j)=0
8896  p(i,j)=0d0
8897  v(i,j)=0d0
8898  260 CONTINUE
8899  k(i,1)=14
8900  k(i,2)=kfls(jr+2)
8901  k(i,4)=ipo
8902  k(i,5)=ipo
8903  p(i,3)=dplcm*(-1)**(jr+1)
8904  p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
8905  p(i,5)=-sqrt(dq2(jr))
8906  k(ipo,1)=14
8907  k(ipo,3)=i
8908  k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i
8909  k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i
8910  270 CONTINUE
8911 
8912 C...Find maximum allowed mass of timelike parton.
8913  ELSEIF(n.GT.ns+2) THEN
8914  jr=3-jt
8915  dq2(3)=q2b
8916  dpc(1)=p(is(1),4)
8917  dpc(2)=p(is(2),4)
8918  dpc(3)=0.5d0*(abs(p(is(1),3))+abs(p(is(2),3)))
8919  dpd(1)=dsh+dq2(jr)+dq2(jt)
8920  dpd(2)=dshz+dq2(jr)+dq2(3)
8921  dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))
8922  dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))
8923  ikin=0
8924  IF(q2s(jr).GE.0.25d0*q2mnc.AND.dpd(1)-dpd(3).GE.
8925  & 1d-10*dpd(1)) ikin=1
8926  IF(ikin.EQ.0) dmsma=(dq2(jt)/zs(jt)-dq2(3))*
8927  & (dsh/(dsh+dq2(jt))-dsh/(dshz+dq2(3)))
8928  IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/
8929  & (2d0*dq2(jr))-dq2(jt)-dq2(3)
8930 
8931 C...Generate timelike parton shower (if required).
8932  it=n
8933  DO 280 j=1,5
8934  k(it,j)=0
8935  p(it,j)=0d0
8936  v(it,j)=0d0
8937  280 CONTINUE
8938  k(it,1)=3
8939 C...f -> f + g (gamma).
8940  IF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).LE.20) THEN
8941  k(it,2)=21
8942  IF(iabs(kflb).GE.11) k(it,2)=22
8943 C...f -> g (gamma, W+-) + f.
8944  ELSEIF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).GT.20) THEN
8945  k(it,2)=kflb
8946  IF(kfls(jt+2).EQ.24) THEN
8947  k(it,2)=-12
8948  ELSEIF(kfls(jt+2).EQ.-24) THEN
8949  k(it,2)=12
8950  ENDIF
8951 C...g (gamma) -> f + fbar, g + g.
8952  ELSE
8953  k(it,2)=-kfls(jt+2)
8954  IF(kfls(jt+2).GT.20) k(it,2)=kfls(jt+2)
8955  ENDIF
8956  p(it,5)=pymass(k(it,2))
8957  IF(dmsma.LE.p(it,5)**2) goto 100
8958  IF(mstp(63).GE.1.AND.mce.EQ.1) THEN
8959  mstj48=mstj(48)
8960  parj85=parj(85)
8961  p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
8962  p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)
8963  IF(mstp(63).EQ.1) THEN
8964  q2tim=dmsma
8965  ELSEIF(mstp(63).EQ.2) THEN
8966  q2tim=min(dmsma,parp(71)*q2s(jt))
8967  ELSE
8968  q2tim=dmsma
8969  mstj(48)=1
8970  IF(ikin.EQ.0) dpt2=dmsma*(dshz+dq2(3))/(dsh+dq2(jt))
8971  IF(ikin.EQ.1) dpt2=dmsma*(0.5d0*dpd(1)*dpd(2)+0.5d0*dpd(3)*
8972  & dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)))/(4d0*dsh*dpc(3)**2)
8973  parj(85)=sqrt(max(0d0,dpt2))*
8974  & (1d0/p(it,4)+1d0/p(is(jt),4))
8975  ENDIF
8976  CALL pyshow(it,0,sqrt(q2tim))
8977  mstj(48)=mstj48
8978  parj(85)=parj85
8979  IF(n.GE.it+1) p(it,5)=p(it+1,5)
8980  ENDIF
8981 
8982 C...Reconstruct kinematics of branching: timelike parton shower.
8983  dms=p(it,5)**2
8984  IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))
8985  IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5d0*dpd(1)*dpd(2)+
8986  & 0.5d0*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
8987  & (4d0*dsh*dpc(3)**2)
8988  IF(dpt2.LT.0d0) goto 100
8989  dpb(1)=(0.5d0*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
8990  & dshr)/dpc(3)-dpc(3)
8991  p(it,1)=sqrt(dpt2)
8992  p(it,3)=dpb(1)*(-1)**(jt+1)
8993  p(it,4)=sqrt(dpt2+dpb(1)**2+dms)
8994  IF(n.GE.it+1) THEN
8995  dpb(1)=sqrt(dpb(1)**2+dpt2)
8996  dpb(2)=sqrt(dpb(1)**2+dms)
8997  dpb(3)=p(it+1,3)
8998  dpb(4)=sqrt(dpb(3)**2+dms)
8999  dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
9000  & dpb(1))
9001  CALL pyrobo(it+1,n,0d0,0d0,0d0,0d0,dbez)
9002  the=pyangl(p(it,3),p(it,1))
9003  CALL pyrobo(it+1,n,the,0d0,0d0,0d0,0d0)
9004  ENDIF
9005 
9006 C...Reconstruct kinematics of branching: spacelike parton.
9007  DO 290 j=1,5
9008  k(n+1,j)=0
9009  p(n+1,j)=0d0
9010  v(n+1,j)=0d0
9011  290 CONTINUE
9012  k(n+1,1)=14
9013  k(n+1,2)=kflb
9014  p(n+1,1)=p(it,1)
9015  p(n+1,3)=p(it,3)+p(is(jt),3)
9016  p(n+1,4)=p(it,4)+p(is(jt),4)
9017  p(n+1,5)=-sqrt(dq2(3))
9018 
9019 C...Define colour flow of branching.
9020  k(is(jt),3)=n+1
9021  k(it,3)=n+1
9022  im1=n+1
9023  im2=n+1
9024 C...f -> f + gamma (Z, W).
9025  IF(iabs(k(it,2)).GE.22) THEN
9026  k(it,1)=1
9027  id1=is(jt)
9028  id2=is(jt)
9029 C...f -> gamma (Z, W) + f.
9030  ELSEIF(iabs(k(is(jt),2)).GE.22) THEN
9031  id1=it
9032  id2=it
9033 C...gamma -> q + qbar, g + g.
9034  ELSEIF(k(n+1,2).EQ.22) THEN
9035  id1=is(jt)
9036  id2=it
9037  im1=id2
9038  im2=id1
9039 C...q -> q + g.
9040  ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(it,2).EQ.21) THEN
9041  id1=it
9042  id2=is(jt)
9043 C...q -> g + q.
9044  ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21) THEN
9045  id1=is(jt)
9046  id2=it
9047 C...qbar -> qbar + g.
9048  ELSEIF(k(n+1,2).LT.0.AND.k(it,2).EQ.21) THEN
9049  id1=is(jt)
9050  id2=it
9051 C...qbar -> g + qbar.
9052  ELSEIF(k(n+1,2).LT.0) THEN
9053  id1=it
9054  id2=is(jt)
9055 C...g -> g + g; g -> q + qbar.
9056  ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
9057  id1=is(jt)
9058  id2=it
9059  ELSE
9060  id1=it
9061  id2=is(jt)
9062  ENDIF
9063  IF(im1.EQ.n+1) k(im1,4)=k(im1,4)+id1
9064  IF(im2.EQ.n+1) k(im2,5)=k(im2,5)+id2
9065  k(id1,4)=k(id1,4)+mstu(5)*im1
9066  k(id2,5)=k(id2,5)+mstu(5)*im2
9067  IF(id1.NE.id2) THEN
9068  k(id1,5)=k(id1,5)+mstu(5)*id2
9069  k(id2,4)=k(id2,4)+mstu(5)*id1
9070  ENDIF
9071  n=n+1
9072 
9073 C...Boost to new CM-frame.
9074  dbsvx=(p(n,1)+p(is(jr),1))/(p(n,4)+p(is(jr),4))
9075  dbsvz=(p(n,3)+p(is(jr),3))/(p(n,4)+p(is(jr),4))
9076  IF(dbsvx**2+dbsvz**2.GE.1d0) goto 100
9077  CALL pyrobo(ns+1,n,0d0,0d0,-dbsvx,0d0,-dbsvz)
9078  ir=n+(jt-1)*(is(1)-n)
9079  CALL pyrobo(ns+1,n,-pyangl(p(ir,3),p(ir,1)),paru(2)*pyr(0),
9080  & 0d0,0d0,0d0)
9081  ENDIF
9082 
9083 C...Update kinematics variables.
9084  is(jt)=n
9085  dq2(jt)=q2b
9086  IF(mstp(62).GE.3) the2(jt)=the2t
9087  dsh=dshz
9088 
9089 C...Save quantities; loop back.
9090  q2s(jt)=q2b
9091  IF((mcev.EQ.1.AND.q2b.GE.0.25d0*q2mnc).OR.
9092  &(meev.EQ.1.AND.q2b.GE.q2mne)) THEN
9093  kfls(jt+2)=kfls(jt)
9094  kfls(jt)=kfla
9095  xs(jt)=xa
9096  zs(jt)=z
9097  DO 300 kfl=-25,25
9098  xfs(jt,kfl)=xfa(kfl)
9099  300 CONTINUE
9100  tevcsv(jt)=tevcb
9101  tevesv(jt)=teveb
9102  ELSE
9103  more(jt)=0
9104  IF(jt.EQ.1) ipu1=n
9105  IF(jt.EQ.2) ipu2=n
9106  ENDIF
9107  IF(n.GT.mstu(4)-mstu(32)-10) THEN
9108  CALL pyerrm(11,'(PYSSPA:) no more memory left in PYJETS')
9109  IF(mstu(21).GE.1) n=ns
9110  IF(mstu(21).GE.1) RETURN
9111  ENDIF
9112  IF(more(1).EQ.1.OR.more(2).EQ.1) goto 150
9113 
9114 C...Boost hard scattering partons to frame of shower initiators.
9115  DO 310 j=1,3
9116  robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))
9117  310 CONTINUE
9118  k(n+2,1)=1
9119  DO 320 j=1,5
9120  p(n+2,j)=p(ns+1,j)
9121  320 CONTINUE
9122  robot=robo(3)**2+robo(4)**2+robo(5)**2
9123  IF(robot.GE.0.999999d0) THEN
9124  robot=1.00001d0*sqrt(robot)
9125  robo(3)=robo(3)/robot
9126  robo(4)=robo(4)/robot
9127  robo(5)=robo(5)/robot
9128  ENDIF
9129  CALL pyrobo(n+2,n+2,0d0,0d0,-robo(3),-robo(4),-robo(5))
9130  robo(2)=pyangl(p(n+2,1),p(n+2,2))
9131  robo(1)=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
9132  CALL pyrobo(mint(83)+5,ns,robo(1),robo(2),robo(3),robo(4),
9133  &robo(5))
9134 
9135 C...Store user information. Reset Lambda value.
9136  k(ipu1,3)=mint(83)+3
9137  k(ipu2,3)=mint(83)+4
9138  DO 330 jt=1,2
9139  mint(12+jt)=kfls(jt)
9140  vint(140+jt)=xs(jt)
9141  IF(mint(18+jt).EQ.1) vint(140+jt)=vint(154+jt)*xs(jt)
9142  330 CONTINUE
9143  paru(112)=alams
9144 
9145  RETURN
9146  END
9147 
9148 C*********************************************************************
9149 
9150 C...PYRESD
9151 C...Allows resonances to decay (including parton showers for hadronic
9152 C...channels).
9153 
9154  SUBROUTINE pyresd(IRES)
9155 
9156 C...Double precision and integer declarations.
9157  IMPLICIT DOUBLE PRECISION(a-h, o-z)
9158  INTEGER pyk,pychge,pycomp
9159 C...Parameter statement to help give large particle numbers.
9160  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
9161 C...Commonblocks.
9162  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
9163  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
9164  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
9165  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
9166  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
9167  common/pypars/mstp(200),parp(200),msti(200),pari(200)
9168  common/pyint1/mint(400),vint(400)
9169  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
9170  common/pyint4/mwid(500),wids(500,5)
9171  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
9172  &/pyint1/,/pyint2/,/pyint4/
9173 C...Local arrays and complex and character variables.
9174  dimension iref(50,8),kdcy(3),kfl1(3),kfl2(3),kfl3(3),keql(3),
9175  &kcqm(3),kcq1(3),kcq2(3),kcq3(3),nsd(3),pmmn(3),ilin(6),
9176  &hgz(3,3),coup(6,4),corl(2,2,2),pk(6,4),pkk(6,6),cthe(3),
9177  &phi(3),wdtp(0:200),wdte(0:200,0:5),dbezqq(3),dpmo(5),xm(5)
9178  COMPLEX fgk,ha(6,6),hc(6,6)
9179  REAL tir,uir
9180  CHARACTER code*9,mass*9
9181 
9182 C...The F, Xi and Xj functions of Gunion and Kunszt
9183 C...(Phys. Rev. D33, 665, plus errata from the authors).
9184  fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*
9185  &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
9186  digk(dt,du)=-4d0*d34*d56+dt*(3d0*dt+4d0*du)+dt**2*(dt*du/
9187  &(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+2d0*(d34/d56+d56/d34))
9188  djgk(dt,du)=8d0*(d34+d56)**2-8d0*(d34+d56)*(dt+du)-6d0*dt*du-
9189  &2d0*dt*du*(dt*du/(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+
9190  &2d0*(d34/d56+d56/d34))
9191 
9192 C...Some general constants.
9193  xw=paru(102)
9194  xwv=xw
9195  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
9196  xw1=1d0-xw
9197  sqmz=pmas(23,1)**2
9198  gmmz=pmas(23,1)*pmas(23,2)
9199  sqmw=pmas(24,1)**2
9200  gmmw=pmas(24,1)*pmas(24,2)
9201  sh=vint(44)
9202 
9203 C...Reset original resonance configuration.
9204  DO 100 jt=1,8
9205  iref(1,jt)=0
9206  100 CONTINUE
9207 
9208 C...Define initial one, two or three objects for subprocess.
9209  IF(ires.EQ.0) THEN
9210  isub=mint(1)
9211  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
9212  iref(1,1)=mint(84)+2+iset(isub)
9213  iref(1,4)=mint(83)+6+iset(isub)
9214  ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
9215  iref(1,1)=mint(84)+1+iset(isub)
9216  iref(1,2)=mint(84)+2+iset(isub)
9217  iref(1,4)=mint(83)+5+iset(isub)
9218  iref(1,5)=mint(83)+6+iset(isub)
9219  ELSEIF(iset(isub).EQ.5) THEN
9220  iref(1,1)=mint(84)+3
9221  iref(1,2)=mint(84)+4
9222  iref(1,3)=mint(84)+5
9223  iref(1,4)=mint(83)+7
9224  iref(1,5)=mint(83)+8
9225  iref(1,6)=mint(83)+9
9226  ENDIF
9227 
9228 C...Define original resonance for odd cases.
9229  ELSE
9230  isub=0
9231  iref(1,1)=ires
9232  ENDIF
9233 
9234 C...Check if initial resonance has been moved (in resonance + jet).
9235  DO 120 jt=1,3
9236  IF(iref(1,jt).GT.0) THEN
9237  IF(k(iref(1,jt),1).GT.10) THEN
9238  kfa=iabs(k(iref(1,jt),2))
9239  IF(kfa.GE.6.AND.kchg(pycomp(kfa),2).NE.0) THEN
9240  DO 110 i=iref(1,jt)+1,n
9241  IF(k(i,1).LE.10.AND.k(i,2).EQ.k(iref(1,jt),2))
9242  & iref(1,jt)=i
9243  110 CONTINUE
9244  ELSE
9245  kda=mod(k(iref(1,jt),4),mstu(4))
9246  IF(mwid(pycomp(kfa)).NE.0.AND.kda.GT.1) iref(1,jt)=kda
9247  ENDIF
9248  ENDIF
9249  ENDIF
9250  120 CONTINUE
9251 
9252 C...Loop over decay history.
9253  np=1
9254  ip=0
9255  130 ip=ip+1
9256  ninh=0
9257  jtmax=2
9258  IF(iref(ip,2).EQ.0) jtmax=1
9259  IF(iref(ip,3).NE.0) jtmax=3
9260  it4=0
9261  nsav=n
9262 
9263 C...Start treatment of one, two or three resonances in parallel.
9264  140 n=nsav
9265  DO 220 jt=1,jtmax
9266  id=iref(ip,jt)
9267  kdcy(jt)=0
9268  kfl1(jt)=0
9269  kfl2(jt)=0
9270  kfl3(jt)=0
9271  keql(jt)=0
9272  nsd(jt)=id
9273 
9274 C...Check whether particle can/is allowed to decay.
9275  IF(id.EQ.0) goto 210
9276  kfa=iabs(k(id,2))
9277  kca=pycomp(kfa)
9278  IF(mwid(kca).EQ.0) goto 210
9279  IF(k(id,1).GT.10.OR.mdcy(kca,1).EQ.0) goto 210
9280  IF(kfa.EQ.6.OR.kfa.EQ.7.OR.kfa.EQ.8.OR.kfa.EQ.17.OR.
9281  & kfa.EQ.18) it4=it4+1
9282  k(id,4)=mstu(5)*(k(id,4)/mstu(5))
9283  k(id,5)=mstu(5)*(k(id,5)/mstu(5))
9284 
9285 C...Info for selection of decay channel: sign, pairings.
9286  IF(kchg(kca,3).EQ.0) THEN
9287  ipm=2
9288  ELSE
9289  ipm=(5-isign(1,k(id,2)))/2
9290  ENDIF
9291  kfb=0
9292  IF(jtmax.EQ.2) THEN
9293  kfb=iabs(k(iref(ip,3-jt),2))
9294  ELSEIF(jtmax.EQ.3) THEN
9295  jt2=jt+1-3*(jt/3)
9296  kfb=iabs(k(iref(ip,jt2),2))
9297  IF(kfb.NE.kfa) THEN
9298  jt2=jt+2-3*((jt+1)/3)
9299  kfb=iabs(k(iref(ip,jt2),2))
9300  ENDIF
9301  ENDIF
9302 
9303 C...Select decay channel.
9304  IF(isub.EQ.1.OR.isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.
9305  & isub.EQ.30.OR.isub.EQ.35.OR.isub.EQ.141) mint(61)=1
9306  CALL pywidt(kfa,p(id,5)**2,wdtp,wdte)
9307  wdte0s=wdte(0,1)+wdte(0,ipm)+wdte(0,4)
9308  IF(kfb.EQ.kfa) wdte0s=wdte0s+wdte(0,5)
9309  IF(wdte0s.LE.0d0) goto 210
9310  rkfl=wdte0s*pyr(0)
9311  idl=0
9312  150 idl=idl+1
9313  idc=idl+mdcy(kca,2)-1
9314  rkfl=rkfl-(wdte(idl,1)+wdte(idl,ipm)+wdte(idl,4))
9315  IF(kfb.EQ.kfa) rkfl=rkfl-wdte(idl,5)
9316  IF(idl.LT.mdcy(kca,3).AND.rkfl.GT.0d0) goto 150
9317 
9318 C...Read out flavours and colour charges of decay channel chosen.
9319  kcqm(jt)=kchg(kca,2)*isign(1,k(id,2))
9320  IF(kcqm(jt).EQ.-2) kcqm(jt)=2
9321  kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))
9322  kfc1a=pycomp(iabs(kfl1(jt)))
9323  IF(kchg(kfc1a,3).EQ.0) kfl1(jt)=iabs(kfl1(jt))
9324  kcq1(jt)=kchg(kfc1a,2)*isign(1,kfl1(jt))
9325  IF(kcq1(jt).EQ.-2) kcq1(jt)=2
9326  kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))
9327  kfc2a=pycomp(iabs(kfl2(jt)))
9328  IF(kchg(kfc2a,3).EQ.0) kfl2(jt)=iabs(kfl2(jt))
9329  kcq2(jt)=kchg(kfc2a,2)*isign(1,kfl2(jt))
9330  IF(kcq2(jt).EQ.-2) kcq2(jt)=2
9331  kfl3(jt)=kfdp(idc,3)*isign(1,k(id,2))
9332  IF(kfl3(jt).NE.0) THEN
9333  kfc3a=pycomp(iabs(kfl3(jt)))
9334  IF(kchg(kfc3a,3).EQ.0) kfl3(jt)=iabs(kfl3(jt))
9335  kcq3(jt)=kchg(kfc3a,2)*isign(1,kfl3(jt))
9336  IF(kcq3(jt).EQ.-2) kcq3(jt)=2
9337  ENDIF
9338 
9339 C...Set/save further info on channel.
9340  kdcy(jt)=1
9341  IF(kfb.EQ.kfa) keql(jt)=mdme(idc,1)
9342  nsd(jt)=n
9343  hgz(jt,1)=vint(111)
9344  hgz(jt,2)=vint(112)
9345  hgz(jt,3)=vint(114)
9346 
9347 C...Select masses; to begin with assume resonances narrow.
9348  DO 170 i=1,3
9349  p(n+i,5)=0d0
9350  pmmn(i)=0d0
9351  IF(i.EQ.1) THEN
9352  kflw=iabs(kfl1(jt))
9353  kcw=kfc1a
9354  ELSEIF(i.EQ.2) THEN
9355  kflw=iabs(kfl2(jt))
9356  kcw=kfc2a
9357  ELSEIF(i.EQ.3) THEN
9358  IF(kfl3(jt).EQ.0) goto 170
9359  kflw=iabs(kfl3(jt))
9360  kcw=kfc3a
9361  ENDIF
9362  p(n+i,5)=pmas(kcw,1)
9363 CMRENNA++
9364 C...This prevents SUSY/t particles from becoming too light.
9365  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
9366  pmmn(i)=pmas(kcw,1)
9367  DO 160 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
9368  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
9369  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
9370  & pmas(pycomp(kfdp(idc,2)),1)
9371  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
9372  & pmas(pycomp(kfdp(idc,3)),1)
9373  pmmn(i)=min(pmmn(i),pmsum)
9374  ENDIF
9375  160 CONTINUE
9376 CMRENNA--
9377  ELSEIF(kflw.EQ.6) THEN
9378  pmmn(i)=pmas(24,1)+pmas(5,1)
9379  ENDIF
9380  170 CONTINUE
9381 
9382 C...Check which two out of three are widest.
9383  iwid1=1
9384  iwid2=2
9385  pwid1=pmas(kfc1a,2)
9386  pwid2=pmas(kfc2a,2)
9387  kflw1=iabs(kfl1(jt))
9388  kflw2=iabs(kfl2(jt))
9389  IF(kfl3(jt).NE.0) THEN
9390  pwid3=pmas(kfc3a,2)
9391  IF(pwid3.GT.pwid1.AND.pwid2.GE.pwid1) THEN
9392  iwid1=3
9393  pwid1=pwid3
9394  kflw1=iabs(kfl3(jt))
9395  ELSEIF(pwid3.GT.pwid2) THEN
9396  iwid2=3
9397  pwid2=pwid3
9398  kflw2=iabs(kfl3(jt))
9399  ENDIF
9400  ENDIF
9401 
9402 C...If all narrow then only check that masses consistent.
9403  IF(mstp(42).LE.0.OR.(pwid1.LT.parp(41).AND.
9404  & pwid2.LT.parp(41))) THEN
9405 CMRENNA++
9406 C....Handle near degeneracy cases.
9407  IF(kfa/ksusy1.EQ.1.OR.kfa/ksusy1.EQ.2) THEN
9408  IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
9409  p(n+1,5)=p(id,5)-p(n+2,5)-0.5d0
9410  IF(p(n+1,5).LT.0d0) p(n+1,5)=0d0
9411  ENDIF
9412  ENDIF
9413 CMRENNA--
9414  IF(p(n+1,5)+p(n+2,5)+p(n+3,5)+parj(64).GT.p(id,5)) THEN
9415  CALL pyerrm(13,'(PYRESD:) daughter masses too large')
9416  mint(51)=1
9417  RETURN
9418  ENDIF
9419 
9420 C...For three wide resonances select narrower of three
9421 C...according to BW decoupled from rest.
9422  ELSE
9423  pmtot=p(id,5)
9424  IF(kfl3(jt).NE.0) THEN
9425  iwid3=6-iwid1-iwid2
9426  kflw3=iabs(kfl1(jt))+iabs(kfl2(jt))+iabs(kfl3(jt))-
9427  & kflw1-kflw2
9428  loop=0
9429  180 loop=loop+1
9430  p(n+iwid3,5)=pymass(kflw3)
9431  IF(loop.LE.10.AND. p(n+iwid3,5).LE.pmmn(iwid3)) goto 180
9432  pmtot=pmtot-p(n+iwid3,5)
9433  ENDIF
9434 C...Select other two correlated within remaining phase space.
9435  IF(ip.EQ.1) THEN
9436  ckin45=ckin(45)
9437  ckin47=ckin(47)
9438  ckin(45)=max(pmmn(iwid1),ckin(45))
9439  ckin(47)=max(pmmn(iwid2),ckin(47))
9440  CALL pyofsh(2,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
9441  & p(n+iwid2,5))
9442  ckin(45)=ckin45
9443  ckin(47)=ckin47
9444  ELSE
9445  ckin(49)=pmmn(iwid1)
9446  ckin(50)=pmmn(iwid2)
9447  CALL pyofsh(5,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
9448  & p(n+iwid2,5))
9449  ckin(49)=0d0
9450  ckin(50)=0d0
9451  ENDIF
9452  IF(mint(51).EQ.1) RETURN
9453  ENDIF
9454 
9455 C...Begin fill decay products, with colour flow for coloured objects.
9456  mstu10=mstu(10)
9457  mstu(10)=1
9458  mstu(19)=1
9459 
9460 CMRENNA++
9461 C...1) Three-body decays of SUSY particles.
9462  IF(kfl3(jt).NE.0) THEN
9463  DO 200 i=n+1,n+3
9464  DO 190 j=1,5
9465  k(i,j)=0
9466  v(i,j)=0d0
9467  190 CONTINUE
9468  200 CONTINUE
9469  xm(1)=p(n+1,5)
9470  xm(2)=p(n+2,5)
9471  xm(3)=p(n+3,5)
9472  xm(5)=p(id,5)
9473  CALL pytbdy(xm)
9474  k(n+1,1)=1
9475  k(n+1,2)=kfl1(jt)
9476  k(n+2,1)=1
9477  k(n+2,2)=kfl2(jt)
9478  k(n+3,1)=1
9479  k(n+3,2)=kfl3(jt)
9480 C...Set colour flow in three-body decays - programmed as special cases.
9481  IF(kfc2a.LE.6) THEN
9482  k(n+2,1)=3
9483  k(n+3,1)=3
9484  isid=4
9485  IF(kfl2(jt).LT.0) isid=5
9486  k(n+2,isid)=mstu(5)*(n+3)
9487  k(n+3,9-isid)=mstu(5)*(n+2)
9488  ENDIF
9489  IF(kfl1(jt).EQ.ksusy1+21) THEN
9490  k(n+1,1)=3
9491  k(n+2,1)=3
9492  k(n+3,1)=3
9493  isid=4
9494  IF(kfl2(jt).LT.0) isid=5
9495  k(n+1,isid)=mstu(5)*(n+2)
9496  k(n+1,9-isid)=mstu(5)*(n+3)
9497  k(n+2,isid)=mstu(5)*(n+1)
9498  k(n+3,9-isid)=mstu(5)*(n+1)
9499  ENDIF
9500  IF(kfa.EQ.ksusy1+21) THEN
9501  k(n+2,1)=3
9502  k(n+3,1)=3
9503  isid=4
9504  IF(kfl2(jt).LT.0) isid=5
9505  k(id,isid)=k(id,isid)+(n+2)
9506  k(id,9-isid)=k(id,9-isid)+(n+3)
9507  k(n+2,isid)=mstu(5)*id
9508  k(n+3,9-isid)=mstu(5)*id
9509  ENDIF
9510  n=n+3
9511 CMRENNA--
9512 
9513 C...2) Everything else two-body decay.
9514  ELSE
9515  CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
9516 C...First set colour flow as if mother colour singlet.
9517  IF(kcq1(jt).NE.0) THEN
9518  k(n-1,1)=3
9519  IF(kcq1(jt).NE.-1) k(n-1,4)=mstu(5)*n
9520  IF(kcq1(jt).NE.1) k(n-1,5)=mstu(5)*n
9521  ENDIF
9522  IF(kcq2(jt).NE.0) THEN
9523  k(n,1)=3
9524  IF(kcq2(jt).NE.-1) k(n,4)=mstu(5)*(n-1)
9525  IF(kcq2(jt).NE.1) k(n,5)=mstu(5)*(n-1)
9526  ENDIF
9527 C...Then redirect colour flow if mother (anti)triplet.
9528  IF(kcqm(jt).EQ.0) THEN
9529  ELSEIF(kcqm(jt).NE.2) THEN
9530  isid=4
9531  IF(kcqm(jt).EQ.-1) isid=5
9532  idau=n-1
9533  IF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.2) idau=n
9534  k(id,isid)=k(id,isid)+idau
9535  k(idau,isid)=mstu(5)*id
9536 C...Then redirect colour flow if mother octet.
9537  ELSEIF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.0) THEN
9538  idau=n-1
9539  IF(kcq1(jt).EQ.0) idau=n
9540  k(id,4)=k(id,4)+idau
9541  k(id,5)=k(id,5)+idau
9542  k(idau,4)=mstu(5)*id
9543  k(idau,5)=mstu(5)*id
9544  ELSE
9545  isid=4
9546  IF(kcq1(jt).EQ.-1) isid=5
9547  IF(kcq1(jt).EQ.2) isid=int(4.5d0+pyr(0))
9548  k(id,isid)=k(id,isid)+(n-1)
9549  k(id,9-isid)=k(id,9-isid)+n
9550  k(n-1,isid)=mstu(5)*id
9551  k(n,9-isid)=mstu(5)*id
9552  ENDIF
9553  ENDIF
9554 
9555 C...End loop over resonances for daughter flavour and mass selection.
9556  mstu(10)=mstu10
9557  210 IF(mwid(kca).NE.0.AND.(kfl1(jt).EQ.0.OR.kfl3(jt).NE.0))
9558  & ninh=ninh+1
9559  IF(ires.GT.0.AND.mwid(kca).NE.0.AND.kfl1(jt).EQ.0) THEN
9560  WRITE(code,'(I9)') k(id,2)
9561  WRITE(mass,'(F9.3)') p(id,5)
9562  CALL pyerrm(3,'(PYRESD:) Failed to decay particle'//
9563  & code//' with mass'//mass)
9564  mint(51)=1
9565  RETURN
9566  ENDIF
9567  220 CONTINUE
9568 
9569 C...Check for allowed combinations. Skip if no decays.
9570  IF(jtmax.EQ.1) THEN
9571  IF(kdcy(1).EQ.0) goto 560
9572  ELSEIF(jtmax.EQ.2) THEN
9573  IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0) goto 560
9574  IF(keql(1).EQ.4.AND.keql(2).EQ.4) goto 140
9575  IF(keql(1).EQ.5.AND.keql(2).EQ.5) goto 140
9576  ELSEIF(jtmax.EQ.3) THEN
9577  IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0.AND.kdcy(3).EQ.0) goto 560
9578  IF(keql(1).EQ.4.AND.keql(2).EQ.4) goto 140
9579  IF(keql(1).EQ.4.AND.keql(3).EQ.4) goto 140
9580  IF(keql(2).EQ.4.AND.keql(3).EQ.4) goto 140
9581  IF(keql(1).EQ.5.AND.keql(2).EQ.5) goto 140
9582  IF(keql(1).EQ.5.AND.keql(3).EQ.5) goto 140
9583  IF(keql(2).EQ.5.AND.keql(3).EQ.5) goto 140
9584  ENDIF
9585 
9586 C...Special case: matrix element option for Z0 decay to quarks.
9587  IF(mstp(48).EQ.1.AND.isub.EQ.1.AND.jtmax.EQ.1.AND.
9588  &iabs(mint(11)).EQ.11.AND.iabs(kfl1(1)).LE.5) THEN
9589 
9590 C...Check consistency of MSTJ options set.
9591  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
9592  CALL pyerrm(6,
9593  & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
9594  mstj(110)=1
9595  ENDIF
9596  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
9597  CALL pyerrm(6,
9598  & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
9599  mstj(111)=0
9600  ENDIF
9601 
9602 C...Select alpha_strong behaviour.
9603  mst111=mstu(111)
9604  par112=paru(112)
9605  mstu(111)=mstj(108)
9606  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
9607  & mstu(111)=1
9608  paru(112)=parj(121)
9609  IF(mstu(111).EQ.2) paru(112)=parj(122)
9610 
9611 C...Find axial fraction in total cross section for scalar gluon model.
9612  parj(171)=0d0
9613  IF((iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.1).OR.
9614  & (mstj(101).EQ.5.AND.mstj(49).EQ.1)) THEN
9615  poll=1d0-parj(131)*parj(132)
9616  sff=1d0/(16d0*xw*xw1)
9617  sfw=p(id,5)**4/((p(id,5)**2-parj(123)**2)**2+
9618  & (parj(123)*parj(124))**2)
9619  sfi=sfw*(1d0-(parj(123)/p(id,5))**2)
9620  ve=4d0*xw-1d0
9621  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
9622  hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*
9623  & (parj(132)-parj(131)))
9624  kflc=iabs(kfl1(1))
9625  pmq=pymass(kflc)
9626  qf=kchg(kflc,1)/3d0
9627  vq=1d0
9628  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,
9629  & 1d0-(2d0*pmq/p(id,5))**2))
9630  vf=sign(1d0,qf)-4d0*qf*xw
9631  rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+
9632  & vf**2*hf1w)+vq**3*hf1w
9633  IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
9634  ENDIF
9635 
9636 C...Choice of jet configuration.
9637  CALL pyxjet(p(id,5),njet,cut)
9638  kflc=iabs(kfl1(1))
9639  kfln=21
9640  IF(njet.EQ.4) THEN
9641  CALL pyx4jt(njet,cut,kflc,p(id,5),kfln,x1,x2,x4,x12,x14)
9642  ELSEIF(njet.EQ.3) THEN
9643  CALL pyx3jt(njet,cut,kflc,p(id,5),x1,x3)
9644  ELSE
9645  mstj(120)=1
9646  ENDIF
9647 
9648 C...Fill jet configuration; return if incorrect kinematics.
9649  nc=n-2
9650  IF(njet.EQ.2.AND.mstj(101).NE.5) THEN
9651  CALL py2ent(nc+1,kflc,-kflc,p(id,5))
9652  ELSEIF(njet.EQ.2) THEN
9653  CALL py2ent(-(nc+1),kflc,-kflc,p(id,5))
9654  ELSEIF(njet.EQ.3) THEN
9655  CALL py3ent(nc+1,kflc,21,-kflc,p(id,5),x1,x3)
9656  ELSEIF(kfln.EQ.21) THEN
9657  CALL py4ent(nc+1,kflc,kfln,kfln,-kflc,p(id,5),x1,x2,x4,
9658  & x12,x14)
9659  ELSE
9660  CALL py4ent(nc+1,kflc,-kfln,kfln,-kflc,p(id,5),x1,x2,x4,
9661  & x12,x14)
9662  ENDIF
9663  IF(mstu(24).NE.0) THEN
9664  mint(51)=1
9665  mstu(111)=mst111
9666  paru(112)=par112
9667  RETURN
9668  ENDIF
9669 
9670 C...Angular orientation according to matrix element.
9671  IF(mstj(106).EQ.1) THEN
9672  CALL pyxdif(nc,njet,kflc,p(id,5),chi,the,phi)
9673  IF(mint(11).LT.0) the=paru(1)-the
9674  cthe(1)=cos(the)
9675  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
9676  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
9677  ENDIF
9678 
9679 C...Boost partons to Z0 rest frame.
9680  CALL pyrobo(nc+1,n,0d0,0d0,p(id,1)/p(id,4),
9681  & p(id,2)/p(id,4),p(id,3)/p(id,4))
9682 
9683 C...Mark decayed resonance and add documentation lines,
9684  k(id,1)=k(id,1)+10
9685  idoc=mint(83)+mint(4)
9686  DO 240 i=nc+1,n
9687  i1=mint(83)+mint(4)+1
9688  k(i,3)=i1
9689  IF(mstp(128).GE.1) k(i,3)=id
9690  IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
9691  mint(4)=mint(4)+1
9692  k(i1,1)=21
9693  k(i1,2)=k(i,2)
9694  k(i1,3)=iref(ip,4)
9695  DO 230 j=1,5
9696  p(i1,j)=p(i,j)
9697  230 CONTINUE
9698  ENDIF
9699  240 CONTINUE
9700 
9701 C...Generate parton shower.
9702  IF(mstj(101).EQ.5) CALL pyshow(n-1,n,p(id,5))
9703 
9704 C... End special case for Z0: skip ahead.
9705  mstu(111)=mst111
9706  paru(112)=par112
9707  goto 550
9708  ENDIF
9709 
9710 C...Order incoming partons and outgoing resonances.
9711  IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN
9712  ilin(1)=mint(84)+1
9713  IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2
9714  IF(k(ilin(1),2).EQ.21) ilin(1)=2*mint(84)+3-ilin(1)
9715  ilin(2)=2*mint(84)+3-ilin(1)
9716  imin=1
9717  IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
9718  & .EQ.36) imin=3
9719  imax=2
9720  iord=1
9721  IF(k(iref(ip,1),2).EQ.23) iord=2
9722  IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2
9723  iakipd=iabs(k(iref(ip,iord),2))
9724  IF(iakipd.EQ.25.OR.iakipd.EQ.35.OR.iakipd.EQ.36) iord=3-iord
9725  IF(kdcy(iord).EQ.0) iord=3-iord
9726 
9727 C...Order decay products of resonances.
9728  DO 250 jt=iord,3-iord,3-2*iord
9729  IF(kdcy(jt).EQ.0) THEN
9730  ilin(imax+1)=nsd(jt)
9731  imax=imax+1
9732  ELSEIF(k(nsd(jt)+1,2).GT.0) THEN
9733  ilin(imax+1)=n+2*jt-1
9734  ilin(imax+2)=n+2*jt
9735  imax=imax+2
9736  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
9737  k(n+2*jt,2)=k(nsd(jt)+2,2)
9738  ELSE
9739  ilin(imax+1)=n+2*jt
9740  ilin(imax+2)=n+2*jt-1
9741  imax=imax+2
9742  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
9743  k(n+2*jt,2)=k(nsd(jt)+2,2)
9744  ENDIF
9745  250 CONTINUE
9746 
9747 C...Find charge, isospin, left- and righthanded couplings.
9748  DO 270 i=imin,imax
9749  DO 260 j=1,4
9750  coup(i,j)=0d0
9751  260 CONTINUE
9752  kfa=iabs(k(ilin(i),2))
9753  IF(kfa.EQ.0.OR.kfa.GT.20) goto 270
9754  coup(i,1)=kchg(kfa,1)/3d0
9755  coup(i,2)=(-1)**mod(kfa,2)
9756  coup(i,4)=-2d0*coup(i,1)*xwv
9757  coup(i,3)=coup(i,2)+coup(i,4)
9758  270 CONTINUE
9759 
9760 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
9761  IF(isub.EQ.22) THEN
9762  DO 300 i=3,5,2
9763  i1=iord
9764  IF(i.EQ.5) i1=3-iord
9765  DO 290 j1=1,2
9766  DO 280 j2=1,2
9767  corl(i/2,j1,j2)=coup(1,1)**2*hgz(i1,1)*coup(i,1)**2/
9768  & 16d0+coup(1,1)*coup(1,j1+2)*hgz(i1,2)*coup(i,1)*
9769  & coup(i,j2+2)/4d0+coup(1,j1+2)**2*hgz(i1,3)*
9770  & coup(i,j2+2)**2
9771  280 CONTINUE
9772  290 CONTINUE
9773  300 CONTINUE
9774  cowt12=(corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
9775  & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2))
9776  comx12=(corl(1,1,1)+corl(1,1,2)+corl(1,2,1)+corl(1,2,2))*
9777  & (corl(2,1,1)+corl(2,1,2)+corl(2,2,1)+corl(2,2,2))
9778  IF(cowt12.LT.pyr(0)*comx12) goto 140
9779  ENDIF
9780  ENDIF
9781 
9782 C...Select angular orientation type - Z'/W' only.
9783  mzpwp=0
9784  IF(isub.EQ.141) THEN
9785  IF(pyr(0).LT.paru(130)) mzpwp=1
9786  IF(ip.EQ.2) THEN
9787  IF(iabs(k(iref(2,1),2)).EQ.37) mzpwp=2
9788  iakir=iabs(k(iref(2,2),2))
9789  IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
9790  ENDIF
9791  IF(ip.GE.3) mzpwp=2
9792  ELSEIF(isub.EQ.142) THEN
9793  IF(pyr(0).LT.paru(136)) mzpwp=1
9794  IF(ip.EQ.2) THEN
9795  iakir=iabs(k(iref(2,2),2))
9796  IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
9797  ENDIF
9798  IF(ip.GE.3) mzpwp=2
9799  ENDIF
9800 
9801 C...Select random angles (begin of weighting procedure).
9802  310 DO 320 jt=1,jtmax
9803  IF(kdcy(jt).EQ.0) goto 320
9804  IF(jtmax.EQ.1) THEN
9805  cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*pyr(0)
9806  IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)
9807  phi(jt)=vint(24)
9808  ELSE
9809  cthe(jt)=2d0*pyr(0)-1d0
9810  phi(jt)=paru(2)*pyr(0)
9811  ENDIF
9812  320 CONTINUE
9813 
9814  IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN
9815 C...Construct massless four-vectors.
9816  DO 340 i=n+1,n+4
9817  k(i,1)=1
9818  DO 330 j=1,5
9819  p(i,j)=0d0
9820  v(i,j)=0d0
9821  330 CONTINUE
9822  340 CONTINUE
9823  DO 350 jt=1,jtmax
9824  IF(kdcy(jt).EQ.0) goto 350
9825  id=iref(ip,jt)
9826  p(n+2*jt-1,3)=0.5d0*p(id,5)
9827  p(n+2*jt-1,4)=0.5d0*p(id,5)
9828  p(n+2*jt,3)=-0.5d0*p(id,5)
9829  p(n+2*jt,4)=0.5d0*p(id,5)
9830  CALL pyrobo(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),
9831  & p(id,1)/p(id,4),p(id,2)/p(id,4),p(id,3)/p(id,4))
9832  350 CONTINUE
9833 
9834 C...Store incoming and outgoing momenta, with random rotation to
9835 C...avoid accidental zeroes in HA expressions.
9836  DO 370 i=1,imax
9837  k(n+4+i,1)=1
9838  p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+
9839  & p(ilin(i),3)**2+p(ilin(i),5)**2)
9840  p(n+4+i,5)=p(ilin(i),5)
9841  DO 360 j=1,3
9842  p(n+4+i,j)=p(ilin(i),j)
9843  360 CONTINUE
9844  370 CONTINUE
9845  380 therr=acos(2d0*pyr(0)-1d0)
9846  phirr=paru(2)*pyr(0)
9847  CALL pyrobo(n+5,n+4+imax,therr,phirr,0d0,0d0,0d0)
9848  DO 400 i=1,imax
9849  IF(p(n+4+i,1)**2+p(n+4+i,2)**2.LT.1d-4*p(n+4+i,4)**2) goto 380
9850  DO 390 j=1,4
9851  pk(i,j)=p(n+4+i,j)
9852  390 CONTINUE
9853  400 CONTINUE
9854 
9855 C...Calculate internal products.
9856  IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25.OR.isub.EQ.141.OR.
9857  & isub.EQ.142) THEN
9858  DO 420 i1=imin,imax-1
9859  DO 410 i2=i1+1,imax
9860  ha(i1,i2)=sngl(sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+
9861  & pk(i2,3))/(1d-20+pk(i1,1)**2+pk(i1,2)**2)))*
9862  & cmplx(sngl(pk(i1,1)),sngl(pk(i1,2)))-
9863  & sngl(sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/
9864  & (1d-20+pk(i2,1)**2+pk(i2,2)**2)))*
9865  & cmplx(sngl(pk(i2,1)),sngl(pk(i2,2)))
9866  hc(i1,i2)=conjg(ha(i1,i2))
9867  IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)
9868  IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)
9869  ha(i2,i1)=-ha(i1,i2)
9870  hc(i2,i1)=-hc(i1,i2)
9871  410 CONTINUE
9872  420 CONTINUE
9873  ENDIF
9874  DO 440 i=1,2
9875  DO 430 j=1,4
9876  pk(i,j)=-pk(i,j)
9877  430 CONTINUE
9878  440 CONTINUE
9879  DO 460 i1=imin,imax-1
9880  DO 450 i2=i1+1,imax
9881  pkk(i1,i2)=2d0*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-
9882  & pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
9883  pkk(i2,i1)=pkk(i1,i2)
9884  450 CONTINUE
9885  460 CONTINUE
9886  ENDIF
9887 
9888  kfagm=iabs(iref(ip,7))
9889  IF(mstp(47).LE.0.OR.ninh.NE.0) THEN
9890 C...Isotropic decay selected by user.
9891  wt=1d0
9892  wtmax=1d0
9893 
9894  ELSEIF(it4.GE.1) THEN
9895 C... Isotropic decay t -> b + W etc for 4th generation q and l.
9896  wt=1d0
9897  wtmax=1d0
9898 
9899  ELSEIF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.
9900  & iref(ip,7).EQ.36) THEN
9901 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
9902  IF(ip.EQ.1) wtmax=sh**2
9903  IF(ip.GE.2) wtmax=p(iref(ip,8),5)**4
9904  kfa=iabs(k(iref(ip,1),2))
9905  IF(kfa.EQ.23) THEN
9906  kflf1a=iabs(kfl1(1))
9907  ef1=kchg(kflf1a,1)/3d0
9908  af1=sign(1d0,ef1+0.1d0)
9909  vf1=af1-4d0*ef1*xwv
9910  kflf2a=iabs(kfl1(2))
9911  ef2=kchg(kflf2a,1)/3d0
9912  af2=sign(1d0,ef2+0.1d0)
9913  vf2=af2-4d0*ef2*xwv
9914  va12as=4d0*vf1*af1*vf2*af2/((vf1**2+af1**2)*(vf2**2+af2**2))
9915  wt=8d0*(1d0+va12as)*pkk(3,5)*pkk(4,6)+
9916  & 8d0*(1d0-va12as)*pkk(3,6)*pkk(4,5)
9917  ELSEIF(kfa.EQ.24) THEN
9918  wt=16d0*pkk(3,5)*pkk(4,6)
9919  ELSE
9920  wt=wtmax
9921  ENDIF
9922 
9923  ELSEIF((kfagm.EQ.6.OR.kfagm.EQ.7.OR.kfagm.EQ.8.OR.
9924  & kfagm.EQ.17.OR.kfagm.EQ.18).AND.iabs(k(iref(ip,1),2)).EQ.24)
9925  & THEN
9926 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
9927  i1=iref(ip,8)
9928  IF(mod(kfagm,2).EQ.0) THEN
9929  i2=n+1
9930  i3=n+2
9931  ELSE
9932  i2=n+2
9933  i3=n+1
9934  ENDIF
9935  i4=iref(ip,2)
9936  wt=(p(i1,4)*p(i2,4)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
9937  & p(i1,3)*p(i2,3))*(p(i3,4)*p(i4,4)-p(i3,1)*p(i4,1)-
9938  & p(i3,2)*p(i4,2)-p(i3,3)*p(i4,3))
9939  wtmax=(p(i1,5)**4-p(iref(ip,1),5)**4)/8d0
9940 
9941  ELSEIF(isub.EQ.1) THEN
9942 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
9943  ei=kchg(iabs(mint(15)),1)/3d0
9944  ai=sign(1d0,ei+0.1d0)
9945  vi=ai-4d0*ei*xwv
9946  ef=kchg(iabs(kfl1(1)),1)/3d0
9947  af=sign(1d0,ef+0.1d0)
9948  vf=af-4d0*ef*xwv
9949  rmf=min(1d0,4d0*pmas(iabs(kfl1(1)),1)**2/sh)
9950  wt1=ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
9951  & (vi**2+ai**2)*vint(114)*(vf**2+(1d0-rmf)*af**2)
9952  wt2=rmf*(ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
9953  & (vi**2+ai**2)*vint(114)*vf**2)
9954  wt3=sqrt(1d0-rmf)*(ei*ai*vint(112)*ef*af+
9955  & 4d0*vi*ai*vint(114)*vf*af)
9956  wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
9957  & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
9958  wtmax=wt1+abs(wt3)
9959 
9960  ELSEIF(isub.EQ.2) THEN
9961 C...Angular weight for W+/- -> 2 quarks/leptons.
9962  wt=(1d0+cthe(1)*isign(1,mint(15)*kfl1(1)))**2
9963  wtmax=4d0
9964 
9965  ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN
9966 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
9967 C...-> gluon/gamma + 2 quarks/leptons.
9968  clilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
9969  & coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+
9970  & coup(1,3)**2*hgz(2,3)*coup(3,3)**2
9971  clirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
9972  & coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+
9973  & coup(1,3)**2*hgz(2,3)*coup(3,4)**2
9974  crilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
9975  & coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+
9976  & coup(1,4)**2*hgz(2,3)*coup(3,3)**2
9977  crirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
9978  & coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+
9979  & coup(1,4)**2*hgz(2,3)*coup(3,4)**2
9980  wt=(clilf+crirf)*(pkk(1,3)**2+pkk(2,4)**2)+
9981  & (clirf+crilf)*(pkk(1,4)**2+pkk(2,3)**2)
9982  wtmax=(clilf+clirf+crilf+crirf)*
9983  & ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
9984 
9985  ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN
9986 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
9987 C...-> gluon/gamma + 2 quarks/leptons.
9988  wt=pkk(1,3)**2+pkk(2,4)**2
9989  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2
9990 
9991  ELSEIF(isub.EQ.22) THEN
9992 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
9993  s34=p(iref(ip,iord),5)**2
9994  s56=p(iref(ip,3-iord),5)**2
9995  ti=pkk(1,3)+pkk(1,4)+s34
9996  ui=pkk(1,5)+pkk(1,6)+s56
9997  tir=REAL(ti)
9998  uir=REAL(ui)
9999  fgk135=abs(fgk(1,2,3,4,5,6)/tir+fgk(1,2,5,6,3,4)/uir)**2
10000  fgk145=abs(fgk(1,2,4,3,5,6)/tir+fgk(1,2,5,6,4,3)/uir)**2
10001  fgk136=abs(fgk(1,2,3,4,6,5)/tir+fgk(1,2,6,5,3,4)/uir)**2
10002  fgk146=abs(fgk(1,2,4,3,6,5)/tir+fgk(1,2,6,5,4,3)/uir)**2
10003  fgk253=abs(fgk(2,1,5,6,3,4)/tir+fgk(2,1,3,4,5,6)/uir)**2
10004  fgk263=abs(fgk(2,1,6,5,3,4)/tir+fgk(2,1,3,4,6,5)/uir)**2
10005  fgk254=abs(fgk(2,1,5,6,4,3)/tir+fgk(2,1,4,3,5,6)/uir)**2
10006  fgk264=abs(fgk(2,1,6,5,4,3)/tir+fgk(2,1,4,3,6,5)/uir)**2
10007  wt=
10008  & corl(1,1,1)*corl(2,1,1)*fgk135+corl(1,1,2)*corl(2,1,1)*fgk145+
10009  & corl(1,1,1)*corl(2,1,2)*fgk136+corl(1,1,2)*corl(2,1,2)*fgk146+
10010  & corl(1,2,1)*corl(2,2,1)*fgk253+corl(1,2,2)*corl(2,2,1)*fgk263+
10011  & corl(1,2,1)*corl(2,2,2)*fgk254+corl(1,2,2)*corl(2,2,2)*fgk264
10012  wtmax=16d0*((corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
10013  & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2)))*s34*s56*
10014  & ((ti**2+ui**2+2d0*sh*(s34+s56))/(ti*ui)-s34*s56*(1d0/ti**2+
10015  & 1d0/ui**2))
10016 
10017  ELSEIF(isub.EQ.23) THEN
10018 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
10019  d34=p(iref(ip,iord),5)**2
10020  d56=p(iref(ip,3-iord),5)**2
10021  dt=pkk(1,3)+pkk(1,4)+d34
10022  du=pkk(1,5)+pkk(1,6)+d56
10023  facbw=1d0/((sh-sqmw)**2+sqmw*pmas(24,2)**2)
10024  cawz=coup(2,3)/dt-2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
10025  cbwz=coup(1,3)/du+2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
10026  fgk135=abs(REAL(cawz)*fgk(1,2,3,4,5,6)+
10027  & REAL(cbwz)*fgk(1,2,5,6,3,4))
10028  fgk136=abs(REAL(cawz)*fgk(1,2,3,4,6,5)+
10029  & REAL(cbwz)*fgk(1,2,6,5,3,4))
10030  wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
10031  wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*
10032  & digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))
10033 
10034  ELSEIF(isub.EQ.24.OR.isub.EQ.171.OR.isub.EQ.176) THEN
10035 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
10036 C...(or H0, or A0).
10037  wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
10038  & pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*
10039  & coup(3,3))**2)*pkk(1,4)*pkk(2,3)
10040  wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
10041  & (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
10042 
10043  ELSEIF(isub.EQ.25) THEN
10044 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
10045  d34=p(iref(ip,iord),5)**2
10046  d56=p(iref(ip,3-iord),5)**2
10047  dt=pkk(1,3)+pkk(1,4)+d34
10048  du=pkk(1,5)+pkk(1,6)+d56
10049  facbw=1d0/((sh-sqmz)**2+sqmz*pmas(23,2)**2)
10050  cdww=(coup(1,3)*sqmz*(sh-sqmz)*facbw+coup(1,2))/sh
10051  caww=cdww+0.5d0*(coup(1,2)+1d0)/dt
10052  cbww=cdww+0.5d0*(coup(1,2)-1d0)/du
10053  ccww=coup(1,4)*sqmz*(sh-sqmz)*facbw/sh
10054  fgk135=abs(REAL(caww)*fgk(1,2,3,4,5,6)-
10055  & REAL(cbww)*fgk(1,2,5,6,3,4))
10056  fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
10057  wt=fgk135**2+(ccww*fgk253)**2
10058  wtmax=4d0*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-caww*
10059  & cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
10060 
10061  ELSEIF(isub.EQ.26.OR.isub.EQ.172.OR.isub.EQ.177) THEN
10062 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
10063 C...(or H0, or A0).
10064  wt=pkk(1,3)*pkk(2,4)
10065  wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
10066 
10067  ELSEIF(isub.EQ.30.OR.isub.EQ.35) THEN
10068 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
10069 C...-> f + 2 quarks/leptons.
10070  clilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
10071  & coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+
10072  & coup(1,3)**2*hgz(2,3)*coup(3,3)**2
10073  clirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
10074  & coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+
10075  & coup(1,3)**2*hgz(2,3)*coup(3,4)**2
10076  crilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
10077  & coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+
10078  & coup(1,4)**2*hgz(2,3)*coup(3,3)**2
10079  crirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+
10080  & coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+
10081  & coup(1,4)**2*hgz(2,3)*coup(3,4)**2
10082  IF(k(ilin(1),2).GT.0) wt=(clilf+crirf)*(pkk(1,4)**2+
10083  & pkk(3,5)**2)+(clirf+crilf)*(pkk(1,3)**2+pkk(4,5)**2)
10084  IF(k(ilin(1),2).LT.0) wt=(clilf+crirf)*(pkk(1,3)**2+
10085  & pkk(4,5)**2)+(clirf+crilf)*(pkk(1,4)**2+pkk(3,5)**2)
10086  wtmax=(clilf+clirf+crilf+crirf)*
10087  & ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
10088 
10089  ELSEIF(isub.EQ.31) THEN
10090 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
10091  IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2
10092  IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2
10093  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2
10094 
10095  ELSEIF(isub.EQ.71.OR.isub.EQ.72.OR.isub.EQ.73.OR.isub.EQ.76.OR.
10096  & isub.EQ.77) THEN
10097 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
10098  wt=16d0*pkk(3,5)*pkk(4,6)
10099  wtmax=sh**2
10100 
10101  ELSEIF(isub.EQ.110) THEN
10102 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
10103  wt=1d0
10104  wtmax=1d0
10105 
10106  ELSEIF(isub.EQ.141) THEN
10107  IF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
10108 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
10109 C...Couplings of incoming flavour.
10110  kfai=iabs(mint(15))
10111  ei=kchg(kfai,1)/3d0
10112  ai=sign(1d0,ei+0.1d0)
10113  vi=ai-4d0*ei*xwv
10114  kfaic=1
10115  IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
10116  IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
10117  IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
10118  vpi=paru(119+2*kfaic)
10119  api=paru(120+2*kfaic)
10120 C...Couplings of final flavour.
10121  kfaf=iabs(kfl1(1))
10122  ef=kchg(kfaf,1)/3d0
10123  af=sign(1d0,ef+0.1d0)
10124  vf=af-4d0*ef*xwv
10125  kfafc=1
10126  IF(kfaf.LE.10.AND.mod(kfaf,2).EQ.0) kfafc=2
10127  IF(kfaf.GT.10.AND.mod(kfaf,2).NE.0) kfafc=3
10128  IF(kfaf.GT.10.AND.mod(kfaf,2).EQ.0) kfafc=4
10129  vpf=paru(119+2*kfafc)
10130  apf=paru(120+2*kfafc)
10131 C...Asymmetry and weight.
10132  asym=2d0*(ei*ai*vint(112)*ef*af+ei*api*vint(113)*ef*apf+
10133  & 4d0*vi*ai*vint(114)*vf*af+(vi*api+vpi*ai)*vint(115)*
10134  & (vf*apf+vpf*af)+4d0*vpi*api*vint(116)*vpf*apf)/
10135  & (ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
10136  & ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
10137  & (vf**2+af**2)+(vi*vpi+ai*api)*vint(115)*(vf*vpf+af*apf)+
10138  & (vpi**2+api**2)*vint(116)*(vpf**2+apf**2))
10139  wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
10140  wtmax=2d0+abs(asym)
10141  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).EQ.24) THEN
10142 C...Angular weight for f + fbar -> Z' -> W+ + W-.
10143  rm1=p(nsd(1)+1,5)**2/sh
10144  rm2=p(nsd(1)+2,5)**2/sh
10145  ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
10146  & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
10147  cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
10148  & (rm2-rm1)**2)
10149  wt=cflat+ccos2*cthe(1)**2
10150  wtmax=cflat+max(0d0,ccos2)
10151  ELSEIF(ip.EQ.1.AND.(kfl1(1).EQ.25.OR.kfl1(1).EQ.35.OR.
10152  & iabs(kfl1(1)).EQ.37)) THEN
10153 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
10154  wt=1d0-cthe(1)**2
10155  wtmax=1d0
10156  ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
10157 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
10158  rm1=p(nsd(1)+1,5)**2/sh
10159  rm2=p(nsd(1)+2,5)**2/sh
10160  flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
10161  wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
10162  wtmax=1d0+flam2/(8d0*rm1)
10163  ELSEIF(mzpwp.EQ.0) THEN
10164 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10165 C...(W:s like if intermediate Z).
10166  d34=p(iref(ip,iord),5)**2
10167  d56=p(iref(ip,3-iord),5)**2
10168  dt=pkk(1,3)+pkk(1,4)+d34
10169  du=pkk(1,5)+pkk(1,6)+d56
10170  fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
10171  fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
10172  wt=(coup(1,3)*fgk135)**2+(coup(1,4)*fgk253)**2
10173  wtmax=4d0*d34*d56*(coup(1,3)**2+coup(1,4)**2)*
10174  & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
10175  ELSEIF(mzpwp.EQ.1) THEN
10176 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10177 C...(W:s approximately longitudinal, like if intermediate H).
10178  wt=16d0*pkk(3,5)*pkk(4,6)
10179  wtmax=sh**2
10180  ELSE
10181 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
10182 C...H0 + A0 -> 4 quarks/leptons.
10183  wt=1d0
10184  wtmax=1d0
10185  ENDIF
10186 
10187  ELSEIF(isub.EQ.142) THEN
10188  IF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
10189 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
10190  kfai=iabs(mint(15))
10191  kfaic=1
10192  IF(kfai.GT.10) kfaic=2
10193  vi=paru(129+2*kfaic)
10194  ai=paru(130+2*kfaic)
10195  kfaf=iabs(kfl1(1))
10196  kfafc=1
10197  IF(kfaf.GT.10) kfafc=2
10198  vf=paru(129+2*kfafc)
10199  af=paru(130+2*kfafc)
10200  asym=8d0*vi*ai*vf*af/((vi**2+ai**2)*(vf**2+af**2))
10201  wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
10202  wtmax=2d0+abs(asym)
10203  ELSEIF(ip.EQ.1.AND.iabs(kfl2(1)).EQ.23) THEN
10204 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
10205  rm1=p(nsd(1)+1,5)**2/sh
10206  rm2=p(nsd(1)+2,5)**2/sh
10207  ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
10208  & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
10209  cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
10210  & (rm2-rm1)**2)
10211  wt=cflat+ccos2*cthe(1)**2
10212  wtmax=cflat+max(0d0,ccos2)
10213  ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
10214 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
10215  rm1=p(nsd(1)+1,5)**2/sh
10216  rm2=p(nsd(1)+2,5)**2/sh
10217  flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
10218  wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
10219  wtmax=1d0+flam2/(8d0*rm1)
10220  ELSEIF(mzpwp.EQ.0) THEN
10221 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10222 C...(W/Z like if intermediate W).
10223  d34=p(iref(ip,iord),5)**2
10224  d56=p(iref(ip,3-iord),5)**2
10225  dt=pkk(1,3)+pkk(1,4)+d34
10226  du=pkk(1,5)+pkk(1,6)+d56
10227  fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
10228  fgk136=abs(fgk(1,2,3,4,6,5)-fgk(1,2,6,5,3,4))
10229  wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
10230  wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*
10231  & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
10232  ELSEIF(mzpwp.EQ.1) THEN
10233 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10234 C...(W/Z approximately longitudinal, like if intermediate H).
10235  wt=16d0*pkk(3,5)*pkk(4,6)
10236  wtmax=sh**2
10237  ELSE
10238 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
10239  wt=1d0
10240  wtmax=1d0
10241  ENDIF
10242 
10243  ELSEIF(isub.EQ.145.OR.isub.EQ.162.OR.isub.EQ.163.OR.isub.EQ.164)
10244  & THEN
10245 C...Isotropic decay of leptoquarks (assumed spin 0).
10246  wt=1d0
10247  wtmax=1d0
10248 
10249  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
10250 C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
10251  side=1d0
10252  IF(mint(16).EQ.21) side=-1d0
10253  IF(ip.EQ.1.AND.(kfl1(1).EQ.21.OR.kfl1(1).EQ.22)) THEN
10254  wt=1d0+side*cthe(1)
10255  wtmax=2d0
10256  ELSEIF(ip.EQ.1) THEN
10257  rm1=p(nsd(1)+1,5)**2/sh
10258  wt=1d0+side*cthe(1)*(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
10259  wtmax=1d0+(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
10260  ELSE
10261 C...W/Z decay assumed isotropic, since not known.
10262  wt=1d0
10263  wtmax=1d0
10264  ENDIF
10265 
10266  ELSEIF(isub.EQ.149) THEN
10267 C...Isotropic decay of techni-eta.
10268  wt=1d0
10269  wtmax=1d0
10270 
10271  ELSEIF(isub.EQ.191) THEN
10272  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
10273 C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
10274 C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
10275  wt=1d0-cthe(1)**2
10276  wtmax=1d0
10277  ELSEIF(ip.EQ.1) THEN
10278 C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
10279  cthesg=cthe(1)*isign(1,mint(15))
10280  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
10281  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
10282  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
10283  kfai=iabs(mint(15))
10284  ei=kchg(kfai,1)/3d0
10285  ai=sign(1d0,ei+0.1d0)
10286  vi=ai-4d0*ei*xwv
10287  vali=0.5d0*(vi+ai)
10288  vari=0.5d0*(vi-ai)
10289  alefti=(ei+vali*bwzr)**2+(vali*bwzi)**2
10290  arighi=(ei+vari*bwzr)**2+(vari*bwzi)**2
10291  kfaf=iabs(kfl1(1))
10292  ef=kchg(kfaf,1)/3d0
10293  af=sign(1d0,ef+0.1d0)
10294  vf=af-4d0*ef*xwv
10295  valf=0.5d0*(vf+af)
10296  varf=0.5d0*(vf-af)
10297  aleftf=(ef+valf*bwzr)**2+(valf*bwzi)**2
10298  arighf=(ef+varf*bwzr)**2+(varf*bwzi)**2
10299  asame=alefti*aleftf+arighi*arighf
10300  aflip=alefti*arighf+arighi*aleftf
10301  wt=asame*(1d0+cthesg)**2+aflip*(1d0-cthesg)**2
10302  wtmax=4d0*max(asame,aflip)
10303  ELSE
10304 C...Isotropic decay of W/pi_tech produced in rho_tech decay.
10305  wt=1d0
10306  wtmax=1d0
10307  ENDIF
10308 
10309  ELSEIF(isub.EQ.192) THEN
10310  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
10311 C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
10312 C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
10313  wt=1d0-cthe(1)**2
10314  wtmax=1d0
10315  ELSEIF(ip.EQ.1) THEN
10316 C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
10317  cthesg=cthe(1)*isign(1,mint(15))
10318  wt=(1d0+cthesg)**2
10319  wtmax=4d0
10320  ELSE
10321 C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
10322  wt=1d0
10323  wtmax=1d0
10324  ENDIF
10325 
10326  ELSEIF(isub.EQ.193) THEN
10327  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
10328 C...Angular weight for f + fbar -> omega_tech0 ->
10329 C...gamma pi_tech0 or Z0 pi_tech0.
10330  wt=1d0+cthe(1)**2
10331  wtmax=2d0
10332  ELSEIF(ip.EQ.1) THEN
10333 C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
10334  cthesg=cthe(1)*isign(1,mint(15))
10335  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
10336  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
10337  kfai=iabs(mint(15))
10338  ei=kchg(kfai,1)/3d0
10339  ai=sign(1d0,ei+0.1d0)
10340  vi=ai-4d0*ei*xwv
10341  vali=0.5d0*(vi+ai)
10342  vari=0.5d0*(vi-ai)
10343  blefti=(ei-vali*bwzr)**2+(vali*bwzi)**2
10344  brighi=(ei-vari*bwzr)**2+(vari*bwzi)**2
10345  kfaf=iabs(kfl1(1))
10346  ef=kchg(kfaf,1)/3d0
10347  af=sign(1d0,ef+0.1d0)
10348  vf=af-4d0*ef*xwv
10349  valf=0.5d0*(vf+af)
10350  varf=0.5d0*(vf-af)
10351  bleftf=(ef-valf*bwzr)**2+(valf*bwzi)**2
10352  brighf=(ef-varf*bwzr)**2+(varf*bwzi)**2
10353  bsame=blefti*bleftf+brighi*brighf
10354  bflip=blefti*brighf+brighi*bleftf
10355  wt=bsame*(1d0+cthesg)**2+bflip*(1d0-cthesg)**2
10356  wtmax=4d0*max(bsame,bflip)
10357  ELSE
10358 C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
10359  wt=1d0
10360  wtmax=1d0
10361  ENDIF
10362 
10363 C...Obtain correct angular distribution by rejection techniques.
10364  ELSE
10365  wt=1d0
10366  wtmax=1d0
10367  ENDIF
10368  IF(wt.LT.pyr(0)*wtmax) goto 310
10369 
10370 C...Construct massive four-vectors using angles chosen.
10371  470 DO 540 jt=1,jtmax
10372  IF(kdcy(jt).EQ.0) goto 540
10373  id=iref(ip,jt)
10374  DO 480 j=1,5
10375  dpmo(j)=p(id,j)
10376  480 CONTINUE
10377  dpmo(4)=sqrt(dpmo(1)**2+dpmo(2)**2+dpmo(3)**2+dpmo(5)**2)
10378 CMRENNA++
10379  IF(kfl3(jt).EQ.0) THEN
10380  CALL pyrobo(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),
10381  & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
10382  ELSE
10383  CALL pyrobo(nsd(jt)+1,nsd(jt)+3,acos(cthe(jt)),phi(jt),
10384  & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
10385  ENDIF
10386 CMRENNA--
10387 
10388 C...Mark decayed resonances; trace history.
10389  k(id,1)=k(id,1)+10
10390  kfa=iabs(k(id,2))
10391  kca=pycomp(kfa)
10392  IF(kcqm(jt).NE.0) THEN
10393 C...Do not kill colour flow through coloured resonance!
10394  ELSE
10395  k(id,4)=nsd(jt)+1
10396  k(id,5)=nsd(jt)+2
10397  IF(kfl3(jt).NE.0) k(id,5)=nsd(jt)+3
10398  ENDIF
10399 
10400 C...Add documentation lines.
10401  IF(isub.NE.0) THEN
10402  idoc=mint(83)+mint(4)
10403 CMRENNA+++
10404  ihi=nsd(jt)+2
10405  IF(kfl3(jt).NE.0) ihi=ihi+1
10406  DO 500 i=nsd(jt)+1,ihi
10407 CMRENNA---
10408  i1=mint(83)+mint(4)+1
10409  k(i,3)=i1
10410  IF(mstp(128).GE.1) k(i,3)=id
10411  IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
10412  mint(4)=mint(4)+1
10413  k(i1,1)=21
10414  k(i1,2)=k(i,2)
10415  k(i1,3)=iref(ip,jt+3)
10416  DO 490 j=1,5
10417  p(i1,j)=p(i,j)
10418  490 CONTINUE
10419  ENDIF
10420  500 CONTINUE
10421  ELSE
10422  k(i,3)=id
10423  ENDIF
10424 
10425 C...Do showering if any of the two/three products can shower.
10426  nshbef=n
10427  IF(mstp(71).GE.1) THEN
10428  ishow1=0
10429  kfl1a=iabs(kfl1(jt))
10430  IF(kfl1a.LE.22) ishow1=1
10431  ishow2=0
10432  kfl2a=iabs(kfl2(jt))
10433  IF(kfl2a.LE.22) ishow2=1
10434  ishow3=0
10435  IF(kfl3(jt).NE.0) THEN
10436  kfl3a=iabs(kfl3(jt))
10437  IF(kfl3a.LE.22) ishow3=1
10438  ENDIF
10439  IF(ishow1.EQ.0.AND.ishow2.EQ.0.AND.ishow3.EQ.0) THEN
10440  ELSEIF(kfl3(jt).EQ.0) THEN
10441  CALL pyshow(nsd(jt)+1,nsd(jt)+2,p(id,5))
10442  ELSE
10443  nsd1=nsd(jt)+1
10444  nsd2=nsd(jt)+2
10445  IF(ishow1.EQ.0.AND.ishow3.NE.0) THEN
10446  nsd1=nsd(jt)+3
10447  ELSEIF(ishow2.EQ.0.AND.ishow3.NE.0) THEN
10448  nsd2=nsd(jt)+3
10449  ENDIF
10450  pmshow=sqrt(max(0d0,(p(nsd1,4)+p(nsd2,4))**2-
10451  & (p(nsd1,1)+p(nsd2,1))**2-(p(nsd1,2)+p(nsd2,2))**2-
10452  & (p(nsd1,3)+p(nsd2,3))**2))
10453  CALL pyshow(nsd1,nsd2,pmshow)
10454  ENDIF
10455  ENDIF
10456  nshaft=n
10457  IF(jt.EQ.1) naft1=n
10458 
10459 C...Check if decay products moved by shower.
10460  nsd1=nsd(jt)+1
10461  nsd2=nsd(jt)+2
10462  nsd3=nsd(jt)+3
10463  IF(nshaft.GT.nshbef) THEN
10464  IF(k(nsd1,1).GT.10) THEN
10465  DO 510 i=nshbef+1,nshaft
10466  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd1,2)) nsd1=i
10467  510 CONTINUE
10468  ENDIF
10469  IF(k(nsd2,1).GT.10) THEN
10470  DO 520 i=nshbef+1,nshaft
10471  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd2,2).AND.
10472  & i.NE.nsd1) nsd2=i
10473  520 CONTINUE
10474  ENDIF
10475  IF(kfl3(jt).NE.0.AND.k(nsd3,1).GT.10) THEN
10476  DO 530 i=nshbef+1,nshaft
10477  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd3,2).AND.
10478  & i.NE.nsd1.AND.i.NE.nsd2) nsd3=i
10479  530 CONTINUE
10480  ENDIF
10481  ENDIF
10482 
10483 C...Store decay products for further treatment.
10484  np=np+1
10485  iref(np,1)=nsd1
10486  iref(np,2)=nsd2
10487  iref(np,3)=0
10488  IF(kfl3(jt).NE.0) iref(np,3)=nsd3
10489  iref(np,4)=idoc+1
10490  iref(np,5)=idoc+2
10491  iref(np,6)=0
10492  IF(kfl3(jt).NE.0) iref(np,6)=idoc+3
10493  iref(np,7)=k(iref(ip,jt),2)
10494  iref(np,8)=iref(ip,jt)
10495  540 CONTINUE
10496 
10497 C...Fill information for 2 -> 1 -> 2.
10498  550 IF(jtmax.EQ.1.AND.kdcy(1).NE.0.AND.isub.NE.0) THEN
10499  mint(7)=mint(83)+6+2*iset(isub)
10500  mint(8)=mint(83)+7+2*iset(isub)
10501  mint(25)=kfl1(1)
10502  mint(26)=kfl2(1)
10503  vint(23)=cthe(1)
10504  rm3=p(n-1,5)**2/sh
10505  rm4=p(n,5)**2/sh
10506  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
10507  vint(45)=-0.5d0*sh*(1d0-rm3-rm4-be34*cthe(1))
10508  vint(46)=-0.5d0*sh*(1d0-rm3-rm4+be34*cthe(1))
10509  vint(48)=0.25d0*sh*be34**2*max(0d0,1d0-cthe(1)**2)
10510  vint(47)=sqrt(vint(48))
10511  ENDIF
10512 
10513 C...Possibility of colour rearrangement in W+W- events.
10514  IF(isub.EQ.25.AND.mstp(115).GE.1) THEN
10515  iakf1=iabs(kfl1(1))
10516  iakf2=iabs(kfl1(2))
10517  iakf3=iabs(kfl2(1))
10518  iakf4=iabs(kfl2(2))
10519  IF(min(iakf1,iakf2,iakf3,iakf4).GE.1.AND.
10520  & max(iakf1,iakf2,iakf3,iakf4).LE.5) CALL
10521  & pyreco(iref(1,1),iref(1,2),nsd(1),naft1)
10522  ENDIF
10523 
10524 C...Loop back if needed.
10525  560 IF(ip.LT.np) goto 130
10526 
10527  RETURN
10528  END
10529 
10530 C*********************************************************************
10531 
10532 C...PYMULT
10533 C...Initializes treatment of multiple interactions, selects kinematics
10534 C...of hardest interaction if low-pT physics included in run, and
10535 C...generates all non-hardest interactions.
10536 
10537  SUBROUTINE pymult(MMUL)
10538 
10539 C...Double precision and integer declarations.
10540  IMPLICIT DOUBLE PRECISION(a-h, o-z)
10541  INTEGER pyk,pychge,pycomp
10542 C...Commonblocks.
10543  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10544  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
10545  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
10546  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
10547  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10548  common/pyint1/mint(400),vint(400)
10549  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
10550  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
10551  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
10552  common/pyint7/sigt(0:6,0:6,0:5)
10553  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
10554  &/pyint2/,/pyint3/,/pyint5/,/pyint7/
10555 C...Local arrays and saved variables.
10556  dimension nmul(20),sigm(20),kstr(500,2),vintsv(80)
10557  SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm
10558 
10559 C...Initialization of multiple interaction treatment.
10560  IF(mmul.EQ.1) THEN
10561  IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
10562  isub=96
10563  mint(1)=96
10564  vint(63)=0d0
10565  vint(64)=0d0
10566  vint(143)=1d0
10567  vint(144)=1d0
10568 
10569 C...Loop over phase space points: xT2 choice in 20 bins.
10570  100 sigsum=0d0
10571  DO 120 ixt2=1,20
10572  nmul(ixt2)=mstp(83)
10573  sigm(ixt2)=0d0
10574  DO 110 itry=1,mstp(83)
10575  rsca=0.05d0*((21-ixt2)-pyr(0))
10576  xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
10577  xt2=max(0.01d0*vint(149),xt2)
10578  vint(25)=xt2
10579 
10580 C...Choose tau and y*. Calculate cos(theta-hat).
10581  IF(pyr(0).LE.coef(isub,1)) THEN
10582  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
10583  tau=xt2*(1d0+taut)**2/(4d0*taut)
10584  ELSE
10585  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
10586  ENDIF
10587  vint(21)=tau
10588  CALL pyklim(2)
10589  ryst=pyr(0)
10590  myst=1
10591  IF(ryst.GT.coef(isub,8)) myst=2
10592  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
10593  CALL pykmap(2,myst,pyr(0))
10594  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
10595 
10596 C...Calculate differential cross-section.
10597  vint(71)=0.5d0*vint(1)*sqrt(xt2)
10598  CALL pysigh(nchn,sigs)
10599  sigm(ixt2)=sigm(ixt2)+sigs
10600  110 CONTINUE
10601  sigsum=sigsum+sigm(ixt2)
10602  120 CONTINUE
10603  sigsum=sigsum/(20d0*mstp(83))
10604 
10605 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
10606  IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
10607  IF(mstp(122).GE.1) WRITE(mstu(11),5100) parp(82),sigsum
10608  parp(82)=0.9d0*parp(82)
10609  vint(149)=4d0*parp(82)**2/vint(2)
10610  goto 100
10611  ENDIF
10612  IF(mstp(122).GE.1) WRITE(mstu(11),5200) parp(82), sigsum
10613 
10614 C...Start iteration to find k factor.
10615  yke=sigsum/sigt(0,0,5)
10616  so=0.5d0
10617  xi=0d0
10618  yi=0d0
10619  xf=0d0
10620  yf=0d0
10621  xk=0.5d0
10622  iit=0
10623  130 IF(iit.EQ.0) THEN
10624  xk=2d0*xk
10625  ELSEIF(iit.EQ.1) THEN
10626  xk=0.5d0*xk
10627  ELSE
10628  xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
10629  ENDIF
10630 
10631 C...Evaluate overlap integrals.
10632  IF(mstp(82).EQ.2) THEN
10633  sp=0.5d0*paru(1)*(1d0-exp(-xk))
10634  sop=sp/paru(1)
10635  ELSE
10636  IF(mstp(82).EQ.3) deltab=0.02d0
10637  IF(mstp(82).EQ.4) deltab=min(0.01d0,0.05d0*parp(84))
10638  sp=0d0
10639  sop=0d0
10640  b=-0.5d0*deltab
10641  140 b=b+deltab
10642  IF(mstp(82).EQ.3) THEN
10643  ov=exp(-b**2)/paru(2)
10644  ELSE
10645  cq2=parp(84)**2
10646  ov=((1d0-parp(83))**2*exp(-min(50d0,b**2))+
10647  & 2d0*parp(83)*(1d0-parp(83))*2d0/(1d0+cq2)*
10648  & exp(-min(50d0,b**2*2d0/(1d0+cq2)))+
10649  & parp(83)**2/cq2*exp(-min(50d0,b**2/cq2)))/paru(2)
10650  ENDIF
10651  pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
10652  sp=sp+paru(2)*b*deltab*pacc
10653  sop=sop+paru(2)*b*deltab*ov*pacc
10654  IF(b.LT.1d0.OR.b*pacc.GT.1d-6) goto 140
10655  ENDIF
10656  yk=paru(1)*xk*so/sp
10657 
10658 C...Continue iteration until convergence.
10659  IF(yk.LT.yke) THEN
10660  xi=xk
10661  yi=yk
10662  IF(iit.EQ.1) iit=2
10663  ELSE
10664  xf=xk
10665  yf=yk
10666  IF(iit.EQ.0) iit=1
10667  ENDIF
10668  IF(abs(yk-yke).GE.1d-5*yke) goto 130
10669 
10670 C...Store some results for subsequent use.
10671  vint(145)=sigsum
10672  vint(146)=sop/so
10673  vint(147)=sop/sp
10674 
10675 C...Initialize iteration in xT2 for hardest interaction.
10676  ELSEIF(mmul.EQ.2) THEN
10677  IF(mstp(82).LE.0) THEN
10678  ELSEIF(mstp(82).EQ.1) THEN
10679  xt2=1d0
10680  xt2fac=xsec(96,1)/sigt(0,0,5)*vint(149)/(1d0-vint(149))
10681  ELSEIF(mstp(82).EQ.2) THEN
10682  xt2=1d0
10683  xt2fac=vint(146)*xsec(96,1)/sigt(0,0,5)*vint(149)*
10684  & (1d0+vint(149))
10685  ELSE
10686  xc2=4d0*ckin(3)**2/vint(2)
10687  IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
10688  ENDIF
10689 
10690  ELSEIF(mmul.EQ.3) THEN
10691 C...Low-pT or multiple interactions (first semihard interaction):
10692 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
10693 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
10694  isub=mint(1)
10695  IF(mstp(82).LE.0) THEN
10696  xt2=0d0
10697  ELSEIF(mstp(82).EQ.1) THEN
10698  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
10699  ELSEIF(mstp(82).EQ.2) THEN
10700  IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
10701  & vint(149)))).GT.pyr(0)) xt2=1d0
10702  IF(xt2.GE.1d0) THEN
10703  xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
10704  & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
10705  & vint(149)
10706  ELSE
10707  xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
10708  & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
10709  & vint(149)
10710  ENDIF
10711  xt2=max(0.01d0*vint(149),xt2)
10712  ELSE
10713  xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
10714  & pyr(0)*(1d0-xc2))-vint(149)
10715  xt2=max(0.01d0*vint(149),xt2)
10716  ENDIF
10717  vint(25)=xt2
10718 
10719 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
10720  IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
10721  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-1
10722  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-1
10723  isub=95
10724  mint(1)=isub
10725  vint(21)=0.01d0*vint(149)
10726  vint(22)=0d0
10727  vint(23)=0d0
10728  vint(25)=0.01d0*vint(149)
10729 
10730  ELSE
10731 C...Multiple interactions (first semihard interaction).
10732 C...Choose tau and y*. Calculate cos(theta-hat).
10733  IF(pyr(0).LE.coef(isub,1)) THEN
10734  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
10735  tau=xt2*(1d0+taut)**2/(4d0*taut)
10736  ELSE
10737  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
10738  ENDIF
10739  vint(21)=tau
10740  CALL pyklim(2)
10741  ryst=pyr(0)
10742  myst=1
10743  IF(ryst.GT.coef(isub,8)) myst=2
10744  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
10745  CALL pykmap(2,myst,pyr(0))
10746  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
10747  ENDIF
10748  vint(71)=0.5d0*vint(1)*sqrt(vint(25))
10749 
10750 C...Store results of cross-section calculation.
10751  ELSEIF(mmul.EQ.4) THEN
10752  isub=mint(1)
10753  xts=vint(25)
10754  IF(iset(isub).EQ.1) xts=vint(21)
10755  IF(iset(isub).EQ.2)
10756  & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
10757  IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
10758  rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
10759  & (xts+vint(149))))
10760  irbin=int(1d0+20d0*rbin)
10761  IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
10762  nmul(irbin)=nmul(irbin)+1
10763  sigm(irbin)=sigm(irbin)+vint(153)
10764  ENDIF
10765 
10766 C...Choose impact parameter.
10767  ELSEIF(mmul.EQ.5) THEN
10768  IF(mstp(82).EQ.3) THEN
10769  vint(148)=pyr(0)/(paru(2)*vint(147))
10770  ELSE
10771  rtype=pyr(0)
10772  cq2=parp(84)**2
10773  IF(rtype.LT.(1d0-parp(83))**2) THEN
10774  b2=-log(pyr(0))
10775  ELSEIF(rtype.LT.1d0-parp(83)**2) THEN
10776  b2=-0.5d0*(1d0+cq2)*log(pyr(0))
10777  ELSE
10778  b2=-cq2*log(pyr(0))
10779  ENDIF
10780  vint(148)=((1d0-parp(83))**2*exp(-min(50d0,b2))+2d0*parp(83)*
10781  & (1d0-parp(83))*2d0/(1d0+cq2)*exp(-min(50d0,b2*2d0/(1d0+cq2)))+
10782  & parp(83)**2/cq2*exp(-min(50d0,b2/cq2)))/(paru(2)*vint(147))
10783  ENDIF
10784 
10785 C...Multiple interactions (variable impact parameter) : reject with
10786 C...probability exp(-overlap*cross-section above pT/normalization).
10787  rncor=(irbin-20d0*rbin)*nmul(irbin)
10788  sigcor=(irbin-20d0*rbin)*sigm(irbin)
10789  DO 150 ibin=irbin+1,20
10790  rncor=rncor+nmul(ibin)
10791  sigcor=sigcor+sigm(ibin)
10792  150 CONTINUE
10793  sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
10794  IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
10795  vint(150)=exp(-min(50d0,vint(146)*vint(148)*
10796  & sigabv/sigt(0,0,5)))
10797 
10798 C...Generate additional multiple semihard interactions.
10799  ELSEIF(mmul.EQ.6) THEN
10800  isubsv=mint(1)
10801  DO 160 j=11,80
10802  vintsv(j)=vint(j)
10803  160 CONTINUE
10804  isub=96
10805  mint(1)=96
10806 
10807 C...Reconstruct strings in hard scattering.
10808  nmax=mint(84)+4
10809  IF(iset(isubsv).EQ.1) nmax=mint(84)+2
10810  IF(iset(isubsv).EQ.11) nmax=mint(84)+2+mint(3)
10811  nstr=0
10812  DO 180 i=mint(84)+1,nmax
10813  kcs=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
10814  IF(kcs.EQ.0) goto 180
10815 
10816  DO 170 j=1,4
10817  IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) goto 170
10818  IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) goto 170
10819  IF(j.LE.2) THEN
10820  ist=mod(k(i,j+3)/mstu(5),mstu(5))
10821  ELSE
10822  ist=mod(k(i,j+1),mstu(5))
10823  ENDIF
10824  IF(ist.LT.mint(84).OR.ist.GT.i) goto 170
10825  IF(kchg(pycomp(k(ist,2)),2).EQ.0) goto 170
10826  nstr=nstr+1
10827  IF(j.EQ.1.OR.j.EQ.4) THEN
10828  kstr(nstr,1)=i
10829  kstr(nstr,2)=ist
10830  ELSE
10831  kstr(nstr,1)=ist
10832  kstr(nstr,2)=i
10833  ENDIF
10834  170 CONTINUE
10835  180 CONTINUE
10836 
10837 C...Set up starting values for iteration in xT2.
10838  xt2=vint(25)
10839  IF(iset(isubsv).EQ.1) xt2=vint(21)
10840  IF(iset(isubsv).EQ.2)
10841  & xt2=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
10842  IF(iset(isubsv).GE.3.AND.iset(isubsv).LE.5) xt2=vint(26)
10843  IF(mstp(82).LE.1) THEN
10844  xt2fac=xsec(isub,1)*vint(149)/((1d0-vint(149))*sigt(0,0,5))
10845  ELSE
10846  xt2fac=vint(146)*vint(148)*xsec(isub,1)/sigt(0,0,5)*
10847  & vint(149)*(1d0+vint(149))
10848  ENDIF
10849  vint(63)=0d0
10850  vint(64)=0d0
10851  vint(143)=1d0-vint(141)
10852  vint(144)=1d0-vint(142)
10853 
10854 C...Iterate downwards in xT2.
10855  190 IF(mstp(82).LE.1) THEN
10856  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
10857  IF(xt2.LT.vint(149)) goto 240
10858  ELSE
10859  IF(xt2.LE.0.01001d0*vint(149)) goto 240
10860  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
10861  & log(pyr(0)))-vint(149)
10862  IF(xt2.LE.0d0) goto 240
10863  xt2=max(0.01d0*vint(149),xt2)
10864  ENDIF
10865  vint(25)=xt2
10866 
10867 C...Choose tau and y*. Calculate cos(theta-hat).
10868  IF(pyr(0).LE.coef(isub,1)) THEN
10869  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
10870  tau=xt2*(1d0+taut)**2/(4d0*taut)
10871  ELSE
10872  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
10873  ENDIF
10874  vint(21)=tau
10875  CALL pyklim(2)
10876  ryst=pyr(0)
10877  myst=1
10878  IF(ryst.GT.coef(isub,8)) myst=2
10879  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
10880  CALL pykmap(2,myst,pyr(0))
10881  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
10882 
10883 C...Check that x not used up. Accept or reject kinematical variables.
10884  x1m=sqrt(tau)*exp(vint(22))
10885  x2m=sqrt(tau)*exp(-vint(22))
10886  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) goto 190
10887  vint(71)=0.5d0*vint(1)*sqrt(xt2)
10888  CALL pysigh(nchn,sigs)
10889  IF(sigs.LT.xsec(isub,1)*pyr(0)) goto 190
10890 
10891 C...Reset K, P and V vectors. Select some variables.
10892  DO 210 i=n+1,n+2
10893  DO 200 j=1,5
10894  k(i,j)=0
10895  p(i,j)=0d0
10896  v(i,j)=0d0
10897  200 CONTINUE
10898  210 CONTINUE
10899  rflav=pyr(0)
10900  pt=0.5d0*vint(1)*sqrt(xt2)
10901  phi=paru(2)*pyr(0)
10902  cth=vint(23)
10903 
10904 C...Add first parton to event record.
10905  k(n+1,1)=3
10906  k(n+1,2)=21
10907  IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=
10908  & 1+int((2d0+parj(2))*pyr(0))
10909  p(n+1,1)=pt*cos(phi)
10910  p(n+1,2)=pt*sin(phi)
10911  p(n+1,3)=0.25d0*vint(1)*(vint(41)*(1d0+cth)-vint(42)*(1d0-cth))
10912  p(n+1,4)=0.25d0*vint(1)*(vint(41)*(1d0+cth)+vint(42)*(1d0-cth))
10913  p(n+1,5)=0d0
10914 
10915 C...Add second parton to event record.
10916  k(n+2,1)=3
10917  k(n+2,2)=21
10918  IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)
10919  p(n+2,1)=-p(n+1,1)
10920  p(n+2,2)=-p(n+1,2)
10921  p(n+2,3)=0.25d0*vint(1)*(vint(41)*(1d0-cth)-vint(42)*(1d0+cth))
10922  p(n+2,4)=0.25d0*vint(1)*(vint(41)*(1d0-cth)+vint(42)*(1d0+cth))
10923  p(n+2,5)=0d0
10924 
10925  IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN
10926 C....Choose relevant string pieces to place gluons on.
10927  DO 230 i=n+1,n+2
10928  dmin=1d8
10929  DO 220 istr=1,nstr
10930  i1=kstr(istr,1)
10931  i2=kstr(istr,2)
10932  dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-
10933  & p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-
10934  & p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1d0,p(i1,4)*p(i2,4)-
10935  & p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))
10936  IF(istr.EQ.1.OR.dist.LT.dmin) THEN
10937  dmin=dist
10938  ist1=i1
10939  ist2=i2
10940  istm=istr
10941  ENDIF
10942  220 CONTINUE
10943 
10944 C....Colour flow adjustments, new string pieces.
10945  IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+
10946  & mod(k(ist1,4),mstu(5))
10947  IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=
10948  & mstu(5)*(k(ist1,5)/mstu(5))+i
10949  k(i,5)=mstu(5)*ist1
10950  k(i,4)=mstu(5)*ist2
10951  IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+
10952  & mod(k(ist2,5),mstu(5))
10953  IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=
10954  & mstu(5)*(k(ist2,4)/mstu(5))+i
10955  kstr(istm,2)=i
10956  kstr(nstr+1,1)=i
10957  kstr(nstr+1,2)=ist2
10958  nstr=nstr+1
10959  230 CONTINUE
10960 
10961 C...String drawing and colour flow for gluon loop.
10962  ELSEIF(k(n+1,2).EQ.21) THEN
10963  k(n+1,4)=mstu(5)*(n+2)
10964  k(n+1,5)=mstu(5)*(n+2)
10965  k(n+2,4)=mstu(5)*(n+1)
10966  k(n+2,5)=mstu(5)*(n+1)
10967  kstr(nstr+1,1)=n+1
10968  kstr(nstr+1,2)=n+2
10969  kstr(nstr+2,1)=n+2
10970  kstr(nstr+2,2)=n+1
10971  nstr=nstr+2
10972 
10973 C...String drawing and colour flow for qqbar pair.
10974  ELSE
10975  k(n+1,4)=mstu(5)*(n+2)
10976  k(n+2,5)=mstu(5)*(n+1)
10977  kstr(nstr+1,1)=n+1
10978  kstr(nstr+1,2)=n+2
10979  nstr=nstr+1
10980  ENDIF
10981 
10982 C...Update remaining energy; iterate.
10983  n=n+2
10984  IF(n.GT.mstu(4)-mstu(32)-10) THEN
10985  CALL pyerrm(11,'(PYMULT:) no more memory left in PYJETS')
10986  IF(mstu(21).GE.1) RETURN
10987  ENDIF
10988  mint(31)=mint(31)+1
10989  vint(151)=vint(151)+vint(41)
10990  vint(152)=vint(152)+vint(42)
10991  vint(143)=vint(143)-vint(41)
10992  vint(144)=vint(144)-vint(42)
10993  IF(mint(31).LT.240) goto 190
10994  240 CONTINUE
10995  mint(1)=isubsv
10996  DO 250 j=11,80
10997  vint(j)=vintsv(j)
10998  250 CONTINUE
10999  ENDIF
11000 
11001 C...Format statements for printout.
11002  5000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',
11003  &'actions for MSTP(82) =',i2,' ******')
11004  5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
11005  &d9.2,' mb: rejected')
11006  5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
11007  &d9.2,' mb: accepted')
11008 
11009  RETURN
11010  END
11011 
11012 C*********************************************************************
11013 
11014 C...PYREMN
11015 C...Adds on target remnants (one or two from each side) and
11016 C...includes primordial kT for hadron beams.
11017 
11018  SUBROUTINE pyremn(IPU1,IPU2)
11019 
11020 C...Double precision and integer declarations.
11021  IMPLICIT DOUBLE PRECISION(a-h, o-z)
11022  INTEGER pyk,pychge,pycomp
11023 C...Commonblocks.
11024  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
11025  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
11026  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
11027  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11028  common/pyint1/mint(400),vint(400)
11029  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
11030 C...Local arrays.
11031  dimension kflch(2),kflsp(2),chi(2),pms(0:6),is(2),isn(2),robo(5),
11032  &psys(0:2,5),pmin(0:2),qold(4),qnew(4),dbe(3),psum(4)
11033 
11034 C...Find event type and remaining energy.
11035  isub=mint(1)
11036  ns=n
11037  IF(mint(50).EQ.0.OR.mstp(81).LE.0) THEN
11038  vint(143)=1d0-vint(141)
11039  vint(144)=1d0-vint(142)
11040  ENDIF
11041 
11042 C...Define initial partons.
11043  ntry=0
11044  100 ntry=ntry+1
11045  DO 130 jt=1,2
11046  i=mint(83)+jt+2
11047  IF(jt.EQ.1) ipu=ipu1
11048  IF(jt.EQ.2) ipu=ipu2
11049  k(i,1)=21
11050  k(i,2)=k(ipu,2)
11051  k(i,3)=i-2
11052  pms(jt)=0d0
11053  vint(156+jt)=0d0
11054  vint(158+jt)=0d0
11055  IF(mint(47).EQ.1) THEN
11056  DO 110 j=1,5
11057  p(i,j)=p(i-2,j)
11058  110 CONTINUE
11059  ELSEIF(isub.EQ.95) THEN
11060  k(i,2)=21
11061  ELSE
11062  p(i,5)=p(ipu,5)
11063 
11064 C...No primordial kT, or chosen according to truncated Gaussian or
11065 C...exponential, or (for photon) predetermined or power law.
11066  120 IF(mint(40+jt).EQ.2.AND.mint(10+jt).NE.22) THEN
11067  IF(mstp(91).LE.0) THEN
11068  pt=0d0
11069  ELSEIF(mstp(91).EQ.1) THEN
11070  pt=parp(91)*sqrt(-log(pyr(0)))
11071  ELSE
11072  rpt1=pyr(0)
11073  rpt2=pyr(0)
11074  pt=-parp(92)*log(rpt1*rpt2)
11075  ENDIF
11076  IF(pt.GT.parp(93)) goto 120
11077  ELSEIF(mint(106+jt).EQ.3) THEN
11078  pt=sqrt(vint(282+jt))
11079  pt=pt*0.8d0**mint(57)
11080  IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
11081  ELSEIF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) THEN
11082  IF(mstp(93).LE.0) THEN
11083  pt=0d0
11084  ELSEIF(mstp(93).EQ.1) THEN
11085  pt=parp(99)*sqrt(-log(pyr(0)))
11086  ELSEIF(mstp(93).EQ.2) THEN
11087  rpt1=pyr(0)
11088  rpt2=pyr(0)
11089  pt=-parp(99)*log(rpt1*rpt2)
11090  ELSEIF(mstp(93).EQ.3) THEN
11091  ha=parp(99)**2
11092  hb=parp(100)**2
11093  pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
11094  ELSE
11095  ha=parp(99)**2
11096  hb=parp(100)**2
11097  IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
11098  pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
11099  ENDIF
11100  IF(pt.GT.parp(100)) goto 120
11101  ELSE
11102  pt=0d0
11103  ENDIF
11104  vint(156+jt)=pt
11105  phi=paru(2)*pyr(0)
11106  p(i,1)=pt*cos(phi)
11107  p(i,2)=pt*sin(phi)
11108  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
11109  ENDIF
11110  130 CONTINUE
11111  IF(mint(47).EQ.1) RETURN
11112 
11113 C...Kinematics construction for initial partons.
11114  i1=mint(83)+3
11115  i2=mint(83)+4
11116  IF(isub.EQ.95) THEN
11117  shs=0d0
11118  shr=0d0
11119  ELSE
11120  shs=vint(141)*vint(142)*vint(2)+(p(i1,1)+p(i2,1))**2+
11121  & (p(i1,2)+p(i2,2))**2
11122  shr=sqrt(max(0d0,shs))
11123  IF((shs-pms(1)-pms(2))**2-4d0*pms(1)*pms(2).LE.0d0) goto 100
11124  p(i1,4)=0.5d0*(shr+(pms(1)-pms(2))/shr)
11125  p(i1,3)=sqrt(max(0d0,p(i1,4)**2-pms(1)))
11126  p(i2,4)=shr-p(i1,4)
11127  p(i2,3)=-p(i1,3)
11128 
11129 C...Transform partons to overall CM-frame.
11130  robo(3)=(p(i1,1)+p(i2,1))/shr
11131  robo(4)=(p(i1,2)+p(i2,2))/shr
11132  CALL pyrobo(i1,i2,0d0,0d0,-robo(3),-robo(4),0d0)
11133  robo(2)=pyangl(p(i1,1),p(i1,2))
11134  CALL pyrobo(i1,i2,0d0,-robo(2),0d0,0d0,0d0)
11135  robo(1)=pyangl(p(i1,3),p(i1,1))
11136  CALL pyrobo(i1,i2,-robo(1),0d0,0d0,0d0,0d0)
11137  CALL pyrobo(i1,mint(52),robo(1),robo(2),robo(3),robo(4),0d0)
11138  robo(5)=max(-0.999999d0,min(0.999999d0,(vint(141)-vint(142))/
11139  & (vint(141)+vint(142))))
11140  CALL pyrobo(i1,mint(52),0d0,0d0,0d0,0d0,robo(5))
11141  ENDIF
11142 
11143 C...Optionally fix up x and Q2 definitions for leptoproduction.
11144  idisxq=0
11145  IF((mint(43).EQ.2.OR.mint(43).EQ.3).AND.((isub.EQ.10.AND.
11146  &mstp(23).GE.1).OR.(isub.EQ.83.AND.mstp(23).GE.2))) idisxq=1
11147  IF(idisxq.EQ.1) THEN
11148 
11149 C...Find where incoming and outgoing leptons/partons are sitting.
11150  lesd=1
11151  IF(mint(42).EQ.1) lesd=2
11152  lpin=mint(83)+3-lesd
11153  lein=mint(84)+lesd
11154  lqin=mint(84)+3-lesd
11155  leout=mint(84)+2+lesd
11156  lqout=mint(84)+5-lesd
11157  IF(k(lein,3).GT.lein) lein=k(lein,3)
11158  IF(k(lqin,3).GT.lqin) lqin=k(lqin,3)
11159  lscms=0
11160  DO 140 i=mint(84)+5,n
11161  IF(k(i,2).EQ.94) THEN
11162  lscms=i
11163  leout=i+lesd
11164  lqout=i+3-lesd
11165  ENDIF
11166  140 CONTINUE
11167  lqbg=ipu1
11168  IF(lesd.EQ.1) lqbg=ipu2
11169 
11170 C...Calculate actual and wanted momentum transfer.
11171  xnom=vint(43-lesd)
11172  q2nom=-vint(45)
11173  hpk=2d0*(p(lpin,4)*p(lein,4)-p(lpin,1)*p(lein,1)-
11174  & p(lpin,2)*p(lein,2)-p(lpin,3)*p(lein,3))*
11175  & (p(mint(83)+lesd,4)*vint(40+lesd)/p(lein,4))
11176  hpt2=max(0d0,q2nom*(1d0-q2nom/(xnom*hpk)))
11177  fac=sqrt(hpt2/(p(leout,1)**2+p(leout,2)**2))
11178  p(n+1,1)=fac*p(leout,1)
11179  p(n+1,2)=fac*p(leout,2)
11180  p(n+1,3)=0.25d0*((hpk-q2nom/xnom)/p(lpin,4)-
11181  & q2nom/(p(mint(83)+lesd,4)*vint(40+lesd)))*(-1)**(lesd+1)
11182  p(n+1,4)=sqrt(p(leout,5)**2+p(n+1,1)**2+p(n+1,2)**2+
11183  & p(n+1,3)**2)
11184  DO 150 j=1,4
11185  qold(j)=p(lein,j)-p(leout,j)
11186  qnew(j)=p(lein,j)-p(n+1,j)
11187  150 CONTINUE
11188 
11189 C...Boost outgoing electron and daughters.
11190  IF(lscms.EQ.0) THEN
11191  DO 160 j=1,4
11192  p(leout,j)=p(n+1,j)
11193  160 CONTINUE
11194  ELSE
11195  DO 170 j=1,3
11196  p(n+2,j)=(p(n+1,j)-p(leout,j))/(p(n+1,4)+p(leout,4))
11197  170 CONTINUE
11198  pinv=2d0/(1d0+p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2)
11199  DO 180 j=1,3
11200  dbe(j)=pinv*p(n+2,j)
11201  180 CONTINUE
11202  DO 200 i=lscms+1,n
11203  iorig=i
11204  190 iorig=k(iorig,3)
11205  IF(iorig.GT.leout) goto 190
11206  IF(i.EQ.leout.OR.iorig.EQ.leout)
11207  & CALL pyrobo(i,i,0d0,0d0,dbe(1),dbe(2),dbe(3))
11208  200 CONTINUE
11209  ENDIF
11210 
11211 C...Copy shower initiator and all outgoing partons.
11212  ncop=n+1
11213  k(ncop,3)=lqbg
11214  DO 210 j=1,5
11215  p(ncop,j)=p(lqbg,j)
11216  210 CONTINUE
11217  DO 240 i=mint(84)+1,n
11218  icop=0
11219  IF(k(i,1).GT.10) goto 240
11220  IF(i.EQ.lqbg.OR.i.EQ.lqout) THEN
11221  icop=i
11222  ELSE
11223  iorig=i
11224  220 iorig=k(iorig,3)
11225  IF(iorig.EQ.lqbg.OR.iorig.EQ.lqout) THEN
11226  icop=iorig
11227  ELSEIF(iorig.GT.mint(84).AND.iorig.LE.n) THEN
11228  goto 220
11229  ENDIF
11230  ENDIF
11231  IF(icop.NE.0) THEN
11232  ncop=ncop+1
11233  k(ncop,3)=i
11234  DO 230 j=1,5
11235  p(ncop,j)=p(i,j)
11236  230 CONTINUE
11237  ENDIF
11238  240 CONTINUE
11239 
11240 C...Calculate relative rescaling factors.
11241  slc=3-2*lesd
11242  plcsum=0d0
11243  DO 250 i=n+2,ncop
11244  plcsum=plcsum+(p(i,4)+slc*p(i,3))
11245  250 CONTINUE
11246  DO 260 i=n+2,ncop
11247  v(i,1)=(p(i,4)+slc*p(i,3))/plcsum
11248  260 CONTINUE
11249 
11250 C...Transfer extra three-momentum of current.
11251  DO 280 i=n+2,ncop
11252  DO 270 j=1,3
11253  p(i,j)=p(i,j)+v(i,1)*(qnew(j)-qold(j))
11254  270 CONTINUE
11255  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
11256  280 CONTINUE
11257 
11258 C...Iterate change of initiator momentum to get energy right.
11259  iter=0
11260  290 iter=iter+1
11261  peex=-p(n+1,4)-qnew(4)
11262  pemv=-p(n+1,3)/p(n+1,4)
11263  DO 300 i=n+2,ncop
11264  peex=peex+p(i,4)
11265  pemv=pemv+v(i,1)*p(i,3)/p(i,4)
11266  300 CONTINUE
11267  IF(abs(pemv).LT.1d-10) THEN
11268  mint(51)=1
11269  mint(57)=mint(57)+1
11270  RETURN
11271  ENDIF
11272  pzch=-peex/pemv
11273  p(n+1,3)=p(n+1,3)+pzch
11274  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)
11275  DO 310 i=n+2,ncop
11276  p(i,3)=p(i,3)+v(i,1)*pzch
11277  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
11278  310 CONTINUE
11279  IF(iter.LT.10.AND.abs(peex).GT.1d-6*p(n+1,4)) goto 290
11280 
11281 C...Modify momenta in event record.
11282  hbe=2d0*(p(n+1,4)+p(lqbg,4))*(p(n+1,3)-p(lqbg,3))/
11283  & ((p(n+1,4)+p(lqbg,4))**2+(p(n+1,3)-p(lqbg,3))**2)
11284  IF(abs(hbe).GT.0.999999d0) THEN
11285  mint(51)=1
11286  mint(57)=mint(57)+1
11287  RETURN
11288  ENDIF
11289  i=mint(83)+5-lesd
11290  CALL pyrobo(i,i,0d0,0d0,0d0,0d0,hbe)
11291  DO 330 i=n+1,ncop
11292  icop=k(i,3)
11293  DO 320 j=1,4
11294  p(icop,j)=p(i,j)
11295  320 CONTINUE
11296  330 CONTINUE
11297  ENDIF
11298 
11299 C...Check minimum invariant mass of remnant system(s).
11300  psys(0,4)=p(i1,4)+p(i2,4)+0.5d0*vint(1)*(vint(151)+vint(152))
11301  psys(0,3)=p(i1,3)+p(i2,3)+0.5d0*vint(1)*(vint(151)-vint(152))
11302  pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
11303  pmin(0)=sqrt(pms(0))
11304  DO 340 jt=1,2
11305  psys(jt,4)=0.5d0*vint(1)*vint(142+jt)
11306  psys(jt,3)=psys(jt,4)*(-1)**(jt-1)
11307  pmin(jt)=0d0
11308  IF(mint(44+jt).EQ.1) goto 340
11309  mint(105)=mint(102+jt)
11310  mint(109)=mint(106+jt)
11311  CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))
11312  IF(kflch(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflch(jt))
11313  IF(kflsp(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflsp(jt))
11314  IF(kflch(jt)*kflsp(jt).NE.0) pmin(jt)=pmin(jt)+0.5d0*parp(111)
11315  pmin(jt)=sqrt(pmin(jt)**2+p(mint(83)+jt+2,1)**2+
11316  & p(mint(83)+jt+2,2)**2)
11317  340 CONTINUE
11318  IF(pmin(0)+pmin(1)+pmin(2).GT.vint(1).OR.(mint(45).GE.2.AND.
11319  &pmin(1).GT.psys(1,4)).OR.(mint(46).GE.2.AND.pmin(2).GT.
11320  &psys(2,4))) THEN
11321  mint(51)=1
11322  mint(57)=mint(57)+1
11323  RETURN
11324  ENDIF
11325 
11326 C...Loop over two remnants; skip if none there.
11327  i=ns
11328  DO 410 jt=1,2
11329  isn(jt)=0
11330  IF(mint(44+jt).EQ.1) goto 410
11331  IF(jt.EQ.1) ipu=ipu1
11332  IF(jt.EQ.2) ipu=ipu2
11333 
11334 C...Store first remnant parton.
11335  i=i+1
11336  is(jt)=i
11337  isn(jt)=1
11338  DO 350 j=1,5
11339  k(i,j)=0
11340  p(i,j)=0d0
11341  v(i,j)=0d0
11342  350 CONTINUE
11343  k(i,1)=1
11344  k(i,2)=kflsp(jt)
11345  k(i,3)=mint(83)+jt
11346  p(i,5)=pymass(k(i,2))
11347 
11348 C...First parton colour connections and kinematics.
11349  kcol=kchg(pycomp(kflsp(jt)),2)
11350  IF(kcol.EQ.2) THEN
11351  k(i,1)=3
11352  k(i,4)=mstu(5)*ipu+ipu
11353  k(i,5)=mstu(5)*ipu+ipu
11354  k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
11355  k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
11356  ELSEIF(kcol.NE.0) THEN
11357  k(i,1)=3
11358  kfls=(3-kcol*isign(1,kflsp(jt)))/2
11359  k(i,kfls+3)=ipu
11360  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
11361  ENDIF
11362  IF(kflch(jt).EQ.0) THEN
11363  p(i,1)=-p(mint(83)+jt+2,1)
11364  p(i,2)=-p(mint(83)+jt+2,2)
11365  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
11366  psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
11367  p(i,3)=psys(jt,3)
11368  p(i,4)=psys(jt,4)
11369 
11370 C...When extra remnant parton or hadron: store extra remnant.
11371  ELSE
11372  i=i+1
11373  isn(jt)=2
11374  DO 360 j=1,5
11375  k(i,j)=0
11376  p(i,j)=0d0
11377  v(i,j)=0d0
11378  360 CONTINUE
11379  k(i,1)=1
11380  k(i,2)=kflch(jt)
11381  k(i,3)=mint(83)+jt
11382  p(i,5)=pymass(k(i,2))
11383 
11384 C...Find parton colour connections of extra remnant.
11385  kcol=kchg(pycomp(kflch(jt)),2)
11386  IF(kcol.EQ.2) THEN
11387  k(i,1)=3
11388  k(i,4)=mstu(5)*ipu+ipu
11389  k(i,5)=mstu(5)*ipu+ipu
11390  k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
11391  k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
11392  ELSEIF(kcol.NE.0) THEN
11393  k(i,1)=3
11394  kfls=(3-kcol*isign(1,kflch(jt)))/2
11395  k(i,kfls+3)=ipu
11396  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
11397  ENDIF
11398 
11399 C...Relative transverse momentum when two remnants.
11400  loop=0
11401  370 loop=loop+1
11402  CALL pyptdi(1,p(i-1,1),p(i-1,2))
11403  IF(iabs(mint(10+jt)).LT.20) THEN
11404  p(i-1,1)=0d0
11405  p(i-1,2)=0d0
11406  ENDIF
11407  pms(jt+2)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
11408  p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)
11409  p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)
11410  pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
11411 
11412 C...Meson or baryon; photon as meson. For splitup below.
11413  imb=1
11414  IF(mod(mint(10+jt)/1000,10).NE.0) imb=2
11415 
11416 C***Relative distribution for electron into two electrons. Temporary!
11417  IF(iabs(mint(10+jt)).LT.20.AND.mint(14+jt).EQ.-mint(10+jt))
11418  & THEN
11419  chi(jt)=pyr(0)
11420 
11421 C...Relative distribution of electron energy into electron plus parton.
11422  ELSEIF(iabs(mint(10+jt)).LT.20) THEN
11423  xhrd=vint(140+jt)
11424  xe=vint(154+jt)
11425  chi(jt)=(xe-xhrd)/(1d0-xhrd)
11426 
11427 C...Relative distribution of energy for particle into two jets.
11428  ELSEIF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN
11429  chik=parp(92+2*imb)
11430  IF(mstp(92).LE.1) THEN
11431  IF(imb.EQ.1) chi(jt)=pyr(0)
11432  IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
11433  ELSEIF(mstp(92).EQ.2) THEN
11434  chi(jt)=1d0-pyr(0)**(1d0/(1d0+chik))
11435  ELSEIF(mstp(92).EQ.3) THEN
11436  cut=2d0*0.3d0/vint(1)
11437  380 chi(jt)=pyr(0)**2
11438  IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25d0*
11439  & (1d0-chi(jt))**chik.LT.pyr(0)) goto 380
11440  ELSEIF(mstp(92).EQ.4) THEN
11441  cut=2d0*0.3d0/vint(1)
11442  cutr=(1d0+sqrt(1d0+cut**2))/cut
11443  390 chir=cut*cutr**pyr(0)
11444  chi(jt)=(chir**2-cut**2)/(2d0*chir)
11445  IF((1d0-chi(jt))**chik.LT.pyr(0)) goto 390
11446  ELSE
11447  cut=2d0*0.3d0/vint(1)
11448  cuta=cut**(1d0-parp(98))
11449  cutb=(1d0+cut)**(1d0-parp(98))
11450  400 chi(jt)=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
11451  IF(((chi(jt)+cut)**2/(2d0*(chi(jt)**2+cut**2)))**
11452  & (0.5d0*parp(98))*(1d0-chi(jt))**chik.LT.pyr(0)) goto 400
11453  ENDIF
11454 
11455 C...Relative distribution of energy for particle into jet plus particle.
11456  ELSE
11457  IF(mstp(94).LE.1) THEN
11458  IF(imb.EQ.1) chi(jt)=pyr(0)
11459  IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
11460  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
11461  ELSEIF(mstp(94).EQ.2) THEN
11462  chi(jt)=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
11463  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
11464  ELSEIF(mstp(94).EQ.3) THEN
11465  CALL pyzdis(1,0,pms(jt+4),zz)
11466  chi(jt)=zz
11467  ELSE
11468  CALL pyzdis(1000,0,pms(jt+4),zz)
11469  chi(jt)=zz
11470  ENDIF
11471  ENDIF
11472 
11473 C...Construct total transverse mass; reject if too large.
11474  pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1d0-chi(jt))
11475  IF(pms(jt).GT.psys(jt,4)**2) THEN
11476  IF(loop.LT.10) THEN
11477  goto 370
11478  ELSE
11479  mint(51)=1
11480  mint(57)=mint(57)+1
11481  RETURN
11482  ENDIF
11483  ENDIF
11484  psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
11485  vint(158+jt)=chi(jt)
11486 
11487 C...Subdivide longitudinal momentum according to value selected above.
11488  pw1=chi(jt)*(psys(jt,4)+abs(psys(jt,3)))
11489  p(is(jt)+1,4)=0.5d0*(pw1+pms(jt+4)/pw1)
11490  p(is(jt)+1,3)=0.5d0*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
11491  p(is(jt),4)=psys(jt,4)-p(is(jt)+1,4)
11492  p(is(jt),3)=psys(jt,3)-p(is(jt)+1,3)
11493  ENDIF
11494  410 CONTINUE
11495  n=i
11496 
11497 C...Check if longitudinal boosts needed - if so pick two systems.
11498  pdev=abs(psys(0,4)+psys(1,4)+psys(2,4)-vint(1))+
11499  &abs(psys(0,3)+psys(1,3)+psys(2,3))
11500  IF(pdev.LE.1d-6*vint(1)) RETURN
11501  IF(isn(1).EQ.0) THEN
11502  ir=0
11503  il=2
11504  ELSEIF(isn(2).EQ.0) THEN
11505  ir=1
11506  il=0
11507  ELSEIF(vint(143).GT.0.2d0.AND.vint(144).GT.0.2d0) THEN
11508  ir=1
11509  il=2
11510  ELSEIF(vint(143).GT.0.2d0) THEN
11511  ir=1
11512  il=0
11513  ELSEIF(vint(144).GT.0.2d0) THEN
11514  ir=0
11515  il=2
11516  ELSEIF(pms(1)/psys(1,4)**2.GT.pms(2)/psys(2,4)**2) THEN
11517  ir=1
11518  il=0
11519  ELSE
11520  ir=0
11521  il=2
11522  ENDIF
11523  ig=3-ir-il
11524 
11525 C...E+-pL wanted for system to be modified.
11526  IF((ig.EQ.1.AND.isn(1).EQ.0).OR.(ig.EQ.2.AND.isn(2).EQ.0)) THEN
11527  ppb=vint(1)
11528  pnb=vint(1)
11529  ELSE
11530  ppb=vint(1)-(psys(ig,4)+psys(ig,3))
11531  pnb=vint(1)-(psys(ig,4)-psys(ig,3))
11532  ENDIF
11533 
11534 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
11535  IF(idisxq.EQ.1.AND.ig.NE.0) THEN
11536  pmtb=ppb*pnb
11537  pmtr=pms(ir)
11538  pmtl=pms(il)
11539  sqlam=sqrt(max(0d0,(pmtb-pmtr-pmtl)**2-4d0*pmtr*pmtl))
11540  sqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
11541  rkr=(pmtb+pmtr-pmtl+sqlam*sqsgn)/(2d0*(psys(ir,4)+psys(ir,3))
11542  & *pnb)
11543  rkl=(pmtb+pmtl-pmtr+sqlam*sqsgn)/(2d0*(psys(il,4)-psys(il,3))
11544  & *ppb)
11545  ber=(rkr**2-1d0)/(rkr**2+1d0)
11546  bel=-(rkl**2-1d0)/(rkl**2+1d0)
11547  ppb=ppb-(psys(0,4)+psys(0,3))
11548  pnb=pnb-(psys(0,4)-psys(0,3))
11549  DO 420 j=1,4
11550  psys(0,j)=0d0
11551  420 CONTINUE
11552  DO 450 i=mint(84)+1,ns
11553  IF(k(i,1).GT.10) goto 450
11554  incl=0
11555  iorig=i
11556  430 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
11557  iorig=k(iorig,3)
11558  IF(iorig.GT.lpin) goto 430
11559  IF(incl.EQ.0) goto 450
11560  DO 440 j=1,4
11561  psys(0,j)=psys(0,j)+p(i,j)
11562  440 CONTINUE
11563  450 CONTINUE
11564  pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
11565  ppb=ppb+(psys(0,4)+psys(0,3))
11566  pnb=pnb+(psys(0,4)-psys(0,3))
11567  ENDIF
11568 
11569 C...Construct longitudinal boosts.
11570  dpmtb=ppb*pnb
11571  dpmtr=pms(ir)
11572  dpmtl=pms(il)
11573  dsqlam=sqrt(max(0d0,(dpmtb-dpmtr-dpmtl)**2-4d0*dpmtr*dpmtl))
11574  IF(dsqlam.LE.1d-6*dpmtb) THEN
11575  mint(51)=1
11576  mint(57)=mint(57)+1
11577  RETURN
11578  ENDIF
11579  dsqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
11580  drkr=(dpmtb+dpmtr-dpmtl+dsqlam*dsqsgn)/
11581  &(2d0*(psys(ir,4)+psys(ir,3))*pnb)
11582  drkl=(dpmtb+dpmtl-dpmtr+dsqlam*dsqsgn)/
11583  &(2d0*(psys(il,4)-psys(il,3))*ppb)
11584  dber=(drkr**2-1d0)/(drkr**2+1d0)
11585  dbel=-(drkl**2-1d0)/(drkl**2+1d0)
11586 
11587 C...Perform longitudinal boosts.
11588  IF(ir.EQ.1.AND.isn(1).EQ.1.AND.dber.LE.-0.99999999d0) THEN
11589  p(is(1),3)=0d0
11590  p(is(1),4)=sqrt(p(is(1),5)**2+p(is(1),1)**2+p(is(1),2)**2)
11591  ELSEIF(ir.EQ.1) THEN
11592  CALL pyrobo(is(1),is(1)+isn(1)-1,0d0,0d0,0d0,0d0,dber)
11593  ELSEIF(idisxq.EQ.1) THEN
11594  DO 470 i=i1,ns
11595  incl=0
11596  iorig=i
11597  460 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
11598  iorig=k(iorig,3)
11599  IF(iorig.GT.lpin) goto 460
11600  IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dber)
11601  470 CONTINUE
11602  ELSE
11603  CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dber)
11604  ENDIF
11605  IF(il.EQ.2.AND.isn(2).EQ.1.AND.dbel.GE.0.99999999d0) THEN
11606  p(is(2),3)=0d0
11607  p(is(2),4)=sqrt(p(is(2),5)**2+p(is(2),1)**2+p(is(2),2)**2)
11608  ELSEIF(il.EQ.2) THEN
11609  CALL pyrobo(is(2),is(2)+isn(2)-1,0d0,0d0,0d0,0d0,dbel)
11610  ELSEIF(idisxq.EQ.1) THEN
11611  DO 490 i=i1,ns
11612  incl=0
11613  iorig=i
11614  480 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
11615  iorig=k(iorig,3)
11616  IF(iorig.GT.lpin) goto 480
11617  IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dbel)
11618  490 CONTINUE
11619  ELSE
11620  CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dbel)
11621  ENDIF
11622 
11623 C...Final check that energy-momentum conservation worked.
11624  pesum=0d0
11625  pzsum=0d0
11626  DO 500 i=mint(84)+1,n
11627  IF(k(i,1).GT.10) goto 500
11628  pesum=pesum+p(i,4)
11629  pzsum=pzsum+p(i,3)
11630  500 CONTINUE
11631  pdev=abs(pesum-vint(1))+abs(pzsum)
11632  IF(pdev.GT.1d-4*vint(1)) THEN
11633  mint(51)=1
11634  mint(57)=mint(57)+1
11635  RETURN
11636  ENDIF
11637 
11638 C...Calculate rotation and boost from overall CM frame to
11639 C...hadronic CM frame in leptoproduction.
11640  mint(91)=0
11641  IF(mint(82).EQ.1.AND.(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
11642  mint(91)=1
11643  lesd=1
11644  IF(mint(42).EQ.1) lesd=2
11645  lpin=mint(83)+3-lesd
11646 
11647 C...Sum upp momenta of everything not lepton or photon to define boost.
11648  DO 510 j=1,4
11649  psum(j)=0d0
11650  510 CONTINUE
11651  DO 530 i=1,n
11652  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 530
11653  IF(iabs(k(i,2)).GE.11.AND.iabs(k(i,2)).LE.20) goto 530
11654  IF(k(i,2).EQ.22) goto 530
11655  DO 520 j=1,4
11656  psum(j)=psum(j)+p(i,j)
11657  520 CONTINUE
11658  530 CONTINUE
11659  vint(223)=-psum(1)/psum(4)
11660  vint(224)=-psum(2)/psum(4)
11661  vint(225)=-psum(3)/psum(4)
11662 
11663 C...Boost incoming hadron to hadronic CM frame to determine rotations.
11664  k(n+1,1)=1
11665  DO 540 j=1,5
11666  p(n+1,j)=p(lpin,j)
11667  v(n+1,j)=v(lpin,j)
11668  540 CONTINUE
11669  CALL pyrobo(n+1,n+1,0d0,0d0,vint(223),vint(224),vint(225))
11670  vint(222)=-pyangl(p(n+1,1),p(n+1,2))
11671  CALL pyrobo(n+1,n+1,0d0,vint(222),0d0,0d0,0d0)
11672  IF(lesd.EQ.2) THEN
11673  vint(221)=-pyangl(p(n+1,3),p(n+1,1))
11674  ELSE
11675  vint(221)=pyangl(-p(n+1,3),p(n+1,1))
11676  ENDIF
11677  ENDIF
11678 
11679  RETURN
11680  END
11681 
11682 C*********************************************************************
11683 
11684 C...PYDIFF
11685 C...Handles diffractive and elastic scattering.
11686 
11687  SUBROUTINE pydiff
11688 
11689 C...Double precision and integer declarations.
11690  IMPLICIT DOUBLE PRECISION(a-h, o-z)
11691  INTEGER pyk,pychge,pycomp
11692 C...Commonblocks.
11693  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
11694  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
11695  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11696  common/pyint1/mint(400),vint(400)
11697  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
11698 
11699 C...Reset K, P and V vectors. Store incoming particles.
11700  DO 110 jt=1,mstp(126)+10
11701  i=mint(83)+jt
11702  DO 100 j=1,5
11703  k(i,j)=0
11704  p(i,j)=0d0
11705  v(i,j)=0d0
11706  100 CONTINUE
11707  110 CONTINUE
11708  n=mint(84)
11709  mint(3)=0
11710  mint(21)=0
11711  mint(22)=0
11712  mint(23)=0
11713  mint(24)=0
11714  mint(4)=4
11715  DO 130 jt=1,2
11716  i=mint(83)+jt
11717  k(i,1)=21
11718  k(i,2)=mint(10+jt)
11719  DO 120 j=1,5
11720  p(i,j)=vint(285+5*jt+j)
11721  120 CONTINUE
11722  130 CONTINUE
11723  mint(6)=2
11724 
11725 C...Subprocess; kinematics.
11726  sqlam=(vint(2)-vint(63)-vint(64))**2-4d0*vint(63)*vint(64)
11727  pz=sqrt(sqlam)/(2d0*vint(1))
11728  DO 200 jt=1,2
11729  i=mint(83)+jt
11730  pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2d0*vint(1))
11731  kfh=mint(102+jt)
11732 
11733 C...Elastically scattered particle.
11734  IF(mint(16+jt).LE.0) THEN
11735  n=n+1
11736  k(n,1)=1
11737  k(n,2)=kfh
11738  k(n,3)=i+2
11739  p(n,3)=pz*(-1)**(jt+1)
11740  p(n,4)=pe
11741  p(n,5)=sqrt(vint(62+jt))
11742 
11743 C...Decay rho from elastic scattering of gamma with sin**2(theta)
11744 C...distribution of decay products (in rho rest frame).
11745  IF(kfh.EQ.113.AND.mint(10+jt).EQ.22.AND.mstp(102).EQ.1) THEN
11746  nsav=n
11747  dbetaz=p(n,3)/sqrt(p(n,3)**2+p(n,5)**2)
11748  p(n,3)=0d0
11749  p(n,4)=p(n,5)
11750  CALL pydecy(nsav)
11751  IF(n.EQ.nsav+2.AND.iabs(k(nsav+1,2)).EQ.211) THEN
11752  phi=pyangl(p(nsav+1,1),p(nsav+1,2))
11753  CALL pyrobo(nsav+1,nsav+2,0d0,-phi,0d0,0d0,0d0)
11754  the=pyangl(p(nsav+1,3),p(nsav+1,1))
11755  CALL pyrobo(nsav+1,nsav+2,-the,0d0,0d0,0d0,0d0)
11756  140 cthe=2d0*pyr(0)-1d0
11757  IF(1d0-cthe**2.LT.pyr(0)) goto 140
11758  CALL pyrobo(nsav+1,nsav+2,acos(cthe),phi,0d0,0d0,0d0)
11759  ENDIF
11760  CALL pyrobo(nsav,nsav+2,0d0,0d0,0d0,0d0,dbetaz)
11761  ENDIF
11762 
11763 C...Diffracted particle: low-mass system to two particles.
11764  ELSEIF(vint(62+jt).LT.(vint(66+jt)+parp(103))**2) THEN
11765  n=n+2
11766  k(n-1,1)=1
11767  k(n,1)=1
11768  k(n-1,3)=i+2
11769  k(n,3)=i+2
11770  pmmas=sqrt(vint(62+jt))
11771  ntry=0
11772  150 ntry=ntry+1
11773  IF(ntry.LT.20) THEN
11774  mint(105)=mint(102+jt)
11775  mint(109)=mint(106+jt)
11776  CALL pyspli(kfh,21,kfl1,kfl2)
11777  CALL pykfdi(kfl1,0,kfl3,kf1)
11778  IF(kf1.EQ.0) goto 150
11779  CALL pykfdi(kfl2,-kfl3,kfldum,kf2)
11780  IF(kf2.EQ.0) goto 150
11781  ELSE
11782  kf1=kfh
11783  kf2=111
11784  ENDIF
11785  pm1=pymass(kf1)
11786  pm2=pymass(kf2)
11787  IF(pm1+pm2+parj(64).GT.pmmas) goto 150
11788  k(n-1,2)=kf1
11789  k(n,2)=kf2
11790  p(n-1,5)=pm1
11791  p(n,5)=pm2
11792  pzp=sqrt(max(0d0,(pmmas**2-pm1**2-pm2**2)**2-
11793  & 4d0*pm1**2*pm2**2))/(2d0*pmmas)
11794  p(n-1,3)=pzp
11795  p(n,3)=-pzp
11796  p(n-1,4)=sqrt(pm1**2+pzp**2)
11797  p(n,4)=sqrt(pm2**2+pzp**2)
11798  CALL pyrobo(n-1,n,acos(2d0*pyr(0)-1d0),paru(2)*pyr(0),
11799  & 0d0,0d0,0d0)
11800  dbetaz=pz*(-1)**(jt+1)/sqrt(pz**2+pmmas**2)
11801  CALL pyrobo(n-1,n,0d0,0d0,0d0,0d0,dbetaz)
11802 
11803 C...Diffracted particle: valence quark kicked out.
11804  ELSEIF(mstp(101).EQ.1.OR.(mstp(101).EQ.3.AND.pyr(0).LT.
11805  & parp(101))) THEN
11806  n=n+2
11807  k(n-1,1)=2
11808  k(n,1)=1
11809  k(n-1,3)=i+2
11810  k(n,3)=i+2
11811  mint(105)=mint(102+jt)
11812  mint(109)=mint(106+jt)
11813  CALL pyspli(kfh,21,k(n,2),k(n-1,2))
11814  p(n-1,5)=pymass(k(n-1,2))
11815  p(n,5)=pymass(k(n,2))
11816  sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-
11817  & 4d0*p(n-1,5)**2*p(n,5)**2
11818  p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-
11819  & p(n,5)**2))/(2d0*vint(62+jt))*(-1)**(jt+1)
11820  p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)
11821  p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)
11822  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
11823 
11824 C...Diffracted particle: gluon kicked out.
11825  ELSE
11826  n=n+3
11827  k(n-2,1)=2
11828  k(n-1,1)=2
11829  k(n,1)=1
11830  k(n-2,3)=i+2
11831  k(n-1,3)=i+2
11832  k(n,3)=i+2
11833  mint(105)=mint(102+jt)
11834  mint(109)=mint(106+jt)
11835  CALL pyspli(kfh,21,k(n,2),k(n-2,2))
11836  k(n-1,2)=21
11837  p(n-2,5)=pymass(k(n-2,2))
11838  p(n-1,5)=0d0
11839  p(n,5)=pymass(k(n,2))
11840 C...Energy distribution for particle into two jets.
11841  160 imb=1
11842  IF(mod(kfh/1000,10).NE.0) imb=2
11843  chik=parp(92+2*imb)
11844  IF(mstp(92).LE.1) THEN
11845  IF(imb.EQ.1) chi=pyr(0)
11846  IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
11847  ELSEIF(mstp(92).EQ.2) THEN
11848  chi=1d0-pyr(0)**(1d0/(1d0+chik))
11849  ELSEIF(mstp(92).EQ.3) THEN
11850  cut=2d0*0.3d0/vint(1)
11851  170 chi=pyr(0)**2
11852  IF((chi**2/(chi**2+cut**2))**0.25d0*(1d0-chi)**chik.LT.
11853  & pyr(0)) goto 170
11854  ELSEIF(mstp(92).EQ.4) THEN
11855  cut=2d0*0.3d0/vint(1)
11856  cutr=(1d0+sqrt(1d0+cut**2))/cut
11857  180 chir=cut*cutr**pyr(0)
11858  chi=(chir**2-cut**2)/(2d0*chir)
11859  IF((1d0-chi)**chik.LT.pyr(0)) goto 180
11860  ELSE
11861  cut=2d0*0.3d0/vint(1)
11862  cuta=cut**(1d0-parp(98))
11863  cutb=(1d0+cut)**(1d0-parp(98))
11864  190 chi=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
11865  IF(((chi+cut)**2/(2d0*(chi**2+cut**2)))**
11866  & (0.5d0*parp(98))*(1d0-chi)**chik.LT.pyr(0)) goto 190
11867  ENDIF
11868  IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1d0-p(n-2,5)**2/
11869  & vint(62+jt)) goto 160
11870  sqm=p(n-2,5)**2/(1d0-chi)+p(n,5)**2/chi
11871  IF((sqrt(sqm)+parj(32))**2.GE.vint(62+jt)) goto 160
11872  pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/
11873  & (2d0*vint(62+jt))
11874  pei=sqrt(pzi**2+sqm)
11875  pqqp=(1d0-chi)*(pei+pzi)
11876  p(n-2,3)=0.5d0*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)
11877  p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)
11878  p(n-1,4)=0.5d0*(vint(62+jt)-sqm)/(pei+pzi)
11879  p(n-1,3)=p(n-1,4)*(-1)**jt
11880  p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)
11881  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
11882  ENDIF
11883 
11884 C...Documentation lines.
11885  k(i+2,1)=21
11886  IF(mint(16+jt).EQ.0) k(i+2,2)=kfh
11887  IF(mint(16+jt).NE.0) k(i+2,2)=10*(kfh/10)
11888  k(i+2,3)=i
11889  p(i+2,3)=pz*(-1)**(jt+1)
11890  p(i+2,4)=pe
11891  p(i+2,5)=sqrt(vint(62+jt))
11892  200 CONTINUE
11893 
11894 C...Rotate outgoing partons/particles using cos(theta).
11895  IF(vint(23).LT.0.9d0) THEN
11896  CALL pyrobo(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)
11897  ELSE
11898  CALL pyrobo(mint(83)+3,n,asin(vint(59)),vint(24),0d0,0d0,0d0)
11899  ENDIF
11900 
11901  RETURN
11902  END
11903 
11904 C*********************************************************************
11905 
11906 C...PYDOCU
11907 C...Handles the documentation of the process in MSTI and PARI,
11908 C...and also computes cross-sections based on accumulated statistics.
11909 
11910  SUBROUTINE pydocu
11911 
11912 C...Double precision and integer declarations.
11913  IMPLICIT DOUBLE PRECISION(a-h, o-z)
11914  INTEGER pyk,pychge,pycomp
11915 C...Commonblocks.
11916  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
11917  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
11918  common/pypars/mstp(200),parp(200),msti(200),pari(200)
11919  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
11920  common/pyint1/mint(400),vint(400)
11921  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
11922  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
11923  SAVE /pyjets/,/pydat1/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
11924  &/pyint5/
11925 
11926 C...Calculate Monte Carlo estimates of cross-sections.
11927  isub=mint(1)
11928  IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1
11929  ngen(0,3)=ngen(0,3)+1
11930  xsec(0,3)=0d0
11931  DO 100 i=1,500
11932  IF(i.EQ.96.OR.i.EQ.97) THEN
11933  xsec(i,3)=0d0
11934  ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.
11935  & i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN
11936  xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
11937  & dble(ngen(96,2)))
11938  ELSEIF(msub(i).EQ.0.OR.ngen(i,1).EQ.0) THEN
11939  xsec(i,3)=0d0
11940  ELSEIF(ngen(i,2).EQ.0) THEN
11941  xsec(i,3)=xsec(i,2)*ngen(0,3)/(dble(ngen(i,1))*
11942  & dble(ngen(0,2)))
11943  ELSE
11944  xsec(i,3)=xsec(i,2)*ngen(i,3)/(dble(ngen(i,1))*
11945  & dble(ngen(i,2)))
11946  ENDIF
11947  xsec(0,3)=xsec(0,3)+xsec(i,3)
11948  100 CONTINUE
11949 
11950 C...Rescale to known low-pT cross-section for standard QCD processes.
11951  IF(msub(95).EQ.1) THEN
11952  xsech=xsec(11,3)+xsec(12,3)+xsec(13,3)+xsec(28,3)+xsec(53,3)+
11953  & xsec(68,3)+xsec(95,3)
11954  xsecw=xsec(97,2)/max(1d0,dble(ngen(97,1)))
11955  IF(xsech.GT.1d-10.AND.xsecw.GT.1d-10) THEN
11956  fac=xsecw/xsech
11957  xsec(11,3)=fac*xsec(11,3)
11958  xsec(12,3)=fac*xsec(12,3)
11959  xsec(13,3)=fac*xsec(13,3)
11960  xsec(28,3)=fac*xsec(28,3)
11961  xsec(53,3)=fac*xsec(53,3)
11962  xsec(68,3)=fac*xsec(68,3)
11963  xsec(95,3)=fac*xsec(95,3)
11964  xsec(0,3)=xsec(0,3)-xsech+xsecw
11965  ENDIF
11966  ENDIF
11967 
11968 C...Save information for gamma-p and gamma-gamma.
11969  IF(mint(121).GT.1) THEN
11970  iga=mint(122)
11971  CALL pysave(2,iga)
11972  CALL pysave(5,0)
11973  ENDIF
11974 
11975 C...Reset information on hard interaction.
11976  DO 110 j=1,200
11977  msti(j)=0
11978  pari(j)=0d0
11979  110 CONTINUE
11980 
11981 C...Copy integer valued information from MINT into MSTI.
11982  DO 120 j=1,32
11983  msti(j)=mint(j)
11984  120 CONTINUE
11985  IF(mint(121).GT.1) msti(9)=mint(122)
11986 
11987 C...Store cross-section variables in PARI.
11988  pari(1)=xsec(0,3)
11989  pari(2)=xsec(0,3)/mint(5)
11990  pari(9)=vint(99)
11991  pari(10)=vint(100)
11992  vint(98)=vint(98)+vint(100)
11993  IF(mstp(142).EQ.1) pari(2)=xsec(0,3)/vint(98)
11994 
11995 C...Store kinematics variables in PARI.
11996  pari(11)=vint(1)
11997  pari(12)=vint(2)
11998  IF(isub.NE.95) THEN
11999  DO 130 j=13,26
12000  pari(j)=vint(30+j)
12001  130 CONTINUE
12002  pari(31)=vint(141)
12003  pari(32)=vint(142)
12004  pari(33)=vint(41)
12005  pari(34)=vint(42)
12006  pari(35)=pari(33)-pari(34)
12007  pari(36)=vint(21)
12008  pari(37)=vint(22)
12009  pari(38)=vint(26)
12010  pari(39)=vint(157)
12011  pari(40)=vint(158)
12012  pari(41)=vint(23)
12013  pari(42)=2d0*vint(47)/vint(1)
12014  ENDIF
12015 
12016 C...Store information on scattered partons in PARI.
12017  IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN
12018  DO 140 is=7,8
12019  i=mint(is)
12020  pari(36+is)=p(i,3)/vint(1)
12021  pari(38+is)=p(i,4)/vint(1)
12022  pr=max(1d-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)
12023  pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
12024  & sqrt(pr),1d20)),p(i,3))
12025  pr=max(1d-20,p(i,1)**2+p(i,2)**2)
12026  pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
12027  & sqrt(pr),1d20)),p(i,3))
12028  pari(44+is)=p(i,3)/sqrt(1d-20+p(i,1)**2+p(i,2)**2+p(i,3)**2)
12029  pari(46+is)=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
12030  pari(48+is)=pyangl(p(i,1),p(i,2))
12031  140 CONTINUE
12032  ENDIF
12033 
12034 C...Store sum up transverse and longitudinal momenta.
12035  pari(65)=2d0*pari(17)
12036  IF(isub.LE.90.OR.isub.GE.95) THEN
12037  DO 150 i=mstp(126)+1,n
12038  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150
12039  pt=sqrt(p(i,1)**2+p(i,2)**2)
12040  pari(69)=pari(69)+pt
12041  IF(i.LE.mint(52)) pari(66)=pari(66)+pt
12042  IF(i.GT.mint(52).AND.i.LE.mint(53)) pari(68)=pari(68)+pt
12043  150 CONTINUE
12044  pari(67)=pari(68)
12045  pari(71)=vint(151)
12046  pari(72)=vint(152)
12047  pari(73)=vint(151)
12048  pari(74)=vint(152)
12049  ELSE
12050  pari(66)=pari(65)
12051  pari(69)=pari(65)
12052  ENDIF
12053 
12054 C...Store various other pieces of information into PARI.
12055  pari(61)=vint(148)
12056  pari(75)=vint(155)
12057  pari(76)=vint(156)
12058  pari(77)=vint(159)
12059  pari(78)=vint(160)
12060  pari(81)=vint(138)
12061 
12062 C...Set information for PYTABU.
12063  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
12064  mstu(161)=mint(21)
12065  mstu(162)=0
12066  ELSEIF(iset(isub).EQ.5) THEN
12067  mstu(161)=mint(23)
12068  mstu(162)=0
12069  ELSE
12070  mstu(161)=mint(21)
12071  mstu(162)=mint(22)
12072  ENDIF
12073 
12074  RETURN
12075  END
12076 
12077 C*********************************************************************
12078 
12079 C...PYFRAM
12080 C...Performs transformations between different coordinate frames.
12081 
12082  SUBROUTINE pyfram(IFRAME)
12083 
12084 C...Double precision and integer declarations.
12085  IMPLICIT DOUBLE PRECISION(a-h, o-z)
12086  INTEGER pyk,pychge,pycomp
12087 C...Commonblocks.
12088  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
12089  common/pypars/mstp(200),parp(200),msti(200),pari(200)
12090  common/pyint1/mint(400),vint(400)
12091  SAVE /pydat1/,/pypars/,/pyint1/
12092 
12093 C...Check that transformation can and should be done.
12094  IF(iframe.EQ.1.OR.iframe.EQ.2.OR.(iframe.EQ.3.AND.
12095  &mint(91).EQ.1)) THEN
12096  IF(iframe.EQ.mint(6)) RETURN
12097  ELSE
12098  WRITE(mstu(11),5000) iframe,mint(6)
12099  RETURN
12100  ENDIF
12101 
12102  IF(mint(6).EQ.1) THEN
12103 C...Transform from fixed target or user specified frame to
12104 C...overall CM frame.
12105  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
12106  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
12107  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
12108  ELSEIF(mint(6).EQ.3) THEN
12109 C...Transform from hadronic CM frame in DIS to overall CM frame.
12110  CALL pyrobo(0,0,-vint(221),-vint(222),-vint(223),-vint(224),
12111  & -vint(225))
12112  ENDIF
12113 
12114  IF(iframe.EQ.1) THEN
12115 C...Transform from overall CM frame to fixed target or user specified
12116 C...frame.
12117  CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))
12118  ELSEIF(iframe.EQ.3) THEN
12119 C...Transform from overall CM frame to hadronic CM frame in DIS.
12120  CALL pyrobo(0,0,0d0,0d0,vint(223),vint(224),vint(225))
12121  CALL pyrobo(0,0,0d0,vint(222),0d0,0d0,0d0)
12122  CALL pyrobo(0,0,vint(221),0d0,0d0,0d0,0d0)
12123  ENDIF
12124 
12125 C...Set information about new frame.
12126  mint(6)=iframe
12127  msti(6)=iframe
12128 
12129  5000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,
12130  &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',
12131  &1x,i5)
12132 
12133  RETURN
12134  END
12135 
12136 C*********************************************************************
12137 
12138 C...PYWIDT
12139 C...Calculates full and partial widths of resonances.
12140 
12141  SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)
12142 
12143 C...Double precision and integer declarations.
12144  IMPLICIT DOUBLE PRECISION(a-h, o-z)
12145  INTEGER pyk,pychge,pycomp
12146 C...Parameter statement to help give large particle numbers.
12147  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
12148 C...Commonblocks.
12149  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
12150  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
12151  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
12152  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
12153  common/pypars/mstp(200),parp(200),msti(200),pari(200)
12154  common/pyint1/mint(400),vint(400)
12155  common/pyint4/mwid(500),wids(500,5)
12156  common/pymssm/imss(0:99),rmss(0:99)
12157  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
12158  &sfmix(16,4)
12159  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
12160  &/pyint4/,/pymssm/,/pyssmt/
12161 C...Local arrays and saved variables.
12162  dimension wdtp(0:200),wdte(0:200,0:5),mofsv(3,2),widwsv(3,2),
12163  &wid2sv(3,2)
12164  SAVE mofsv,widwsv,wid2sv
12165  DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
12166 
12167 C...Compressed code and sign; mass.
12168  kfla=iabs(kflr)
12169  kfls=isign(1,kflr)
12170  kc=pycomp(kfla)
12171  shr=sqrt(sh)
12172  pmr=pmas(kc,1)
12173 
12174 C...Reset width information.
12175  DO 110 i=0,200
12176  wdtp(i)=0d0
12177  DO 100 j=0,5
12178  wdte(i,j)=0d0
12179  100 CONTINUE
12180  110 CONTINUE
12181 
12182 C...Not to be treated as a resonance: return.
12183  IF((mwid(kc).LE.0.OR.mwid(kc).GE.4).AND.kfla.NE.21.AND.
12184  &kfla.NE.22) THEN
12185  wdtp(0)=1d0
12186  wdte(0,0)=1d0
12187  mint(61)=0
12188  mint(62)=0
12189  mint(63)=0
12190  RETURN
12191 
12192 C...Treatment as a resonance based on tabulated branching ratios.
12193  ELSEIF(mwid(kc).EQ.2.OR.(mwid(kc).EQ.3.AND.mint(63).EQ.0)) THEN
12194 C...Loop over possible decay channels; skip irrelevant ones.
12195  DO 120 i=1,mdcy(kc,3)
12196  idc=i+mdcy(kc,2)-1
12197  IF(mdme(idc,1).LT.0) goto 120
12198 
12199 C...Read out decay products and nominal masses.
12200  kfd1=kfdp(idc,1)
12201  kfc1=pycomp(kfd1)
12202  IF(kchg(kfc1,3).EQ.1) kfd1=kfls*kfd1
12203  pm1=pmas(kfc1,1)
12204  kfd2=kfdp(idc,2)
12205  kfc2=pycomp(kfd2)
12206  IF(kchg(kfc2,3).EQ.1) kfd2=kfls*kfd2
12207  pm2=pmas(kfc2,1)
12208  kfd3=kfdp(idc,3)
12209  pm3=0d0
12210  IF(kfd3.NE.0) THEN
12211  kfc3=pycomp(kfd3)
12212  IF(kchg(kfc3,3).EQ.1) kfd3=kfls*kfd3
12213  pm3=pmas(kfc3,1)
12214  ENDIF
12215 
12216 C...Naive partial width and alternative threshold factors.
12217  wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)
12218  IF(mdme(idc,2).GE.51.AND.mdme(idc,2).LE.53.AND.
12219  & pm1+pm2+pm3.GE.shr) THEN
12220  wdtp(i)=0d0
12221  ELSEIF(mdme(idc,2).EQ.52.AND.kfd3.EQ.0) THEN
12222  wdtp(i)=wdtp(i)*sqrt(max(0d0,(sh-pm1**2-pm2**2)**2-
12223  & 4d0*pm1**2*pm2**2))/sh
12224  ELSEIF(mdme(idc,2).EQ.52) THEN
12225  pma=max(pm1,pm2,pm3)
12226  pmc=min(pm1,pm2,pm3)
12227  pmb=pm1+pm2+pm3-pma-pmc
12228  pmbc=pmb+pmc+0.5d0*(shr-pma-pmc-pmc)
12229  pman=pma**2/sh
12230  pmbn=pmb**2/sh
12231  pmcn=pmc**2/sh
12232  pmbcn=pmbc**2/sh
12233  wdtp(i)=wdtp(i)*sqrt(max(0d0,
12234  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
12235  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
12236  & ((shr-pma)**2-(pmb+pmc)**2)*
12237  & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
12238  & ((1d0-pmbcn)*pmbcn*sh)
12239  ELSEIF(mdme(idc,2).EQ.53.AND.kfd3.EQ.0) THEN
12240  wdtp(i)=wdtp(i)*sqrt(
12241  & max(0d0,(sh-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2)/
12242  & max(1d-4,(pmr**2-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2))
12243  ELSEIF(mdme(idc,2).EQ.53) THEN
12244  pma=max(pm1,pm2,pm3)
12245  pmc=min(pm1,pm2,pm3)
12246  pmb=pm1+pm2+pm3-pma-pmc
12247  pmbc=pmb+pmc+0.5d0*(shr-pma-pmb-pmc)
12248  pman=pma**2/sh
12249  pmbn=pmb**2/sh
12250  pmcn=pmc**2/sh
12251  pmbcn=pmbc**2/sh
12252  facact=sqrt(max(0d0,
12253  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
12254  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
12255  & ((shr-pma)**2-(pmb+pmc)**2)*
12256  & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
12257  & ((1d0-pmbcn)*pmbcn*sh)
12258  pmbc=pmb+pmc+0.5d0*(pmr-pma-pmb-pmc)
12259  pman=pma**2/pmr**2
12260  pmbn=pmb**2/pmr**2
12261  pmcn=pmc**2/pmr**2
12262  pmbcn=pmbc**2/pmr**2
12263  facnom=sqrt(max(0d0,
12264  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
12265  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
12266  & ((pmr-pma)**2-(pmb+pmc)**2)*
12267  & (1d0+0.25d0*(pma+pmb+pmc)/pmr)/
12268  & ((1d0-pmbcn)*pmbcn*pmr**2)
12269  wdtp(i)=wdtp(i)*facact/max(1d-6,facnom)
12270  ENDIF
12271  wdtp(0)=wdtp(0)+wdtp(i)
12272 
12273 C...Calculate secondary width (at most two identical/opposite).
12274  IF(mdme(idc,1).GT.0) THEN
12275  IF(kfd2.EQ.kfd1) THEN
12276  IF(kchg(kfc1,3).EQ.0) THEN
12277  wid2=wids(kfc1,1)
12278  ELSEIF(kfd1.GT.0) THEN
12279  wid2=wids(kfc1,4)
12280  ELSE
12281  wid2=wids(kfc1,5)
12282  ENDIF
12283  IF(kfd3.GT.0) THEN
12284  wid2=wid2*wids(kfc3,2)
12285  ELSEIF(kfd3.LT.0) THEN
12286  wid2=wid2*wids(kfc3,3)
12287  ENDIF
12288  ELSEIF(kfd2.EQ.-kfd1) THEN
12289  wid2=wids(kfc1,1)
12290  IF(kfd3.GT.0) THEN
12291  wid2=wid2*wids(kfc3,2)
12292  ELSEIF(kfd3.LT.0) THEN
12293  wid2=wid2*wids(kfc3,3)
12294  ENDIF
12295  ELSEIF(kfd3.EQ.kfd1) THEN
12296  IF(kchg(kfc1,3).EQ.0) THEN
12297  wid2=wids(kfc1,1)
12298  ELSEIF(kfd1.GT.0) THEN
12299  wid2=wids(kfc1,4)
12300  ELSE
12301  wid2=wids(kfc1,5)
12302  ENDIF
12303  IF(kfd2.GT.0) THEN
12304  wid2=wid2*wids(kfc2,2)
12305  ELSEIF(kfd2.LT.0) THEN
12306  wid2=wid2*wids(kfc2,3)
12307  ENDIF
12308  ELSEIF(kfd3.EQ.-kfd1) THEN
12309  wid2=wids(kfc1,1)
12310  IF(kfd2.GT.0) THEN
12311  wid2=wid2*wids(kfc2,2)
12312  ELSEIF(kfd2.LT.0) THEN
12313  wid2=wid2*wids(kfc2,3)
12314  ENDIF
12315  ELSEIF(kfd3.EQ.kfd2) THEN
12316  IF(kchg(kfc2,3).EQ.0) THEN
12317  wid2=wids(kfc2,1)
12318  ELSEIF(kfd2.GT.0) THEN
12319  wid2=wids(kfc2,4)
12320  ELSE
12321  wid2=wids(kfc2,5)
12322  ENDIF
12323  IF(kfd1.GT.0) THEN
12324  wid2=wid2*wids(kfc1,2)
12325  ELSEIF(kfd1.LT.0) THEN
12326  wid2=wid2*wids(kfc1,3)
12327  ENDIF
12328  ELSEIF(kfd3.EQ.-kfd2) THEN
12329  wid2=wids(kfc2,1)
12330  IF(kfd1.GT.0) THEN
12331  wid2=wid2*wids(kfc1,2)
12332  ELSEIF(kfd1.LT.0) THEN
12333  wid2=wid2*wids(kfc1,3)
12334  ENDIF
12335  ELSE
12336  IF(kfd1.GT.0) THEN
12337  wid2=wids(kfc1,2)
12338  ELSE
12339  wid2=wids(kfc1,3)
12340  ENDIF
12341  IF(kfd2.GT.0) THEN
12342  wid2=wid2*wids(kfc2,2)
12343  ELSE
12344  wid2=wid2*wids(kfc2,3)
12345  ENDIF
12346  IF(kfd3.GT.0) THEN
12347  wid2=wid2*wids(kfc3,2)
12348  ELSEIF(kfd3.LT.0) THEN
12349  wid2=wid2*wids(kfc3,3)
12350  ENDIF
12351  ENDIF
12352 
12353 C...Store effective widths according to case.
12354  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12355  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12356  wdte(i,0)=wdte(i,mdme(idc,1))
12357  wdte(0,0)=wdte(0,0)+wdte(i,0)
12358  ENDIF
12359  120 CONTINUE
12360 C...Return.
12361  mint(61)=0
12362  mint(62)=0
12363  mint(63)=0
12364  RETURN
12365  ENDIF
12366 
12367 C...Here begins detailed dynamical calculation of resonance widths.
12368 C...Shared treatment of Higgs states.
12369  kfhigg=25
12370  ihigg=1
12371  IF(kfla.EQ.35.OR.kfla.EQ.36) THEN
12372  kfhigg=kfla
12373  ihigg=kfla-33
12374  ENDIF
12375 
12376 C...Common electroweak and strong constants.
12377  xw=paru(102)
12378  xwv=xw
12379  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
12380  xw1=1d0-xw
12381  aem=pyalem(sh)
12382  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
12383  as=pyalps(sh)
12384  radc=1d0+as/paru(1)
12385 
12386  IF(kfla.EQ.6) THEN
12387 C...t quark.
12388  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
12389  radct=1d0-2.5d0*as/paru(1)
12390  DO 130 i=1,mdcy(kc,3)
12391  idc=i+mdcy(kc,2)-1
12392  IF(mdme(idc,1).LT.0) goto 130
12393  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
12394  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
12395  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 130
12396  IF(i.GE.4.AND.i.LE.7) THEN
12397 C...t -> W + q; including approximate QCD correction factor.
12398  wdtp(i)=fac*vckm(3,i-3)*radct*
12399  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12400  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
12401  IF(kflr.GT.0) THEN
12402  wid2=wids(24,2)
12403  IF(i.EQ.7) wid2=wid2*wids(7,2)
12404  ELSE
12405  wid2=wids(24,3)
12406  IF(i.EQ.7) wid2=wid2*wids(7,3)
12407  ENDIF
12408  ELSEIF(i.EQ.9) THEN
12409 C...t -> H + b.
12410  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12411  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
12412  wid2=wids(37,2)
12413  IF(kflr.LT.0) wid2=wids(37,3)
12414 CMRENNA++
12415  ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN
12416 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
12417  beta=atan(rmss(5))
12418  sinb=sin(beta)
12419  tanw=sqrt(paru(102)/(1d0-paru(102)))
12420  et=kchg(6,1)/3d0
12421  t3l=sign(0.5d0,et)
12422  kfc1=pycomp(kfdp(idc,1))
12423  kfc2=pycomp(kfdp(idc,2))
12424  pmnchi=pmas(kfc1,1)
12425  pmstop=pmas(kfc2,1)
12426  IF(shr.GT.pmnchi+pmstop) THEN
12427  iz=i-9
12428  al=shr*zmix(iz,4)/(2.0d0*pmas(24,1)*sinb)
12429  ar=-et*zmix(iz,1)*tanw
12430  bl=t3l*(zmix(iz,2)-zmix(iz,1)*tanw)-ar
12431  br=al
12432  fl=sfmix(6,1)*al+sfmix(6,2)*ar
12433  fr=sfmix(6,1)*bl+sfmix(6,2)*br
12434  pcm=sqrt((sh-(pmnchi+pmstop)**2)*
12435  & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
12436  wdtp(i)=(0.5d0*pyalem(sh)/paru(102))*pcm*((fl**2+fr**2)*
12437  & (sh+pmnchi**2-pmstop**2)+smz(iz)*4d0*shr*fl*fr)
12438  IF(kflr.GT.0) THEN
12439  wid2=wids(kfc1,2)*wids(kfc2,2)
12440  ELSE
12441  wid2=wids(kfc1,2)*wids(kfc2,3)
12442  ENDIF
12443  ENDIF
12444 CMRENNA--
12445  ENDIF
12446  wdtp(0)=wdtp(0)+wdtp(i)
12447  IF(mdme(idc,1).GT.0) THEN
12448  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12449  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12450  wdte(i,0)=wdte(i,mdme(idc,1))
12451  wdte(0,0)=wdte(0,0)+wdte(i,0)
12452  ENDIF
12453  130 CONTINUE
12454 
12455  ELSEIF(kfla.EQ.7) THEN
12456 C...b' quark.
12457  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
12458  DO 140 i=1,mdcy(kc,3)
12459  idc=i+mdcy(kc,2)-1
12460  IF(mdme(idc,1).LT.0) goto 140
12461  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
12462  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
12463  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 140
12464  IF(i.GE.4.AND.i.LE.7) THEN
12465 C...b' -> W + q.
12466  wdtp(i)=fac*vckm(i-3,4)*
12467  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12468  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
12469  IF(kflr.GT.0) THEN
12470  wid2=wids(24,3)
12471  IF(i.EQ.6) wid2=wid2*wids(6,2)
12472  IF(i.EQ.7) wid2=wid2*wids(8,2)
12473  ELSE
12474  wid2=wids(24,2)
12475  IF(i.EQ.6) wid2=wid2*wids(6,3)
12476  IF(i.EQ.7) wid2=wid2*wids(8,3)
12477  ENDIF
12478  wid2=wids(24,3)
12479  IF(kflr.LT.0) wid2=wids(24,2)
12480  ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
12481 C...b' -> H + q.
12482  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12483  & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
12484  IF(kflr.GT.0) THEN
12485  wid2=wids(37,3)
12486  IF(i.EQ.10) wid2=wid2*wids(6,2)
12487  ELSE
12488  wid2=wids(37,2)
12489  IF(i.EQ.10) wid2=wid2*wids(6,3)
12490  ENDIF
12491  ENDIF
12492  wdtp(0)=wdtp(0)+wdtp(i)
12493  IF(mdme(idc,1).GT.0) THEN
12494  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12495  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12496  wdte(i,0)=wdte(i,mdme(idc,1))
12497  wdte(0,0)=wdte(0,0)+wdte(i,0)
12498  ENDIF
12499  140 CONTINUE
12500 
12501  ELSEIF(kfla.EQ.8) THEN
12502 C...t' quark.
12503  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
12504  DO 150 i=1,mdcy(kc,3)
12505  idc=i+mdcy(kc,2)-1
12506  IF(mdme(idc,1).LT.0) goto 150
12507  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
12508  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
12509  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 150
12510  IF(i.GE.4.AND.i.LE.7) THEN
12511 C...t' -> W + q.
12512  wdtp(i)=fac*vckm(4,i-3)*
12513  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12514  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
12515  IF(kflr.GT.0) THEN
12516  wid2=wids(24,2)
12517  IF(i.EQ.7) wid2=wid2*wids(7,2)
12518  ELSE
12519  wid2=wids(24,3)
12520  IF(i.EQ.7) wid2=wid2*wids(7,3)
12521  ENDIF
12522  ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
12523 C...t' -> H + q.
12524  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12525  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
12526  IF(kflr.GT.0) THEN
12527  wid2=wids(37,2)
12528  IF(i.EQ.10) wid2=wid2*wids(7,2)
12529  ELSE
12530  wid2=wids(37,3)
12531  IF(i.EQ.10) wid2=wid2*wids(7,3)
12532  ENDIF
12533  ENDIF
12534  wdtp(0)=wdtp(0)+wdtp(i)
12535  IF(mdme(idc,1).GT.0) THEN
12536  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12537  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12538  wdte(i,0)=wdte(i,mdme(idc,1))
12539  wdte(0,0)=wdte(0,0)+wdte(i,0)
12540  ENDIF
12541  150 CONTINUE
12542 
12543  ELSEIF(kfla.EQ.17) THEN
12544 C...tau' lepton.
12545  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
12546  DO 160 i=1,mdcy(kc,3)
12547  idc=i+mdcy(kc,2)-1
12548  IF(mdme(idc,1).LT.0) goto 160
12549  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
12550  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
12551  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 160
12552  IF(i.EQ.3) THEN
12553 C...tau' -> W + nu'_tau.
12554  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12555  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
12556  IF(kflr.GT.0) THEN
12557  wid2=wids(24,3)
12558  wid2=wid2*wids(18,2)
12559  ELSE
12560  wid2=wids(24,2)
12561  wid2=wid2*wids(18,3)
12562  ENDIF
12563  ELSEIF(i.EQ.5) THEN
12564 C...tau' -> H + nu'_tau.
12565  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12566  & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
12567  IF(kflr.GT.0) THEN
12568  wid2=wids(37,3)
12569  wid2=wid2*wids(18,2)
12570  ELSE
12571  wid2=wids(37,2)
12572  wid2=wid2*wids(18,3)
12573  ENDIF
12574  ENDIF
12575  wdtp(0)=wdtp(0)+wdtp(i)
12576  IF(mdme(idc,1).GT.0) THEN
12577  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12578  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12579  wdte(i,0)=wdte(i,mdme(idc,1))
12580  wdte(0,0)=wdte(0,0)+wdte(i,0)
12581  ENDIF
12582  160 CONTINUE
12583 
12584  ELSEIF(kfla.EQ.18) THEN
12585 C...nu'_tau neutrino.
12586  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
12587  DO 170 i=1,mdcy(kc,3)
12588  idc=i+mdcy(kc,2)-1
12589  IF(mdme(idc,1).LT.0) goto 170
12590  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
12591  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
12592  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 170
12593  IF(i.EQ.2) THEN
12594 C...nu'_tau -> W + tau'.
12595  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12596  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
12597  IF(kflr.GT.0) THEN
12598  wid2=wids(24,2)
12599  wid2=wid2*wids(17,2)
12600  ELSE
12601  wid2=wids(24,3)
12602  wid2=wid2*wids(17,3)
12603  ENDIF
12604  ELSEIF(i.EQ.3) THEN
12605 C...nu'_tau -> H + tau'.
12606  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
12607  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
12608  IF(kflr.GT.0) THEN
12609  wid2=wids(37,2)
12610  wid2=wid2*wids(17,2)
12611  ELSE
12612  wid2=wids(37,3)
12613  wid2=wid2*wids(17,3)
12614  ENDIF
12615  ENDIF
12616  wdtp(0)=wdtp(0)+wdtp(i)
12617  IF(mdme(idc,1).GT.0) THEN
12618  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12619  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12620  wdte(i,0)=wdte(i,mdme(idc,1))
12621  wdte(0,0)=wdte(0,0)+wdte(i,0)
12622  ENDIF
12623  170 CONTINUE
12624 
12625  ELSEIF(kfla.EQ.21) THEN
12626 C...QCD:
12627 C***Note that widths are not given in dimensional quantities here.
12628  DO 180 i=1,mdcy(kc,3)
12629  idc=i+mdcy(kc,2)-1
12630  IF(mdme(idc,1).LT.0) goto 180
12631  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
12632  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
12633  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 180
12634  wid2=1d0
12635  IF(i.LE.8) THEN
12636 C...QCD -> q + qbar
12637  wdtp(i)=(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
12638  IF(i.EQ.6) wid2=wids(6,1)
12639  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
12640  ENDIF
12641  wdtp(0)=wdtp(0)+wdtp(i)
12642  IF(mdme(idc,1).GT.0) THEN
12643  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12644  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12645  wdte(i,0)=wdte(i,mdme(idc,1))
12646  wdte(0,0)=wdte(0,0)+wdte(i,0)
12647  ENDIF
12648  180 CONTINUE
12649 
12650  ELSEIF(kfla.EQ.22) THEN
12651 C...QED photon.
12652 C***Note that widths are not given in dimensional quantities here.
12653  DO 190 i=1,mdcy(kc,3)
12654  idc=i+mdcy(kc,2)-1
12655  IF(mdme(idc,1).LT.0) goto 190
12656  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
12657  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
12658  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 190
12659  wid2=1d0
12660  IF(i.LE.8) THEN
12661 C...QED -> q + qbar.
12662  ef=kchg(i,1)/3d0
12663  fcof=3d0*radc
12664  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
12665  wdtp(i)=fcof*ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
12666  IF(i.EQ.6) wid2=wids(6,1)
12667  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
12668  ELSEIF(i.LE.12) THEN
12669 C...QED -> l+ + l-.
12670  ef=kchg(9+2*(i-8),1)/3d0
12671  wdtp(i)=ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
12672  IF(i.EQ.12) wid2=wids(17,1)
12673  ENDIF
12674  wdtp(0)=wdtp(0)+wdtp(i)
12675  IF(mdme(idc,1).GT.0) THEN
12676  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12677  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12678  wdte(i,0)=wdte(i,mdme(idc,1))
12679  wdte(0,0)=wdte(0,0)+wdte(i,0)
12680  ENDIF
12681  190 CONTINUE
12682 
12683  ELSEIF(kfla.EQ.23) THEN
12684 C...Z0:
12685  icase=1
12686  xwc=1d0/(16d0*xw*xw1)
12687  fac=(aem*xwc/3d0)*shr
12688  200 CONTINUE
12689  IF(mint(61).GE.1.AND.icase.EQ.2) THEN
12690  vint(111)=0d0
12691  vint(112)=0d0
12692  vint(114)=0d0
12693  ENDIF
12694  IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
12695  kfi=iabs(mint(15))
12696  IF(kfi.GT.20) kfi=iabs(mint(16))
12697  ei=kchg(kfi,1)/3d0
12698  ai=sign(1d0,ei)
12699  vi=ai-4d0*ei*xwv
12700  sqmz=pmas(23,1)**2
12701  hz=shr*wdtp(0)
12702  IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=1d0
12703  IF(mstp(43).EQ.3) vint(112)=
12704  & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
12705  IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
12706  & xwc**2*sh**2/((sh-sqmz)**2+hz**2)
12707  ENDIF
12708  DO 210 i=1,mdcy(kc,3)
12709  idc=i+mdcy(kc,2)-1
12710  IF(mdme(idc,1).LT.0) goto 210
12711  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
12712  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
12713  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 210
12714  wid2=1d0
12715  IF(i.LE.8) THEN
12716 C...Z0 -> q + qbar
12717  ef=kchg(i,1)/3d0
12718  af=sign(1d0,ef+0.1d0)
12719  vf=af-4d0*ef*xwv
12720  fcof=3d0*radc
12721  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
12722  IF(i.EQ.6) wid2=wids(6,1)
12723  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
12724  ELSEIF(i.LE.16) THEN
12725 C...Z0 -> l+ + l-, nu + nubar
12726  ef=kchg(i+2,1)/3d0
12727  af=sign(1d0,ef+0.1d0)
12728  vf=af-4d0*ef*xwv
12729  fcof=1d0
12730  IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
12731  ENDIF
12732  be34=sqrt(max(0d0,1d0-4d0*rm1))
12733  IF(icase.EQ.1) THEN
12734  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
12735  & be34
12736  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
12737  wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
12738  & ef*vf+(vi**2+ai**2)*vint(114)*vf**2)*(1d0+2d0*rm1)+
12739  & (vi**2+ai**2)*vint(114)*af**2*(1d0-4d0*rm1))*be34
12740  ELSEIF(mint(61).EQ.2.AND.icase.EQ.2) THEN
12741  fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
12742  fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
12743  fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
12744  ENDIF
12745  IF(icase.EQ.1) wdtp(0)=wdtp(0)+wdtp(i)
12746  IF(mdme(idc,1).GT.0) THEN
12747  IF((icase.EQ.1.AND.mint(61).NE.1).OR.
12748  & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
12749  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12750  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
12751  & wdte(i,mdme(idc,1))
12752  wdte(i,0)=wdte(i,mdme(idc,1))
12753  wdte(0,0)=wdte(0,0)+wdte(i,0)
12754  ENDIF
12755  IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
12756  IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=
12757  & vint(111)+fggf*wid2
12758  IF(mstp(43).EQ.3) vint(112)=vint(112)+fgzf*wid2
12759  IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
12760  & vint(114)+fzzf*wid2
12761  ENDIF
12762  ENDIF
12763  210 CONTINUE
12764  IF(mint(61).GE.1) icase=3-icase
12765  IF(icase.EQ.2) goto 200
12766 
12767  ELSEIF(kfla.EQ.24) THEN
12768 C...W+/-:
12769  fac=(aem/(24d0*xw))*shr
12770  DO 220 i=1,mdcy(kc,3)
12771  idc=i+mdcy(kc,2)-1
12772  IF(mdme(idc,1).LT.0) goto 220
12773  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
12774  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
12775  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 220
12776  wid2=1d0
12777  IF(i.LE.16) THEN
12778 C...W+/- -> q + qbar'
12779  fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
12780  IF(kflr.GT.0) THEN
12781  IF(mod(i,4).EQ.3) wid2=wids(6,2)
12782  IF(mod(i,4).EQ.0) wid2=wids(8,2)
12783  IF(i.GE.13) wid2=wid2*wids(7,3)
12784  ELSE
12785  IF(mod(i,4).EQ.3) wid2=wids(6,3)
12786  IF(mod(i,4).EQ.0) wid2=wids(8,3)
12787  IF(i.GE.13) wid2=wid2*wids(7,2)
12788  ENDIF
12789  ELSEIF(i.LE.20) THEN
12790 C...W+/- -> l+/- + nu
12791  fcof=1d0
12792  IF(kflr.GT.0) THEN
12793  IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
12794  ELSE
12795  IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
12796  ENDIF
12797  ENDIF
12798  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
12799  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
12800  wdtp(0)=wdtp(0)+wdtp(i)
12801  IF(mdme(idc,1).GT.0) THEN
12802  wdte(i,mdme(idc,1))=wdtp(i)*wid2
12803  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
12804  wdte(i,0)=wdte(i,mdme(idc,1))
12805  wdte(0,0)=wdte(0,0)+wdte(i,0)
12806  ENDIF
12807  220 CONTINUE
12808 
12809  ELSEIF(kfla.EQ.25.OR.kfla.EQ.35.OR.kfla.EQ.36) THEN
12810 C...h0 (or H0, or A0):
12811  IF(mstp(49).EQ.0) THEN
12812  fac=(aem/(8d0*xw))*(sh/pmas(24,1)**2)*shr
12813  ELSE
12814  fac=(aem/(8d0*xw))*(pmas(kfhigg,1)/pmas(24,1))**2*shr
12815  ENDIF
12816  DO 260 i=1,mdcy(kfhigg,3)
12817  idc=i+mdcy(kfhigg,2)-1
12818  IF(mdme(idc,1).LT.0) goto 260
12819  kfc1=pycomp(kfdp(idc,1))
12820  kfc2=pycomp(kfdp(idc,2))
12821  rm1=pmas(kfc1,1)**2/sh
12822  rm2=pmas(kfc2,1)**2/sh
12823  IF(i.NE.16.AND.i.NE.17.AND.sqrt(rm1)+sqrt(rm2).GT.1d0)
12824  & goto 260
12825  wid2=1d0
12826 
12827  IF(i.LE.8) THEN
12828 C...h0 -> q + qbar
12829  wdtp(i)=fac*3d0*rm1*(1d0-4d0*rm1)*sqrt(max(0d0,
12830  & 1d0-4d0*rm1))*radc
12831  IF(mstp(37).EQ.1.AND.mstp(2).GE.1) wdtp(i)=wdtp(i)*
12832  & (log(max(4d0,parp(37)**2*rm1*sh/paru(117)**2))/
12833  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
12834  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
12835  IF(mod(i,2).EQ.1) wdtp(i)=wdtp(i)*paru(151+10*ihigg)**2
12836  IF(mod(i,2).EQ.0) wdtp(i)=wdtp(i)*paru(152+10*ihigg)**2
12837  ENDIF
12838  IF(i.EQ.6) wid2=wids(6,1)
12839  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
12840 
12841  ELSEIF(i.LE.12) THEN
12842 C...h0 -> l+ + l-
12843  wdtp(i)=fac*rm1*(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
12844  IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
12845  & paru(153+10*ihigg)**2
12846  IF(i.EQ.12) wid2=wids(17,1)
12847 
12848  ELSEIF(i.EQ.13) THEN
12849 C...h0 -> g + g; quark loop contribution only
12850  etare=0d0
12851  etaim=0d0
12852  DO 230 j=1,2*mstp(1)
12853  eps=(2d0*pmas(j,1))**2/sh
12854 C...Loop integral; function of eps=4m^2/shat; different for A0.
12855  IF(eps.LE.1d0) THEN
12856  IF(eps.GT.1.d-4) THEN
12857  root=sqrt(1d0-eps)
12858  rln=log((1d0+root)/(1d0-root))
12859  ELSE
12860  rln=log(4d0/eps-2d0)
12861  ENDIF
12862  phire=-0.25d0*(rln**2-paru(1)**2)
12863  phiim=0.5d0*paru(1)*rln
12864  ELSE
12865  phire=(asin(1d0/sqrt(eps)))**2
12866  phiim=0d0
12867  ENDIF
12868  IF(ihigg.LE.2) THEN
12869  etarej=-0.5d0*eps*(1d0+(1d0-eps)*phire)
12870  etaimj=-0.5d0*eps*(1d0-eps)*phiim
12871  ELSE
12872  etarej=-0.5d0*eps*phire
12873  etaimj=-0.5d0*eps*phiim
12874  ENDIF
12875 C...Couplings (=1 for standard model Higgs).
12876  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
12877  IF(mod(j,2).EQ.1) THEN
12878  etarej=etarej*paru(151+10*ihigg)
12879  etaimj=etaimj*paru(151+10*ihigg)
12880  ELSE
12881  etarej=etarej*paru(152+10*ihigg)
12882  etaimj=etaimj*paru(152+10*ihigg)
12883  ENDIF
12884  ENDIF
12885  etare=etare+etarej
12886  etaim=etaim+etaimj
12887  230 CONTINUE
12888  eta2=etare**2+etaim**2
12889  wdtp(i)=fac*(as/paru(1))**2*eta2
12890 
12891  ELSEIF(i.EQ.14) THEN
12892 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
12893  etare=0d0
12894  etaim=0d0
12895  jmax=3*mstp(1)+1
12896  IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
12897  DO 240 j=1,jmax
12898  IF(j.LE.2*mstp(1)) THEN
12899  ej=kchg(j,1)/3d0
12900  eps=(2d0*pmas(j,1))**2/sh
12901  ELSEIF(j.LE.3*mstp(1)) THEN
12902  jl=2*(j-2*mstp(1))-1
12903  ej=kchg(10+jl,1)/3d0
12904  eps=(2d0*pmas(10+jl,1))**2/sh
12905  ELSEIF(j.EQ.3*mstp(1)+1) THEN
12906  eps=(2d0*pmas(24,1))**2/sh
12907  ELSE
12908  eps=(2d0*pmas(37,1))**2/sh
12909  ENDIF
12910 C...Loop integral; function of eps=4m^2/shat.
12911  IF(eps.LE.1d0) THEN
12912  IF(eps.GT.1.d-4) THEN
12913  root=sqrt(1d0-eps)
12914  rln=log((1d0+root)/(1d0-root))
12915  ELSE
12916  rln=log(4d0/eps-2d0)
12917  ENDIF
12918  phire=-0.25d0*(rln**2-paru(1)**2)
12919  phiim=0.5d0*paru(1)*rln
12920  ELSE
12921  phire=(asin(1d0/sqrt(eps)))**2
12922  phiim=0d0
12923  ENDIF
12924  IF(j.LE.3*mstp(1)) THEN
12925 C...Fermion loops: loop integral different for A0; charges.
12926  IF(ihigg.LE.2) THEN
12927  phipre=-0.5d0*eps*(1d0+(1d0-eps)*phire)
12928  phipim=-0.5d0*eps*(1d0-eps)*phiim
12929  ELSE
12930  phipre=-0.5d0*eps*phire
12931  phipim=-0.5d0*eps*phiim
12932  ENDIF
12933  IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
12934  ejc=3d0*ej**2
12935  ejh=paru(151+10*ihigg)
12936  ELSEIF(j.LE.2*mstp(1)) THEN
12937  ejc=3d0*ej**2
12938  ejh=paru(152+10*ihigg)
12939  ELSE
12940  ejc=ej**2
12941  ejh=paru(153+10*ihigg)
12942  ENDIF
12943  IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
12944  etarej=ejc*ejh*phipre
12945  etaimj=ejc*ejh*phipim
12946  ELSEIF(j.EQ.3*mstp(1)+1) THEN
12947 C...W loops: loop integral and charges.
12948  etarej=0.5d0+0.75d0*eps*(1d0+(2d0-eps)*phire)
12949  etaimj=0.75d0*eps*(2d0-eps)*phiim
12950  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
12951  etarej=etarej*paru(155+10*ihigg)
12952  etaimj=etaimj*paru(155+10*ihigg)
12953  ENDIF
12954  ELSE
12955 C...Charged H loops: loop integral and charges.
12956  fachhh=(pmas(24,1)/pmas(37,1))**2*
12957  & paru(158+10*ihigg+2*(ihigg/3))
12958  etarej=eps*(1d0-eps*phire)*fachhh
12959  etaimj=-eps**2*phiim*fachhh
12960  ENDIF
12961  etare=etare+etarej
12962  etaim=etaim+etaimj
12963  240 CONTINUE
12964  eta2=etare**2+etaim**2
12965  wdtp(i)=fac*(aem/paru(1))**2*0.5d0*eta2
12966 
12967  ELSEIF(i.EQ.15) THEN
12968 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
12969  etare=0d0
12970  etaim=0d0
12971  jmax=3*mstp(1)+1
12972  IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
12973  DO 250 j=1,jmax
12974  IF(j.LE.2*mstp(1)) THEN
12975  ej=kchg(j,1)/3d0
12976  aj=sign(1d0,ej+0.1d0)
12977  vj=aj-4d0*ej*xwv
12978  eps=(2d0*pmas(j,1))**2/sh
12979  epsp=(2d0*pmas(j,1)/pmas(23,1))**2
12980  ELSEIF(j.LE.3*mstp(1)) THEN
12981  jl=2*(j-2*mstp(1))-1
12982  ej=kchg(10+jl,1)/3d0
12983  aj=sign(1d0,ej+0.1d0)
12984  vj=aj-4d0*ej*xwv
12985  eps=(2d0*pmas(10+jl,1))**2/sh
12986  epsp=(2d0*pmas(10+jl,1)/pmas(23,1))**2
12987  ELSE
12988  eps=(2d0*pmas(24,1))**2/sh
12989  epsp=(2d0*pmas(24,1)/pmas(23,1))**2
12990  ENDIF
12991 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
12992  IF(eps.LE.1d0) THEN
12993  root=sqrt(1d0-eps)
12994  IF(eps.GT.1.d-4) THEN
12995  rln=log((1d0+root)/(1d0-root))
12996  ELSE
12997  rln=log(4d0/eps-2d0)
12998  ENDIF
12999  phire=-0.25d0*(rln**2-paru(1)**2)
13000  phiim=0.5d0*paru(1)*rln
13001  psire=0.5d0*root*rln
13002  psiim=-0.5d0*root*paru(1)
13003  ELSE
13004  phire=(asin(1d0/sqrt(eps)))**2
13005  phiim=0d0
13006  psire=sqrt(eps-1d0)*asin(1d0/sqrt(eps))
13007  psiim=0d0
13008  ENDIF
13009  IF(epsp.LE.1d0) THEN
13010  root=sqrt(1d0-epsp)
13011  IF(epsp.GT.1.d-4) THEN
13012  rln=log((1d0+root)/(1d0-root))
13013  ELSE
13014  rln=log(4d0/epsp-2d0)
13015  ENDIF
13016  phirep=-0.25d0*(rln**2-paru(1)**2)
13017  phiimp=0.5d0*paru(1)*rln
13018  psirep=0.5d0*root*rln
13019  psiimp=-0.5d0*root*paru(1)
13020  ELSE
13021  phirep=(asin(1d0/sqrt(epsp)))**2
13022  phiimp=0d0
13023  psirep=sqrt(epsp-1d0)*asin(1d0/sqrt(epsp))
13024  psiimp=0d0
13025  ENDIF
13026  fxyre=eps*epsp/(8d0*(eps-epsp))*(1d0+eps*epsp/(eps-epsp)*
13027  & (phire-phirep)+2d0*eps/(eps-epsp)*(psire-psirep))
13028  fxyim=eps**2*epsp/(8d0*(eps-epsp)**2)*
13029  & (epsp*(phiim-phiimp)+2d0*(psiim-psiimp))
13030  f1re=-eps*epsp/(2d0*(eps-epsp))*(phire-phirep)
13031  f1im=-eps*epsp/(2d0*(eps-epsp))*(phiim-phiimp)
13032  IF(j.LE.3*mstp(1)) THEN
13033 C...Fermion loops: loop integral different for A0; charges.
13034  IF(ihigg.EQ.3) fxyre=0d0
13035  IF(ihigg.EQ.3) fxyim=0d0
13036  IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
13037  ejc=-3d0*ej*vj
13038  ejh=paru(151+10*ihigg)
13039  ELSEIF(j.LE.2*mstp(1)) THEN
13040  ejc=-3d0*ej*vj
13041  ejh=paru(152+10*ihigg)
13042  ELSE
13043  ejc=-ej*vj
13044  ejh=paru(153+10*ihigg)
13045  ENDIF
13046  IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
13047  etarej=ejc*ejh*(fxyre-0.25d0*f1re)
13048  etaimj=ejc*ejh*(fxyim-0.25d0*f1im)
13049  ELSEIF(j.EQ.3*mstp(1)+1) THEN
13050 C...W loops: loop integral and charges.
13051  heps=(1d0+2d0/eps)*xw/xw1-(5d0+2d0/eps)
13052  etarej=-xw1*((3d0-xw/xw1)*f1re+heps*fxyre)
13053  etaimj=-xw1*((3d0-xw/xw1)*f1im+heps*fxyim)
13054  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
13055  etarej=etarej*paru(155+10*ihigg)
13056  etaimj=etaimj*paru(155+10*ihigg)
13057  ENDIF
13058  ELSE
13059 C...Charged H loops: loop integral and charges.
13060  fachhh=(pmas(24,1)/pmas(37,1))**2*(1d0-2d0*xw)*
13061  & paru(158+10*ihigg+2*(ihigg/3))
13062  etarej=fachhh*fxyre
13063  etaimj=fachhh*fxyim
13064  ENDIF
13065  etare=etare+etarej
13066  etaim=etaim+etaimj
13067  250 CONTINUE
13068  eta2=(etare**2+etaim**2)/(xw*xw1)
13069  wdtp(i)=fac*(aem/paru(1))**2*(1d0-pmas(23,1)**2/sh)**3*eta2
13070  wid2=wids(23,2)
13071 
13072  ELSEIF(i.LE.17) THEN
13073 C...h0 -> Z0 + Z0, W+ + W-
13074  pm1=pmas(iabs(kfdp(idc,1)),1)
13075  pg1=pmas(iabs(kfdp(idc,1)),2)
13076  IF(mint(62).GE.1) THEN
13077  IF(mstp(42).EQ.0.OR.(4d0*(pm1+10d0*pg1)**2.LT.sh.AND.
13078  & ckin(46).LT.ckin(45).AND.ckin(48).LT.ckin(47).AND.
13079  & max(ckin(45),ckin(47)).LT.pm1-10d0*pg1)) THEN
13080  mofsv(ihigg,i-15)=0
13081  widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
13082  & 1d0-4d0*rm1))
13083  wid2=1d0
13084  ELSE
13085  mofsv(ihigg,i-15)=1
13086  rmas=sqrt(max(0d0,sh))
13087  CALL pyofsh(1,kfla,kfdp(idc,1),kfdp(idc,2),rmas,widw,
13088  & wid2)
13089  widwsv(ihigg,i-15)=widw
13090  wid2sv(ihigg,i-15)=wid2
13091  ENDIF
13092  ELSE
13093  IF(mofsv(ihigg,i-15).EQ.0) THEN
13094  widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
13095  & 1d0-4d0*rm1))
13096  wid2=1d0
13097  ELSE
13098  widw=widwsv(ihigg,i-15)
13099  wid2=wid2sv(ihigg,i-15)
13100  ENDIF
13101  ENDIF
13102  wdtp(i)=fac*widw/(2d0*(18-i))
13103  IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
13104  & paru(138+i+10*ihigg)**2
13105  wid2=wid2*wids(7+i,1)
13106 
13107  ELSEIF(i.EQ.18.AND.kfla.EQ.35) THEN
13108 C***H0 -> Z0 + h0 (not yet implemented).
13109 
13110  ELSEIF(i.EQ.19.AND.kfla.EQ.35) THEN
13111 C...H0 -> h0 + h0.
13112  wdtp(i)=fac*paru(176)**2*0.25d0*pmas(23,1)**4/sh**2*
13113  & sqrt(max(0d0,1d0-4d0*rm1))
13114  wid2=wids(25,2)**2
13115 
13116  ELSEIF(i.EQ.20.AND.kfla.EQ.35) THEN
13117 C...H0 -> A0 + A0.
13118  wdtp(i)=fac*paru(177)**2*0.25d0*pmas(23,1)**4/sh**2*
13119  & sqrt(max(0d0,1d0-4d0*rm1))
13120  wid2=wids(36,2)**2
13121 
13122  ELSEIF(i.EQ.18.AND.kfla.EQ.36) THEN
13123 C...A0 -> Z0 + h0.
13124  wdtp(i)=fac*paru(186)**2*0.5d0*sqrt(max(0d0,
13125  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13126  wid2=wids(23,2)*wids(25,2)
13127 
13128 CMRENNA++
13129  ELSE
13130 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13131  rm10=rm1*sh/pmr**2
13132  rm20=rm2*sh/pmr**2
13133  wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
13134  wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
13135  IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
13136  wfac=0d0
13137  ELSE
13138  wfac=wfac/wfac0
13139  ENDIF
13140  wdtp(i)=pmas(kfla,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
13141 CMRENNA--
13142  IF(kfc2.EQ.kfc1) THEN
13143  wid2=wids(kfc1,1)
13144  ELSE
13145  ksgn1=2
13146  IF(kfdp(idc,1).LT.0) ksgn1=3
13147  ksgn2=2
13148  IF(kfdp(idc,2).LT.0) ksgn2=3
13149  wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
13150  ENDIF
13151  ENDIF
13152  wdtp(0)=wdtp(0)+wdtp(i)
13153  IF(mdme(idc,1).GT.0) THEN
13154  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13155  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13156  wdte(i,0)=wdte(i,mdme(idc,1))
13157  wdte(0,0)=wdte(0,0)+wdte(i,0)
13158  ENDIF
13159  260 CONTINUE
13160 
13161  ELSEIF(kfla.EQ.32) THEN
13162 C...Z'0:
13163  icase=1
13164  xwc=1d0/(16d0*xw*xw1)
13165  fac=(aem*xwc/3d0)*shr
13166  vint(117)=0d0
13167  270 CONTINUE
13168  IF(mint(61).GE.1.AND.icase.EQ.2) THEN
13169  vint(111)=0d0
13170  vint(112)=0d0
13171  vint(113)=0d0
13172  vint(114)=0d0
13173  vint(115)=0d0
13174  vint(116)=0d0
13175  ENDIF
13176  IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
13177  kfai=iabs(mint(15))
13178  ei=kchg(kfai,1)/3d0
13179  ai=sign(1d0,ei+0.1d0)
13180  vi=ai-4d0*ei*xwv
13181  kfaic=1
13182  IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
13183  IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
13184  IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
13185  vpi=paru(119+2*kfaic)
13186  api=paru(120+2*kfaic)
13187  sqmz=pmas(23,1)**2
13188  hz=shr*fac*vint(117)
13189  sqmzp=pmas(32,1)**2
13190  hzp=shr*fac*wdtp(0)
13191  IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
13192  & mstp(44).EQ.7) vint(111)=1d0
13193  IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=
13194  & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
13195  IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=
13196  & 2d0*xwc*sh*(sh-sqmzp)/((sh-sqmzp)**2+hzp**2)
13197  IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
13198  & mstp(44).EQ.7) vint(114)=xwc**2*sh**2/((sh-sqmz)**2+hz**2)
13199  IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=
13200  & 2d0*xwc**2*sh**2*((sh-sqmz)*(sh-sqmzp)+hz*hzp)/
13201  & (((sh-sqmz)**2+hz**2)*((sh-sqmzp)**2+hzp**2))
13202  IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
13203  & mstp(44).EQ.7) vint(116)=xwc**2*sh**2/((sh-sqmzp)**2+hzp**2)
13204  ENDIF
13205  DO 280 i=1,mdcy(kc,3)
13206  idc=i+mdcy(kc,2)-1
13207  IF(mdme(idc,1).LT.0) goto 280
13208  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13209  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13210  IF(sqrt(rm1)+sqrt(rm2).GT.1d0.OR.mdme(idc,1).LT.0) goto 280
13211  wid2=1d0
13212  IF(i.LE.16) THEN
13213  IF(i.LE.8) THEN
13214 C...Z'0 -> q + qbar
13215  ef=kchg(i,1)/3d0
13216  af=sign(1d0,ef+0.1d0)
13217  vf=af-4d0*ef*xwv
13218  vpf=paru(123-2*mod(i,2))
13219  apf=paru(124-2*mod(i,2))
13220  fcof=3d0*radc
13221  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
13222  & pyhfth(sh,sh*rm1,1d0)
13223  IF(i.EQ.6) wid2=wids(6,1)
13224  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
13225  ELSEIF(i.LE.16) THEN
13226 C...Z'0 -> l+ + l-, nu + nubar
13227  ef=kchg(i+2,1)/3d0
13228  af=sign(1d0,ef+0.1d0)
13229  vf=af-4d0*ef*xwv
13230  vpf=paru(127-2*mod(i,2))
13231  apf=paru(128-2*mod(i,2))
13232  fcof=1d0
13233  IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
13234  ENDIF
13235  be34=sqrt(max(0d0,1d0-4d0*rm1))
13236  IF(icase.EQ.1) THEN
13237  wdtpz=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
13238  wdtp(i)=fac*fcof*(vpf**2*(1d0+2d0*rm1)+
13239  & apf**2*(1d0-4d0*rm1))*be34
13240  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
13241  wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
13242  & ef*vf+ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
13243  & vf**2+(vi*vpi+ai*api)*vint(115)*vf*vpf+(vpi**2+api**2)*
13244  & vint(116)*vpf**2)*(1d0+2d0*rm1)+((vi**2+ai**2)*vint(114)*
13245  & af**2+(vi*vpi+ai*api)*vint(115)*af*apf+(vpi**2+api**2)*
13246  & vint(116)*apf**2)*(1d0-4d0*rm1))*be34
13247  ELSEIF(mint(61).EQ.2) THEN
13248  fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
13249  fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
13250  fgzpf=fcof*ef*vpf*(1d0+2d0*rm1)*be34
13251  fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
13252  fzzpf=fcof*(vf*vpf*(1d0+2d0*rm1)+af*apf*(1d0-4d0*rm1))*
13253  & be34
13254  fzpzpf=fcof*(vpf**2*(1d0+2d0*rm1)+apf**2*(1d0-4d0*rm1))*
13255  & be34
13256  ENDIF
13257  ELSEIF(i.EQ.17) THEN
13258 C...Z'0 -> W+ + W-
13259  wdtpzp=paru(129)**2*xw1**2*
13260  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
13261  & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
13262  IF(icase.EQ.1) THEN
13263  wdtpz=0d0
13264  wdtp(i)=fac*wdtpzp
13265  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
13266  wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
13267  ELSEIF(mint(61).EQ.2) THEN
13268  fggf=0d0
13269  fgzf=0d0
13270  fgzpf=0d0
13271  fzzf=0d0
13272  fzzpf=0d0
13273  fzpzpf=wdtpzp
13274  ENDIF
13275  wid2=wids(24,1)
13276  ELSEIF(i.EQ.18) THEN
13277 C...Z'0 -> H+ + H-
13278  czc=2d0*(1d0-2d0*xw)
13279  be34c=(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
13280  IF(icase.EQ.1) THEN
13281  wdtpz=0.25d0*paru(142)**2*czc**2*be34c
13282  wdtp(i)=fac*0.25d0*paru(143)**2*czc**2*be34c
13283  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
13284  wdtp(i)=fac*0.25d0*(ei**2*vint(111)+paru(142)*ei*vi*
13285  & vint(112)*czc+paru(143)*ei*vpi*vint(113)*czc+paru(142)**2*
13286  & (vi**2+ai**2)*vint(114)*czc**2+paru(142)*paru(143)*
13287  & (vi*vpi+ai*api)*vint(115)*czc**2+paru(143)**2*
13288  & (vpi**2+api**2)*vint(116)*czc**2)*be34c
13289  ELSEIF(mint(61).EQ.2) THEN
13290  fggf=0.25d0*be34c
13291  fgzf=0.25d0*paru(142)*czc*be34c
13292  fgzpf=0.25d0*paru(143)*czc*be34c
13293  fzzf=0.25d0*paru(142)**2*czc**2*be34c
13294  fzzpf=0.25d0*paru(142)*paru(143)*czc**2*be34c
13295  fzpzpf=0.25d0*paru(143)**2*czc**2*be34c
13296  ENDIF
13297  wid2=wids(37,1)
13298  ELSEIF(i.EQ.19) THEN
13299 C...Z'0 -> Z0 + gamma.
13300  ELSEIF(i.EQ.20) THEN
13301 C...Z'0 -> Z0 + h0
13302  flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13303  wdtpzp=paru(145)**2*4d0*abs(1d0-2d0*xw)*
13304  & (3d0*rm1+0.25d0*flam**2)*flam
13305  IF(icase.EQ.1) THEN
13306  wdtpz=0d0
13307  wdtp(i)=fac*wdtpzp
13308  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
13309  wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
13310  ELSEIF(mint(61).EQ.2) THEN
13311  fggf=0d0
13312  fgzf=0d0
13313  fgzpf=0d0
13314  fzzf=0d0
13315  fzzpf=0d0
13316  fzpzpf=wdtpzp
13317  ENDIF
13318  wid2=wids(23,2)*wids(25,2)
13319  ELSEIF(i.EQ.21.OR.i.EQ.22) THEN
13320 C...Z' -> h0 + A0 or H0 + A0.
13321  be34c=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13322  IF(i.EQ.21) THEN
13323  czah=paru(186)
13324  czpah=paru(188)
13325  ELSE
13326  czah=paru(187)
13327  czpah=paru(189)
13328  ENDIF
13329  IF(icase.EQ.1) THEN
13330  wdtpz=czah**2*be34c
13331  wdtp(i)=fac*czpah**2*be34c
13332  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
13333  wdtp(i)=fac*(czah**2*(vi**2+ai**2)*vint(114)+czah*czpah*
13334  & (vi*vpi+ai*api)*vint(115)+czpah**2*(vpi**2+api**2)*
13335  & vint(116))*be34c
13336  ELSEIF(mint(61).EQ.2) THEN
13337  fggf=0d0
13338  fgzf=0d0
13339  fgzpf=0d0
13340  fzzf=czah**2*be34c
13341  fzzpf=czah*czpah*be34c
13342  fzpzpf=czpah**2*be34c
13343  ENDIF
13344  IF(i.EQ.21) wid2=wids(25,2)*wids(36,2)
13345  IF(i.EQ.22) wid2=wids(35,2)*wids(36,2)
13346  ENDIF
13347  IF(icase.EQ.1) THEN
13348  vint(117)=vint(117)+wdtpz
13349  wdtp(0)=wdtp(0)+wdtp(i)
13350  ENDIF
13351  IF(mdme(idc,1).GT.0) THEN
13352  IF((icase.EQ.1.AND.mint(61).NE.1).OR.
13353  & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
13354  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13355  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
13356  & wdte(i,mdme(idc,1))
13357  wdte(i,0)=wdte(i,mdme(idc,1))
13358  wdte(0,0)=wdte(0,0)+wdte(i,0)
13359  ENDIF
13360  IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
13361  IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
13362  & mstp(44).EQ.7) vint(111)=vint(111)+fggf*wid2
13363  IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=vint(112)+
13364  & fgzf*wid2
13365  IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=vint(113)+
13366  & fgzpf*wid2
13367  IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
13368  & mstp(44).EQ.7) vint(114)=vint(114)+fzzf*wid2
13369  IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=vint(115)+
13370  & fzzpf*wid2
13371  IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
13372  & mstp(44).EQ.7) vint(116)=vint(116)+fzpzpf*wid2
13373  ENDIF
13374  ENDIF
13375  280 CONTINUE
13376  IF(mint(61).GE.1) icase=3-icase
13377  IF(icase.EQ.2) goto 270
13378 
13379  ELSEIF(kfla.EQ.34) THEN
13380 C...W'+/-:
13381  fac=(aem/(24d0*xw))*shr
13382  DO 290 i=1,mdcy(kc,3)
13383  idc=i+mdcy(kc,2)-1
13384  IF(mdme(idc,1).LT.0) goto 290
13385  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13386  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13387  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 290
13388  wid2=1d0
13389  IF(i.LE.20) THEN
13390  IF(i.LE.16) THEN
13391 C...W'+/- -> q + qbar'
13392  fcof=3d0*radc*(paru(131)**2+paru(132)**2)*
13393  & vckm((i-1)/4+1,mod(i-1,4)+1)
13394  IF(kflr.GT.0) THEN
13395  IF(mod(i,4).EQ.3) wid2=wids(6,2)
13396  IF(mod(i,4).EQ.0) wid2=wids(8,2)
13397  IF(i.GE.13) wid2=wid2*wids(7,3)
13398  ELSE
13399  IF(mod(i,4).EQ.3) wid2=wids(6,3)
13400  IF(mod(i,4).EQ.0) wid2=wids(8,3)
13401  IF(i.GE.13) wid2=wid2*wids(7,2)
13402  ENDIF
13403  ELSEIF(i.LE.20) THEN
13404 C...W'+/- -> l+/- + nu
13405  fcof=paru(133)**2+paru(134)**2
13406  IF(kflr.GT.0) THEN
13407  IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
13408  ELSE
13409  IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
13410  ENDIF
13411  ENDIF
13412  wdtp(i)=fac*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*
13413  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13414  ELSEIF(i.EQ.21) THEN
13415 C...W'+/- -> W+/- + Z0
13416  wdtp(i)=fac*paru(135)**2*0.5d0*xw1*(rm1/rm2)*
13417  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
13418  & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
13419  IF(kflr.GT.0) wid2=wids(24,2)*wids(23,2)
13420  IF(kflr.LT.0) wid2=wids(24,3)*wids(23,2)
13421  ELSEIF(i.EQ.23) THEN
13422 C...W'+/- -> W+/- + h0
13423  flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13424  wdtp(i)=fac*paru(146)**2*2d0*(3d0*rm1+0.25d0*flam**2)*flam
13425  IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
13426  IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
13427  ENDIF
13428  wdtp(0)=wdtp(0)+wdtp(i)
13429  IF(mdme(idc,1).GT.0) THEN
13430  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13431  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13432  wdte(i,0)=wdte(i,mdme(idc,1))
13433  wdte(0,0)=wdte(0,0)+wdte(i,0)
13434  ENDIF
13435  290 CONTINUE
13436 
13437  ELSEIF(kfla.EQ.37) THEN
13438 C...H+/-:
13439  fac=(aem/(8d0*xw))*(sh/pmas(24,1)**2)*shr
13440  DO 300 i=1,mdcy(kc,3)
13441  idc=i+mdcy(kc,2)-1
13442  IF(mdme(idc,1).LT.0) goto 300
13443  kfc1=pycomp(kfdp(idc,1))
13444  kfc2=pycomp(kfdp(idc,2))
13445  rm1=pmas(kfc1,1)**2/sh
13446  rm2=pmas(kfc2,1)**2/sh
13447  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 300
13448  wid2=1d0
13449  IF(i.LE.4) THEN
13450 C...H+/- -> q + qbar'
13451  rm1r=rm1
13452  IF(mstp(37).EQ.1.AND.mstp(2).GE.1) rm1r=rm1*
13453  & (log(max(4d0,parp(37)**2*rm1*sh/paru(117)**2))/
13454  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
13455  wdtp(i)=fac*3d0*radc*((rm1r*paru(141)**2+rm2/paru(141)**2)*
13456  & (1d0-rm1r-rm2)-4d0*rm1r*rm2)*
13457  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13458  IF(kflr.GT.0) THEN
13459  IF(i.EQ.3) wid2=wids(6,2)
13460  IF(i.EQ.4) wid2=wids(7,3)*wids(8,2)
13461  ELSE
13462  IF(i.EQ.3) wid2=wids(6,3)
13463  IF(i.EQ.4) wid2=wids(7,2)*wids(8,3)
13464  ENDIF
13465  ELSEIF(i.LE.8) THEN
13466 C...H+/- -> l+/- + nu
13467  wdtp(i)=fac*((rm1*paru(141)**2+rm2/paru(141)**2)*
13468  & (1d0-rm1-rm2)-4d0*rm1*rm2)*sqrt(max(0d0,(1d0-rm1-rm2)**2-
13469  & 4d0*rm1*rm2))
13470  IF(kflr.GT.0) THEN
13471  IF(i.EQ.8) wid2=wids(17,3)*wids(18,2)
13472  ELSE
13473  IF(i.EQ.8) wid2=wids(17,2)*wids(18,3)
13474  ENDIF
13475  ELSEIF(i.EQ.9) THEN
13476 C...H+/- -> W+/- + h0.
13477  wdtp(i)=fac*paru(195)**2*0.5d0*sqrt(max(0d0,
13478  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13479  IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
13480  IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
13481 
13482 CMRENNA++
13483  ELSE
13484 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13485  rm10=rm1*sh/pmr**2
13486  rm20=rm2*sh/pmr**2
13487  wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
13488  wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
13489  IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
13490  wfac=0d0
13491  ELSE
13492  wfac=wfac/wfac0
13493  ENDIF
13494  wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
13495 CMRENNA--
13496  ksgn1=2
13497  IF(kfls*kfdp(idc,1).LT.0.AND.kchg(kfc1,3).EQ.1) ksgn1=3
13498  ksgn2=2
13499  IF(kfls*kfdp(idc,2).LT.0.AND.kchg(kfc2,3).EQ.1) ksgn2=3
13500  wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
13501  ENDIF
13502  wdtp(0)=wdtp(0)+wdtp(i)
13503  IF(mdme(idc,1).GT.0) THEN
13504  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13505  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13506  wdte(i,0)=wdte(i,mdme(idc,1))
13507  wdte(0,0)=wdte(0,0)+wdte(i,0)
13508  ENDIF
13509  300 CONTINUE
13510 
13511  ELSEIF(kfla.EQ.38) THEN
13512 C...Techni-eta.
13513  fac=(sh/parp(46)**2)*shr
13514  DO 310 i=1,mdcy(kc,3)
13515  idc=i+mdcy(kc,2)-1
13516  IF(mdme(idc,1).LT.0) goto 310
13517  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13518  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13519  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 310
13520  wid2=1d0
13521  IF(i.LE.2) THEN
13522  wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))/(4d0*paru(1))
13523  IF(i.EQ.2) wid2=wids(6,1)
13524  ELSE
13525  wdtp(i)=fac*5d0*as**2/(96d0*paru(1)**3)
13526  ENDIF
13527  wdtp(0)=wdtp(0)+wdtp(i)
13528  IF(mdme(idc,1).GT.0) THEN
13529  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13530  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13531  wdte(i,0)=wdte(i,mdme(idc,1))
13532  wdte(0,0)=wdte(0,0)+wdte(i,0)
13533  ENDIF
13534  310 CONTINUE
13535 
13536  ELSEIF(kfla.EQ.39) THEN
13537 C...LQ (leptoquark).
13538  fac=(aem/4d0)*paru(151)*shr
13539  DO 320 i=1,mdcy(kc,3)
13540  idc=i+mdcy(kc,2)-1
13541  IF(mdme(idc,1).LT.0) goto 320
13542  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13543  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13544  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 320
13545  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13546  wid2=1d0
13547  wdtp(0)=wdtp(0)+wdtp(i)
13548  IF(mdme(idc,1).GT.0) THEN
13549  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13550  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13551  wdte(i,0)=wdte(i,mdme(idc,1))
13552  wdte(0,0)=wdte(0,0)+wdte(i,0)
13553  ENDIF
13554  320 CONTINUE
13555 
13556  ELSEIF(kfla.EQ.40) THEN
13557 C...R:
13558  fac=(aem/(12d0*xw))*shr
13559  DO 330 i=1,mdcy(kc,3)
13560  idc=i+mdcy(kc,2)-1
13561  IF(mdme(idc,1).LT.0) goto 330
13562  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13563  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13564  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 330
13565  wid2=1d0
13566  IF(i.LE.6) THEN
13567 C...R -> q + qbar'
13568  fcof=3d0*radc
13569  ELSEIF(i.LE.9) THEN
13570 C...R -> l+ + l'-
13571  fcof=1d0
13572  ENDIF
13573  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
13574  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13575  IF(kflr.GT.0) THEN
13576  IF(i.EQ.4) wid2=wids(6,3)
13577  IF(i.EQ.5) wid2=wids(7,3)
13578  IF(i.EQ.6) wid2=wids(6,2)*wids(8,3)
13579  IF(i.EQ.9) wid2=wids(17,3)
13580  ELSE
13581  IF(i.EQ.4) wid2=wids(6,2)
13582  IF(i.EQ.5) wid2=wids(7,2)
13583  IF(i.EQ.6) wid2=wids(6,3)*wids(8,2)
13584  IF(i.EQ.9) wid2=wids(17,2)
13585  ENDIF
13586  wdtp(0)=wdtp(0)+wdtp(i)
13587  IF(mdme(idc,1).GT.0) THEN
13588  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13589  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13590  wdte(i,0)=wdte(i,mdme(idc,1))
13591  wdte(0,0)=wdte(0,0)+wdte(i,0)
13592  ENDIF
13593  330 CONTINUE
13594 
13595  ELSEIF(kfla.EQ.51.OR.kfla.EQ.52) THEN
13596 C...Techni-pi0 and techni-pi+-:
13597  fac=(3d0/(32d0*paru(1)*parp(142)**2))*shr
13598  DO 340 i=1,mdcy(kc,3)
13599  idc=i+mdcy(kc,2)-1
13600  IF(mdme(idc,1).LT.0) goto 340
13601  pm1=pmas(pycomp(kfdp(idc,1)),1)
13602  pm2=pmas(pycomp(kfdp(idc,2)),1)
13603  rm1=pm1**2/sh
13604  rm2=pm2**2/sh
13605  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 340
13606  wid2=1d0
13607 C...pi_tech -> f + f'.
13608  fcof=1d0
13609  IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc
13610  wdtp(i)=fac*fcof*(pm1+pm2)**2*
13611  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13612  wdtp(0)=wdtp(0)+wdtp(i)
13613  IF(mdme(idc,1).GT.0) THEN
13614  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13615  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13616  wdte(i,0)=wdte(i,mdme(idc,1))
13617  wdte(0,0)=wdte(0,0)+wdte(i,0)
13618  ENDIF
13619  340 CONTINUE
13620 
13621  ELSEIF(kfla.EQ.53) THEN
13622 C...Techni-pi'0 not yet implemented.
13623 
13624  ELSEIF(kfla.EQ.54) THEN
13625 C...Techni-rho0:
13626  alprht=2.91d0*(3d0/parp(144))
13627  fac=(alprht/12d0)*shr
13628  facf=(1d0/6d0)*(aem**2/alprht)*(pmas(kfla,1)**4/shr**3)
13629  sqmz=pmas(23,1)**2
13630  gmmz=pmas(23,1)*pmas(23,2)
13631  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
13632  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
13633  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
13634  DO 350 i=1,mdcy(kc,3)
13635  idc=i+mdcy(kc,2)-1
13636  IF(mdme(idc,1).LT.0) goto 350
13637  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13638  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13639  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 350
13640  IF(i.EQ.1) THEN
13641 C...rho_tech0 -> W+ + W-.
13642  wdtp(i)=fac*parp(141)**4*
13643  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13644  wid2=wids(24,1)
13645  ELSEIF(i.EQ.2) THEN
13646 C...rho_tech0 -> W+ + pi_tech-.
13647  wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
13648  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13649  wid2=wids(24,2)*wids(52,3)
13650  ELSEIF(i.EQ.3) THEN
13651 C...rho_tech0 -> pi_tech+ + W-.
13652  wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
13653  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13654  wid2=wids(52,2)*wids(24,3)
13655  ELSEIF(i.EQ.4) THEN
13656 C...rho_tech0 -> pi_tech+ + pi_tech-.
13657  wdtp(i)=fac*(1d0-parp(141)**2)**2*
13658  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13659  wid2=wids(52,1)
13660  ELSE
13661 C...rho_tech0 -> f + fbar.
13662  wid2=1d0
13663  IF(i.LE.12) THEN
13664  ia=i-4
13665  fcof=3d0*radc
13666  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
13667  ELSE
13668  ia=i-2
13669  fcof=1d0
13670  IF(ia.GE.17) wid2=wids(ia,1)
13671  ENDIF
13672  ei=kchg(ia,1)/3d0
13673  ai=sign(1d0,ei+0.1d0)
13674  vi=ai-4d0*ei*xwv
13675  vali=0.5d0*(vi+ai)
13676  vari=0.5d0*(vi-ai)
13677  wdtp(i)=facf*fcof*(1d0-rm1)*sqrt(max(0d0,1d0-4d0*rm1))*
13678  & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
13679  & (ei+vari*bwzr)**2+(vari*bwzi)**2)
13680  ENDIF
13681  wdtp(0)=wdtp(0)+wdtp(i)
13682  IF(mdme(idc,1).GT.0) THEN
13683  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13684  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13685  wdte(i,0)=wdte(i,mdme(idc,1))
13686  wdte(0,0)=wdte(0,0)+wdte(i,0)
13687  ENDIF
13688  350 CONTINUE
13689 
13690  ELSEIF(kfla.EQ.55) THEN
13691 C...Techni-rho+/-:
13692  alprht=2.91d0*(3d0/parp(144))
13693  fac=(alprht/12d0)*shr
13694  sqmw=pmas(24,1)**2
13695  gmmw=pmas(24,1)*pmas(24,2)
13696  facf=(1d0/6d0)*(aem**2/alprht)*(pmas(kfla,1)**4/shr**3)*
13697  & (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
13698  DO 360 i=1,mdcy(kc,3)
13699  idc=i+mdcy(kc,2)-1
13700  IF(mdme(idc,1).LT.0) goto 360
13701  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13702  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13703  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 360
13704  IF(i.EQ.1) THEN
13705 C...rho_tech+ -> W+ + Z0.
13706  wdtp(i)=fac*parp(141)**4*
13707  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13708  IF(kflr.GT.0) THEN
13709  wid2=wids(24,2)*wids(23,2)
13710  ELSE
13711  wid2=wids(24,3)*wids(23,2)
13712  ENDIF
13713  ELSEIF(i.EQ.2) THEN
13714 C...rho_tech+ -> W+ + pi_tech0.
13715  wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
13716  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13717  IF(kflr.GT.0) THEN
13718  wid2=wids(24,2)*wids(51,2)
13719  ELSE
13720  wid2=wids(24,3)*wids(51,2)
13721  ENDIF
13722  ELSEIF(i.EQ.3) THEN
13723 C...rho_tech+ -> pi_tech+ + Z0.
13724  wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*
13725  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13726  IF(kflr.GT.0) THEN
13727  wid2=wids(52,2)*wids(23,2)
13728  ELSE
13729  wid2=wids(52,3)*wids(23,2)
13730  ENDIF
13731  ELSEIF(i.EQ.4) THEN
13732 C...rho_tech+ -> pi_tech+ + pi_tech0.
13733  wdtp(i)=fac*(1d0-parp(141)**2)**2*
13734  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13735  IF(kflr.GT.0) THEN
13736  wid2=wids(52,2)*wids(51,2)
13737  ELSE
13738  wid2=wids(52,3)*wids(51,2)
13739  ENDIF
13740  ELSE
13741 C...rho_tech+ -> f + fbar'.
13742  ia=i-4
13743  wid2=1d0
13744  IF(ia.LE.16) THEN
13745  fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
13746  IF(kflr.GT.0) THEN
13747  IF(mod(ia,4).EQ.3) wid2=wids(6,2)
13748  IF(mod(ia,4).EQ.0) wid2=wids(8,2)
13749  IF(ia.GE.13) wid2=wid2*wids(7,3)
13750  ELSE
13751  IF(mod(ia,4).EQ.3) wid2=wids(6,3)
13752  IF(mod(ia,4).EQ.0) wid2=wids(8,3)
13753  IF(ia.GE.13) wid2=wid2*wids(7,2)
13754  ENDIF
13755  ELSE
13756  fcof=1d0
13757  IF(kflr.GT.0) THEN
13758  IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
13759  ELSE
13760  IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
13761  ENDIF
13762  ENDIF
13763  wdtp(i)=facf*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*
13764  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
13765  ENDIF
13766  wdtp(0)=wdtp(0)+wdtp(i)
13767  IF(mdme(idc,1).GT.0) THEN
13768  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13769  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13770  wdte(i,0)=wdte(i,mdme(idc,1))
13771  wdte(0,0)=wdte(0,0)+wdte(i,0)
13772  ENDIF
13773  360 CONTINUE
13774 
13775  ELSEIF(kfla.EQ.56) THEN
13776 C...Techni-omega:
13777  alprht=2.91d0*(3d0/parp(144))
13778  fac=(aem/24d0)*(shr**3/parp(145)**2)
13779  facf=(1d0/6d0)*(aem**2/alprht)*(pmas(kfla,1)**4/shr**3)*
13780  & (2d0*parp(143)-1d0)**2
13781  sqmz=pmas(23,1)**2
13782  gmmz=pmas(23,1)*pmas(23,2)
13783  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
13784  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
13785  DO 370 i=1,mdcy(kc,3)
13786  idc=i+mdcy(kc,2)-1
13787  IF(mdme(idc,1).LT.0) goto 370
13788  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13789  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13790  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 370
13791  IF(i.EQ.1) THEN
13792 C...omega_tech0 -> gamma + pi_tech0.
13793  wdtp(i)=fac*
13794  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
13795  wid2=wids(51,2)
13796  ELSEIF(i.EQ.2) THEN
13797 C...omega_tech0 -> Z0 + pi_tech0 not known.
13798  wdtp(i)=0d0
13799  wid2=wids(23,2)*wids(51,2)
13800  ELSE
13801 C...omega_tech0 -> f + fbar.
13802  wid2=1d0
13803  IF(i.LE.10) THEN
13804  ia=i-2
13805  fcof=3d0*radc
13806  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
13807  ELSE
13808  ia=i
13809  fcof=1d0
13810  IF(ia.GE.17) wid2=wids(ia,1)
13811  ENDIF
13812  ei=kchg(ia,1)/3d0
13813  ai=sign(1d0,ei+0.1d0)
13814  vi=ai-4d0*ei*xwv
13815  vali=0.5d0*(vi+ai)
13816  vari=0.5d0*(vi-ai)
13817  wdtp(i)=facf*fcof*(1d0-rm1)*sqrt(max(0d0,1d0-4d0*rm1))*
13818  & ((ei-vali*bwzr)**2+(vali*bwzi)**2+
13819  & (ei-vari*bwzr)**2+(vari*bwzi)**2)
13820  ENDIF
13821  wdtp(0)=wdtp(0)+wdtp(i)
13822  IF(mdme(idc,1).GT.0) THEN
13823  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13824  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13825  wdte(i,0)=wdte(i,mdme(idc,1))
13826  wdte(0,0)=wdte(0,0)+wdte(i,0)
13827  ENDIF
13828  370 CONTINUE
13829 
13830  ELSEIF(kfla.EQ.kexcit+1) THEN
13831 C...d* excited quark.
13832  fac=(sh/paru(155)**2)*shr
13833  DO 380 i=1,mdcy(kc,3)
13834  idc=i+mdcy(kc,2)-1
13835  IF(mdme(idc,1).LT.0) goto 380
13836  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13837  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13838  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 380
13839  IF(i.EQ.1) THEN
13840 C...d* -> g + d.
13841  wdtp(i)=fac*as*paru(159)**2/3d0
13842  wid2=1d0
13843  ELSEIF(i.EQ.2) THEN
13844 C...d* -> gamma + d.
13845  qf=-paru(157)/2d0+paru(158)/6d0
13846  wdtp(i)=fac*aem*qf**2/4d0
13847  wid2=1d0
13848  ELSEIF(i.EQ.3) THEN
13849 C...d* -> Z0 + d.
13850  qf=-paru(157)*xw1/2d0-paru(158)*xw/6d0
13851  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
13852  & (1d0-rm1)**2*(2d0+rm1)
13853  wid2=wids(23,2)
13854  ELSEIF(i.EQ.4) THEN
13855 C...d* -> W- + u.
13856  wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
13857  & (1d0-rm1)**2*(2d0+rm1)
13858  IF(kflr.GT.0) wid2=wids(24,3)
13859  IF(kflr.LT.0) wid2=wids(24,2)
13860  ENDIF
13861  wdtp(0)=wdtp(0)+wdtp(i)
13862  IF(mdme(idc,1).GT.0) THEN
13863  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13864  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13865  wdte(i,0)=wdte(i,mdme(idc,1))
13866  wdte(0,0)=wdte(0,0)+wdte(i,0)
13867  ENDIF
13868  380 CONTINUE
13869 
13870  ELSEIF(kfla.EQ.kexcit+2) THEN
13871 C...u* excited quark.
13872  fac=(sh/paru(155)**2)*shr
13873  DO 390 i=1,mdcy(kc,3)
13874  idc=i+mdcy(kc,2)-1
13875  IF(mdme(idc,1).LT.0) goto 390
13876  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13877  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13878  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 390
13879  IF(i.EQ.1) THEN
13880 C...u* -> g + u.
13881  wdtp(i)=fac*as*paru(159)**2/3d0
13882  wid2=1d0
13883  ELSEIF(i.EQ.2) THEN
13884 C...u* -> gamma + u.
13885  qf=paru(157)/2d0+paru(158)/6d0
13886  wdtp(i)=fac*aem*qf**2/4d0
13887  wid2=1d0
13888  ELSEIF(i.EQ.3) THEN
13889 C...u* -> Z0 + u.
13890  qf=paru(157)*xw1/2d0-paru(158)*xw/6d0
13891  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
13892  & (1d0-rm1)**2*(2d0+rm1)
13893  wid2=wids(23,2)
13894  ELSEIF(i.EQ.4) THEN
13895 C...u* -> W+ + d.
13896  wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
13897  & (1d0-rm1)**2*(2d0+rm1)
13898  IF(kflr.GT.0) wid2=wids(24,2)
13899  IF(kflr.LT.0) wid2=wids(24,3)
13900  ENDIF
13901  wdtp(0)=wdtp(0)+wdtp(i)
13902  IF(mdme(idc,1).GT.0) THEN
13903  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13904  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13905  wdte(i,0)=wdte(i,mdme(idc,1))
13906  wdte(0,0)=wdte(0,0)+wdte(i,0)
13907  ENDIF
13908  390 CONTINUE
13909 
13910  ELSEIF(kfla.EQ.kexcit+11) THEN
13911 C...e* excited lepton.
13912  fac=(sh/paru(155)**2)*shr
13913  DO 400 i=1,mdcy(kc,3)
13914  idc=i+mdcy(kc,2)-1
13915  IF(mdme(idc,1).LT.0) goto 400
13916  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13917  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13918  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 400
13919  IF(i.EQ.1) THEN
13920 C...e* -> gamma + e.
13921  qf=-paru(157)/2d0-paru(158)/2d0
13922  wdtp(i)=fac*aem*qf**2/4d0
13923  wid2=1d0
13924  ELSEIF(i.EQ.2) THEN
13925 C...e* -> Z0 + e.
13926  qf=-paru(157)*xw1/2d0+paru(158)*xw/2d0
13927  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
13928  & (1d0-rm1)**2*(2d0+rm1)
13929  wid2=wids(23,2)
13930  ELSEIF(i.EQ.3) THEN
13931 C...e* -> W- + nu.
13932  wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
13933  & (1d0-rm1)**2*(2d0+rm1)
13934  IF(kflr.GT.0) wid2=wids(24,3)
13935  IF(kflr.LT.0) wid2=wids(24,2)
13936  ENDIF
13937  wdtp(0)=wdtp(0)+wdtp(i)
13938  IF(mdme(idc,1).GT.0) THEN
13939  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13940  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13941  wdte(i,0)=wdte(i,mdme(idc,1))
13942  wdte(0,0)=wdte(0,0)+wdte(i,0)
13943  ENDIF
13944  400 CONTINUE
13945 
13946  ELSEIF(kfla.EQ.kexcit+12) THEN
13947 C...nu*_e excited neutrino.
13948  fac=(sh/paru(155)**2)*shr
13949  DO 410 i=1,mdcy(kc,3)
13950  idc=i+mdcy(kc,2)-1
13951  IF(mdme(idc,1).LT.0) goto 410
13952  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
13953  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
13954  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 410
13955  IF(i.EQ.1) THEN
13956 C...nu*_e -> Z0 + nu*_e.
13957  qf=paru(157)*xw1/2d0+paru(158)*xw/2d0
13958  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
13959  & (1d0-rm1)**2*(2d0+rm1)
13960  wid2=wids(23,2)
13961  ELSEIF(i.EQ.2) THEN
13962 C...nu*_e -> W+ + e.
13963  wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*
13964  & (1d0-rm1)**2*(2d0+rm1)
13965  IF(kflr.GT.0) wid2=wids(24,2)
13966  IF(kflr.LT.0) wid2=wids(24,3)
13967  ENDIF
13968  wdtp(0)=wdtp(0)+wdtp(i)
13969  IF(mdme(idc,1).GT.0) THEN
13970  wdte(i,mdme(idc,1))=wdtp(i)*wid2
13971  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
13972  wdte(i,0)=wdte(i,mdme(idc,1))
13973  wdte(0,0)=wdte(0,0)+wdte(i,0)
13974  ENDIF
13975  410 CONTINUE
13976 
13977  ENDIF
13978  mint(61)=0
13979  mint(62)=0
13980  mint(63)=0
13981 
13982  RETURN
13983  END
13984 
13985 C***********************************************************************
13986 
13987 C...PYOFSH
13988 C...Calculates partial width and differential cross-section maxima
13989 C...of channels/processes not allowed on mass-shell, and selects
13990 C...masses in such channels/processes.
13991 
13992  SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
13993 
13994 C...Double precision and integer declarations.
13995  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13996  INTEGER pyk,pychge,pycomp
13997 C...Commonblocks.
13998  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13999  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14000  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
14001  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
14002  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14003  common/pyint1/mint(400),vint(400)
14004  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
14005  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
14006  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
14007  &/pyint2/,/pyint5/
14008 C...Local arrays.
14009  dimension kfd(2),mbw(2),pmd(2),pgd(2),pmg(2),pml(2),pmu(2),
14010  &pmh(2),atl(2),atu(2),ath(2),rmg(2),inx1(100),xpt1(100),
14011  &fpt1(100),inx2(100),xpt2(100),fpt2(100),wdtp(0:200),
14012  &wdte(0:200,0:5)
14013 
14014 C...Find if particles equal, maximum mass, matrix elements, etc.
14015  mint(51)=0
14016  isub=mint(1)
14017  kfd(1)=iabs(kfd1)
14018  kfd(2)=iabs(kfd2)
14019  meql=0
14020  IF(kfd(1).EQ.kfd(2)) meql=1
14021  mlm=0
14022  IF(mofsh.GE.2.AND.meql.EQ.1) mlm=int(1.5d0+pyr(0))
14023  IF(mofsh.LE.2.OR.mofsh.EQ.5) THEN
14024  noff=44
14025  pmmx=pmmo
14026  ELSE
14027  noff=40
14028  pmmx=vint(1)
14029  IF(ckin(2).GT.ckin(1)) pmmx=min(ckin(2),vint(1))
14030  ENDIF
14031  mmed=0
14032  IF((kfmo.EQ.25.OR.kfmo.EQ.35.OR.kfmo.EQ.36).AND.meql.EQ.1.AND.
14033  &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=1
14034  IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(1).EQ.23.OR.
14035  &kfd(1).EQ.24).AND.(kfd(2).EQ.23.OR.kfd(2).EQ.24)) mmed=2
14036  IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(2).EQ.25.OR.
14037  &kfd(2).EQ.35.OR.kfd(2).EQ.36)) mmed=3
14038  loop=1
14039 
14040 C...Find where Breit-Wigners are required, else select discrete masses.
14041  100 DO 110 i=1,2
14042  kfca=pycomp(kfd(i))
14043  IF(kfca.GT.0) THEN
14044  pmd(i)=pmas(kfca,1)
14045  pgd(i)=pmas(kfca,2)
14046  ELSE
14047  pmd(i)=0d0
14048  pgd(i)=0d0
14049  ENDIF
14050  IF(mstp(42).LE.0.OR.pgd(i).LT.parp(41)) THEN
14051  mbw(i)=0
14052  pmg(i)=pmd(i)
14053  rmg(i)=(pmg(i)/pmmx)**2
14054  ELSE
14055  mbw(i)=1
14056  ENDIF
14057  110 CONTINUE
14058 
14059 C...Find allowed mass range and Breit-Wigner parameters.
14060  DO 120 i=1,2
14061  IF(mofsh.EQ.1.AND.loop.EQ.1.AND.mbw(i).EQ.1) THEN
14062  pml(i)=parp(42)
14063  pmu(i)=pmmx-parp(42)
14064  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
14065  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
14066  ELSEIF(mbw(i).EQ.1.AND.mofsh.NE.5) THEN
14067  ilm=i
14068  IF(mlm.EQ.2) ilm=3-i
14069  pml(i)=max(ckin(noff+2*ilm-1),parp(42))
14070  pmu(i)=pmmx-max(ckin(noff+5-2*ilm),parp(42))
14071  IF(ckin(noff+2*ilm).GT.ckin(noff+2*ilm-1)) pmu(i)=min(pmu(i),
14072  & ckin(noff+2*ilm))
14073  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
14074  IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
14075  IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
14076  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
14077  IF(mbw(i).EQ.1) THEN
14078  atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
14079  atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
14080  IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
14081  & pgd(i)))
14082  ENDIF
14083  ELSEIF(mbw(i).EQ.1.AND.mofsh.EQ.5) THEN
14084  ilm=i
14085  IF(mlm.EQ.2) ilm=3-i
14086  pml(i)=max(ckin(48+i),parp(42))
14087  pmu(i)=pmmx-max(ckin(51-i),parp(42))
14088  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
14089  IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
14090  IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
14091  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
14092  IF(mbw(i).EQ.1) THEN
14093  atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
14094  atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
14095  IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
14096  & pgd(i)))
14097  ENDIF
14098  ENDIF
14099  120 CONTINUE
14100  IF(mbw(1).LT.0.OR.mbw(2).LT.0.OR.(mbw(1).EQ.0.AND.mbw(2).EQ.0))
14101  &THEN
14102  CALL pyerrm(3,'(PYOFSH:) no allowed decay product masses')
14103  mint(51)=1
14104  RETURN
14105  ENDIF
14106 
14107 C...Calculation of partial width of resonance.
14108  IF(mofsh.EQ.1) THEN
14109 
14110 C..If only one integration, pick that to be the inner.
14111  IF(mbw(1).EQ.0) THEN
14112  pm2=pmd(1)
14113  pmd(1)=pmd(2)
14114  pgd(1)=pgd(2)
14115  pml(1)=pml(2)
14116  pmu(1)=pmu(2)
14117  ELSEIF(mbw(2).EQ.0) THEN
14118  pm2=pmd(2)
14119  ENDIF
14120 
14121 C...Start outer loop of integration.
14122  IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
14123  atl2=atan((pml(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
14124  atu2=atan((pmu(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
14125  npt2=1
14126  xpt2(1)=1d0
14127  inx2(1)=0
14128  fmax2=0d0
14129  ENDIF
14130  130 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
14131  pm2s=pmd(2)**2+pmd(2)*pgd(2)*tan(atl2+xpt2(npt2)*(atu2-atl2))
14132  pm2=min(pmu(2),max(pml(2),sqrt(max(0d0,pm2s))))
14133  ENDIF
14134  rm2=(pm2/pmmx)**2
14135 
14136 C...Start inner loop of integration.
14137  pml1=pml(1)
14138  pmu1=min(pmu(1),pmmx-pm2)
14139  IF(meql.EQ.1) pmu1=min(pmu1,pm2)
14140  atl1=atan((pml1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
14141  atu1=atan((pmu1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
14142  IF(pml1+parj(64).GE.pmu1.OR.atl1+1d-7.GE.atu1) THEN
14143  func2=0d0
14144  goto 180
14145  ENDIF
14146  npt1=1
14147  xpt1(1)=1d0
14148  inx1(1)=0
14149  fmax1=0d0
14150  140 pm1s=pmd(1)**2+pmd(1)*pgd(1)*tan(atl1+xpt1(npt1)*(atu1-atl1))
14151  pm1=min(pmu1,max(pml1,sqrt(max(0d0,pm1s))))
14152  rm1=(pm1/pmmx)**2
14153 
14154 C...Evaluate function value - inner loop.
14155  func1=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
14156  IF(mmed.EQ.1) func1=func1*((1d0-rm1-rm2)**2+8d0*rm1*rm2)
14157  IF(mmed.EQ.2) func1=func1**3*(1d0+10d0*rm1+10d0*rm2+rm1**2+
14158  & rm2**2+10d0*rm1*rm2)
14159  IF(func1.GT.fmax1) fmax1=func1
14160  fpt1(npt1)=func1
14161 
14162 C...Go to next position in inner loop.
14163  IF(npt1.EQ.1) THEN
14164  npt1=npt1+1
14165  xpt1(npt1)=0d0
14166  inx1(npt1)=1
14167  goto 140
14168  ELSEIF(npt1.LE.8) THEN
14169  npt1=npt1+1
14170  IF(npt1.LE.4.OR.npt1.EQ.6) ish1=1
14171  ish1=ish1+1
14172  xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
14173  inx1(npt1)=inx1(ish1)
14174  inx1(ish1)=npt1
14175  goto 140
14176  ELSEIF(npt1.LT.100) THEN
14177  isn1=ish1
14178  150 ish1=ish1+1
14179  IF(ish1.GT.npt1) ish1=2
14180  IF(ish1.EQ.isn1) goto 160
14181  dfpt1=abs(fpt1(ish1)-fpt1(inx1(ish1)))
14182  IF(dfpt1.LT.parp(43)*fmax1) goto 150
14183  npt1=npt1+1
14184  xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
14185  inx1(npt1)=inx1(ish1)
14186  inx1(ish1)=npt1
14187  goto 140
14188  ENDIF
14189 
14190 C...Calculate integral over inner loop.
14191  160 fsum1=0d0
14192  DO 170 ipt1=2,npt1
14193  fsum1=fsum1+0.5d0*(fpt1(ipt1)+fpt1(inx1(ipt1)))*
14194  & (xpt1(inx1(ipt1))-xpt1(ipt1))
14195  170 CONTINUE
14196  func2=fsum1*(atu1-atl1)/paru(1)
14197  180 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
14198  IF(func2.GT.fmax2) fmax2=func2
14199  fpt2(npt2)=func2
14200 
14201 C...Go to next position in outer loop.
14202  IF(npt2.EQ.1) THEN
14203  npt2=npt2+1
14204  xpt2(npt2)=0d0
14205  inx2(npt2)=1
14206  goto 130
14207  ELSEIF(npt2.LE.8) THEN
14208  npt2=npt2+1
14209  IF(npt2.LE.4.OR.npt2.EQ.6) ish2=1
14210  ish2=ish2+1
14211  xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
14212  inx2(npt2)=inx2(ish2)
14213  inx2(ish2)=npt2
14214  goto 130
14215  ELSEIF(npt2.LT.100) THEN
14216  isn2=ish2
14217  190 ish2=ish2+1
14218  IF(ish2.GT.npt2) ish2=2
14219  IF(ish2.EQ.isn2) goto 200
14220  dfpt2=abs(fpt2(ish2)-fpt2(inx2(ish2)))
14221  IF(dfpt2.LT.parp(43)*fmax2) goto 190
14222  npt2=npt2+1
14223  xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
14224  inx2(npt2)=inx2(ish2)
14225  inx2(ish2)=npt2
14226  goto 130
14227  ENDIF
14228 
14229 C...Calculate integral over outer loop.
14230  200 fsum2=0d0
14231  DO 210 ipt2=2,npt2
14232  fsum2=fsum2+0.5d0*(fpt2(ipt2)+fpt2(inx2(ipt2)))*
14233  & (xpt2(inx2(ipt2))-xpt2(ipt2))
14234  210 CONTINUE
14235  fsum2=fsum2*(atu2-atl2)/paru(1)
14236  IF(meql.EQ.1) fsum2=2d0*fsum2
14237  ELSE
14238  fsum2=func2
14239  ENDIF
14240 
14241 C...Save result; second integration for user-selected mass range.
14242  IF(loop.EQ.1) widw=fsum2
14243  wid2=fsum2
14244  IF(loop.EQ.1.AND.(ckin(46).GE.ckin(45).OR.ckin(48).GE.ckin(47)
14245  & .OR.max(ckin(45),ckin(47)).GE.1.01d0*parp(42))) THEN
14246  loop=2
14247  goto 100
14248  ENDIF
14249  ret1=widw
14250  ret2=wid2/widw
14251 
14252 C...Select two decay product masses of a resonance.
14253  ELSEIF(mofsh.EQ.2.OR.mofsh.EQ.5) THEN
14254  220 DO 230 i=1,2
14255  IF(mbw(i).EQ.0) goto 230
14256  pmbw=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*
14257  & (atu(i)-atl(i)))
14258  pmg(i)=min(pmu(i),max(pml(i),sqrt(max(0d0,pmbw))))
14259  rmg(i)=(pmg(i)/pmmx)**2
14260  230 CONTINUE
14261  IF((meql.EQ.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
14262  & pmg(1)+pmg(2)+parj(64).GT.pmmx) goto 220
14263 
14264 C...Weight with matrix element (if none known, use beta factor).
14265  flam=sqrt(max(0d0,(1d0-rmg(1)-rmg(2))**2-4d0*rmg(1)*rmg(2)))
14266  IF(mmed.EQ.1) THEN
14267  wtbe=flam*((1d0-rmg(1)-rmg(2))**2+8d0*rmg(1)*rmg(2))
14268  ELSEIF(mmed.EQ.2) THEN
14269  wtbe=flam**3*(1d0+10d0*rmg(1)+10d0*rmg(2)+rmg(1)**2+
14270  & rmg(2)**2+10d0*rmg(1)*rmg(2))
14271  ELSEIF(mmed.EQ.3) THEN
14272  wtbe=flam*(rmg(1)+flam**2/12d0)
14273  ELSE
14274  wtbe=flam
14275  ENDIF
14276  IF(wtbe.LT.pyr(0)) goto 220
14277  ret1=pmg(1)
14278  ret2=pmg(2)
14279 
14280 C...Find suitable set of masses for initialization of 2 -> 2 processes.
14281  ELSEIF(mofsh.EQ.3) THEN
14282  IF(mbw(1).NE.0.AND.mbw(2).EQ.0) THEN
14283  pmg(1)=min(pmd(1),0.5d0*(pml(1)+pmu(1)))
14284  pmg(2)=pmd(2)
14285  ELSEIF(mbw(2).NE.0.AND.mbw(1).EQ.0) THEN
14286  pmg(1)=pmd(1)
14287  pmg(2)=min(pmd(2),0.5d0*(pml(2)+pmu(2)))
14288  ELSE
14289  idiv=-1
14290  240 idiv=idiv+1
14291  pmg(1)=min(pmd(1),0.1d0*(idiv*pml(1)+(10-idiv)*pmu(1)))
14292  pmg(2)=min(pmd(2),0.1d0*(idiv*pml(2)+(10-idiv)*pmu(2)))
14293  IF(idiv.LE.9.AND.pmg(1)+pmg(2).GT.0.9d0*pmmx) goto 240
14294  ENDIF
14295  ret1=pmg(1)
14296  ret2=pmg(2)
14297 
14298 C...Evaluate importance of excluded tails of Breit-Wigners.
14299  IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
14300  & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
14301  IF(meql.LE.1) THEN
14302  vint(80)=1d0
14303  DO 250 i=1,2
14304  IF(mbw(i).NE.0) vint(80)=vint(80)*1.25d0*(atu(i)-atl(i))/
14305  & paru(1)
14306  250 CONTINUE
14307  ELSE
14308  vint(80)=(1.25d0/paru(1))**2*max((atu(1)-atl(1))*
14309  & (ath(2)-atl(2)),(ath(1)-atl(1))*(atu(2)-atl(2)))
14310  ENDIF
14311  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.30.OR.isub.EQ.35).AND.
14312  & mstp(43).NE.2) vint(80)=2d0*vint(80)
14313  IF(isub.EQ.22.AND.mstp(43).NE.2) vint(80)=4d0*vint(80)
14314  IF(meql.GE.1) vint(80)=2d0*vint(80)
14315 
14316 C...Pick one particle to be the lighter (if improves efficiency).
14317  ELSEIF(mofsh.EQ.4) THEN
14318  IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
14319  & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
14320  260 IF(meql.EQ.2) mlm=int(1.5d0+pyr(0))
14321 
14322 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
14323  DO 270 i=1,2
14324  IF(mbw(i).EQ.0) goto 270
14325  pmv=pmu(i)
14326  IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
14327  atv=atu(i)
14328  IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
14329  rbr=pyr(0)
14330  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
14331  & isub.EQ.35).AND.mstp(43).NE.2) rbr=2d0*rbr
14332  IF(rbr.LT.0.8d0) THEN
14333  pmsr=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*(atv-atl(i)))
14334  pmg(i)=min(pmv,max(pml(i),sqrt(max(0d0,pmsr))))
14335  ELSEIF(rbr.LT.0.9d0) THEN
14336  pmg(i)=sqrt(max(0d0,pml(i)**2+pyr(0)*(pmv**2-pml(i)**2)))
14337  ELSEIF(rbr.LT.1.5d0) THEN
14338  pmg(i)=pml(i)*(pmv/pml(i))**pyr(0)
14339  ELSE
14340  pmg(i)=sqrt(max(0d0,pml(i)**2*pmv**2/(pml(i)**2+pyr(0)*
14341  & (pmv**2-pml(i)**2))))
14342  ENDIF
14343  270 CONTINUE
14344  IF((meql.GE.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
14345  & pmg(1)+pmg(2)+parj(64).GT.pmmx) THEN
14346  IF(mint(48).EQ.1) THEN
14347  ngen(0,1)=ngen(0,1)+1
14348  ngen(mint(1),1)=ngen(mint(1),1)+1
14349  goto 260
14350  ELSE
14351  mint(51)=1
14352  RETURN
14353  ENDIF
14354  ENDIF
14355  ret1=pmg(1)
14356  ret2=pmg(2)
14357 
14358 C...Give weight for selected mass distribution.
14359  vint(80)=1d0
14360  DO 280 i=1,2
14361  IF(mbw(i).EQ.0) goto 280
14362  pmv=pmu(i)
14363  IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
14364  atv=atu(i)
14365  IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
14366  f0=pmd(i)*pgd(i)/((pmg(i)**2-pmd(i)**2)**2+
14367  & (pmd(i)*pgd(i))**2)/paru(1)
14368  f1=1d0
14369  f2=1d0/pmg(i)**2
14370  f3=1d0/pmg(i)**4
14371  fi0=(atv-atl(i))/paru(1)
14372  fi1=pmv**2-pml(i)**2
14373  fi2=2d0*log(pmv/pml(i))
14374  fi3=1d0/pml(i)**2-1d0/pmv**2
14375  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
14376  & isub.EQ.35).AND.mstp(43).NE.2) THEN
14377  vint(80)=vint(80)*20d0/(8d0+(fi0/f0)*(f1/fi1+6d0*f2/fi2+
14378  & 5d0*f3/fi3))
14379  ELSE
14380  vint(80)=vint(80)*10d0/(8d0+(fi0/f0)*(f1/fi1+f2/fi2))
14381  ENDIF
14382  vint(80)=vint(80)*fi0
14383  280 CONTINUE
14384  IF(meql.GE.1) vint(80)=2d0*vint(80)
14385  ENDIF
14386 
14387  RETURN
14388  END
14389 
14390 C***********************************************************************
14391 
14392 C...PYRECO
14393 C...Handles the possibility of colour reconnection in W+W- events,
14394 C...Based on the main scenarios of the Sjostrand and Khoze study:
14395 C...I, II, II', intermediate and instantaneous; plus one model
14396 C...along the lines of the Gustafson and Hakkinen: GH.
14397 
14398  SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)
14399 
14400 C...Double precision and integer declarations.
14401  IMPLICIT DOUBLE PRECISION(a-h, o-z)
14402  INTEGER pyk,pychge,pycomp
14403 C...Parameter value; number of points in MC integration.
14404  parameter(npt=100)
14405 C...Commonblocks.
14406  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
14407  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14408  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14409  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14410  common/pyint1/mint(400),vint(400)
14411  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
14412 C...Local arrays.
14413  dimension nbeg(2),nend(2),inp(50),inm(50),beww(3),xp(3),xm(3),
14414  &v1(3),v2(3),betp(50,4),dirp(50,3),betm(50,4),dirm(50,3),
14415  &xd(4),xb(4),iap(npt),iam(npt),wta(npt),v1p(3),v2p(3),v1m(3),
14416  &v2m(3),q(4,3),xpp(3),xmm(3),ipc(20),imc(20),tc(0:20),tpc(20),
14417  &tmc(20),ijoin(100)
14418 
14419 C...Functions to give four-product and to do determinants.
14420  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)
14421  deter(i,j,l)=q(i,1)*q(j,2)*q(l,3)-q(i,1)*q(l,2)*q(j,3)+
14422  &q(j,1)*q(l,2)*q(i,3)-q(j,1)*q(i,2)*q(l,3)+
14423  &q(l,1)*q(i,2)*q(j,3)-q(l,1)*q(j,2)*q(i,3)
14424 
14425 C...Only allow fraction of recoupling for GH, intermediate and
14426 C...instantaneous.
14427  IF(mstp(115).EQ.5.OR.mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
14428  IF(pyr(0).GT.parp(120)) RETURN
14429  ENDIF
14430 
14431 C...Common part for scenarios I, II, II', and GH.
14432  IF(mstp(115).EQ.1.OR.mstp(115).EQ.2.OR.mstp(115).EQ.3.OR.
14433  &mstp(115).EQ.5) THEN
14434 
14435 C...Read out frequently-used parameters.
14436  pi=paru(1)
14437  hbar=paru(3)
14438  pmw=pmas(24,1)
14439  pgw=pmas(24,2)
14440  tfrag=parp(115)
14441  rhad=parp(116)
14442  fact=parp(117)
14443  blowr=parp(118)
14444  blowt=parp(119)
14445 
14446 C...Find range of decay products of the W's.
14447 C...Background: the W's are stored in IW1 and IW2.
14448 C...Their direct decay products in NSD1+1 through NSD1+4.
14449 C...Products after shower (if any) in NSD1+5 through NAFT1
14450 C...for first W and in NAFT1+1 through N for the second.
14451  IF(k(iw1,2).GT.0) THEN
14452  jt=1
14453  ELSE
14454  jt=2
14455  ENDIF
14456  jr=3-jt
14457  IF(naft1.GT.nsd1+4) THEN
14458  nbeg(jt)=nsd1+5
14459  nend(jt)=naft1
14460  ELSE
14461  nbeg(jt)=nsd1+1
14462  nend(jt)=nsd1+2
14463  ENDIF
14464  IF(n.GT.naft1) THEN
14465  nbeg(jr)=naft1+1
14466  nend(jr)=n
14467  ELSE
14468  nbeg(jr)=nsd1+3
14469  nend(jr)=nsd1+4
14470  ENDIF
14471 
14472 C...Rearrange parton shower products along strings.
14473  nold=n
14474  CALL pyprep(nsd1+1)
14475 
14476 C...Find partons pointing back to W+ and W-; store them with quark
14477 C...end of string first.
14478  nnp=0
14479  nnm=0
14480  isgp=0
14481  isgm=0
14482  DO 120 i=nold+1,n
14483  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 120
14484  IF(iabs(k(i,2)).GE.22) goto 120
14485  IF(k(i,3).GE.nbeg(1).AND.k(i,3).LE.nend(1)) THEN
14486  IF(isgp.EQ.0) isgp=isign(1,k(i,2))
14487  nnp=nnp+1
14488  IF(isgp.EQ.1) THEN
14489  inp(nnp)=i
14490  ELSE
14491  DO 100 i1=nnp,2,-1
14492  inp(i1)=inp(i1-1)
14493  100 CONTINUE
14494  inp(1)=i
14495  ENDIF
14496  IF(k(i,1).EQ.1) isgp=0
14497  ELSEIF(k(i,3).GE.nbeg(2).AND.k(i,3).LE.nend(2)) THEN
14498  IF(isgm.EQ.0) isgm=isign(1,k(i,2))
14499  nnm=nnm+1
14500  IF(isgm.EQ.1) THEN
14501  inm(nnm)=i
14502  ELSE
14503  DO 110 i1=nnm,2,-1
14504  inm(i1)=inm(i1-1)
14505  110 CONTINUE
14506  inm(1)=i
14507  ENDIF
14508  IF(k(i,1).EQ.1) isgm=0
14509  ENDIF
14510  120 CONTINUE
14511 
14512 C...Boost to W+W- rest frame (not strictly needed).
14513  DO 130 j=1,3
14514  beww(j)=(p(iw1,j)+p(iw2,j))/(p(iw1,4)+p(iw2,4))
14515  130 CONTINUE
14516  CALL pyrobo(iw1,iw1,0d0,0d0,-beww(1),-beww(2),-beww(3))
14517  CALL pyrobo(iw2,iw2,0d0,0d0,-beww(1),-beww(2),-beww(3))
14518  CALL pyrobo(nold+1,n,0d0,0d0,-beww(1),-beww(2),-beww(3))
14519 
14520 C...Select decay vertices of W+ and W-.
14521  tp=hbar*(-log(pyr(0)))*p(iw1,4)/
14522  & sqrt((p(iw1,5)**2-pmw**2)**2+(p(iw1,5)**2*pgw/pmw)**2)
14523  tm=hbar*(-log(pyr(0)))*p(iw2,4)/
14524  & sqrt((p(iw2,5)**2-pmw**2)**2+(p(iw2,5)**2*pgw/pmw)**2)
14525  gtmax=max(tp,tm)
14526  DO 140 j=1,3
14527  xp(j)=tp*p(iw1,j)/p(iw1,4)
14528  xm(j)=tm*p(iw2,j)/p(iw2,4)
14529  140 CONTINUE
14530 
14531 C...Begin scenario I specifics.
14532  IF(mstp(115).EQ.1) THEN
14533 
14534 C...Reconstruct velocity and direction of W+ string pieces.
14535  DO 170 iip=1,nnp-1
14536  IF(k(inp(iip),2).LT.0) goto 170
14537  i1=inp(iip)
14538  i2=inp(iip+1)
14539  p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
14540  p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
14541  DO 150 j=1,3
14542  v1(j)=p(i1,j)/p1a
14543  v2(j)=p(i2,j)/p2a
14544  betp(iip,j)=0.5d0*(v1(j)+v2(j))
14545  dirp(iip,j)=v1(j)-v2(j)
14546  150 CONTINUE
14547  betp(iip,4)=1d0/sqrt(1d0-betp(iip,1)**2-betp(iip,2)**2-
14548  & betp(iip,3)**2)
14549  dirl=sqrt(dirp(iip,1)**2+dirp(iip,2)**2+dirp(iip,3)**2)
14550  DO 160 j=1,3
14551  dirp(iip,j)=dirp(iip,j)/dirl
14552  160 CONTINUE
14553  170 CONTINUE
14554 
14555 C...Reconstruct velocity and direction of W- string pieces.
14556  DO 200 iim=1,nnm-1
14557  IF(k(inm(iim),2).LT.0) goto 200
14558  i1=inm(iim)
14559  i2=inm(iim+1)
14560  p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
14561  p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
14562  DO 180 j=1,3
14563  v1(j)=p(i1,j)/p1a
14564  v2(j)=p(i2,j)/p2a
14565  betm(iim,j)=0.5d0*(v1(j)+v2(j))
14566  dirm(iim,j)=v1(j)-v2(j)
14567  180 CONTINUE
14568  betm(iim,4)=1d0/sqrt(1d0-betm(iim,1)**2-betm(iim,2)**2-
14569  & betm(iim,3)**2)
14570  dirl=sqrt(dirm(iim,1)**2+dirm(iim,2)**2+dirm(iim,3)**2)
14571  DO 190 j=1,3
14572  dirm(iim,j)=dirm(iim,j)/dirl
14573  190 CONTINUE
14574  200 CONTINUE
14575 
14576 C...Loop over number of space-time points.
14577  nacc=0
14578  sum=0d0
14579  DO 250 ipt=1,npt
14580 
14581 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
14582  r=sqrt(-log(pyr(0)))
14583  phi=2d0*pi*pyr(0)
14584  x=blowr*rhad*r*cos(phi)
14585  y=blowr*rhad*r*sin(phi)
14586  r=sqrt(-log(pyr(0)))
14587  phi=2d0*pi*pyr(0)
14588  z=blowr*rhad*r*cos(phi)
14589  t=gtmax+blowt*sqrt(0.5d0)*tfrag*r*abs(sin(phi))
14590 
14591 C...Weight for sample distribution.
14592  wtsmp=exp(-(x**2+y**2+z**2)/(blowr*rhad)**2)*
14593  & exp(-2d0*(t-gtmax)**2/(blowt*tfrag)**2)
14594 
14595 C...Loop over W+ string pieces and find one with largest weight.
14596  imaxp=0
14597  wtmaxp=1d-10
14598  xd(1)=x-xp(1)
14599  xd(2)=y-xp(2)
14600  xd(3)=z-xp(3)
14601  xd(4)=t-tp
14602  DO 220 iip=1,nnp-1
14603  IF(k(inp(iip),2).LT.0) goto 220
14604  bed=betp(iip,1)*xd(1)+betp(iip,2)*xd(2)+betp(iip,3)*xd(3)
14605  bedg=betp(iip,4)*(betp(iip,4)*bed/(1d0+betp(iip,4))-xd(4))
14606  DO 210 j=1,3
14607  xb(j)=xd(j)+bedg*betp(iip,j)
14608  210 CONTINUE
14609  xb(4)=betp(iip,4)*(xd(4)-bed)
14610  sr2=xb(1)**2+xb(2)**2+xb(3)**2
14611  sz2=(dirp(iip,1)*xb(1)+dirp(iip,2)*xb(2)+
14612  & dirp(iip,3)*xb(3))**2
14613  wtp=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
14614  & tfrag**2)
14615  IF(xb(4)-sqrt(sr2).LT.0d0) wtp=0d0
14616  IF(wtp.GT.wtmaxp) THEN
14617  imaxp=iip
14618  wtmaxp=wtp
14619  ENDIF
14620  220 CONTINUE
14621 
14622 C...Loop over W- string pieces and find one with largest weight.
14623  imaxm=0
14624  wtmaxm=1d-10
14625  xd(1)=x-xm(1)
14626  xd(2)=y-xm(2)
14627  xd(3)=z-xm(3)
14628  xd(4)=t-tm
14629  DO 240 iim=1,nnm-1
14630  IF(k(inm(iim),2).LT.0) goto 240
14631  bed=betm(iim,1)*xd(1)+betm(iim,2)*xd(2)+betm(iim,3)*xd(3)
14632  bedg=betm(iim,4)*(betm(iim,4)*bed/(1d0+betm(iim,4))-xd(4))
14633  DO 230 j=1,3
14634  xb(j)=xd(j)+bedg*betm(iim,j)
14635  230 CONTINUE
14636  xb(4)=betm(iim,4)*(xd(4)-bed)
14637  sr2=xb(1)**2+xb(2)**2+xb(3)**2
14638  sz2=(dirm(iim,1)*xb(1)+dirm(iim,2)*xb(2)+
14639  & dirm(iim,3)*xb(3))**2
14640  wtm=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
14641  & tfrag**2)
14642  IF(xb(4)-sqrt(sr2).LT.0d0) wtm=0d0
14643  IF(wtm.GT.wtmaxm) THEN
14644  imaxm=iim
14645  wtmaxm=wtm
14646  ENDIF
14647  240 CONTINUE
14648 
14649 C...Result of integration.
14650  wt=0d0
14651  IF(imaxp.NE.0.AND.imaxm.NE.0) THEN
14652  wt=wtmaxp*wtmaxm/wtsmp
14653  sum=sum+wt
14654  nacc=nacc+1
14655  iap(nacc)=imaxp
14656  iam(nacc)=imaxm
14657  wta(nacc)=wt
14658  ENDIF
14659  250 CONTINUE
14660  res=blowr**3*blowt*sum/npt
14661 
14662 C...Decide whether to reconnect and, if so, where.
14663  iacc=0
14664  prec=1d0-exp(-fact*res)
14665  IF(prec.GT.pyr(0)) THEN
14666  rsum=pyr(0)*sum
14667  DO 260 ia=1,nacc
14668  iacc=ia
14669  rsum=rsum-wta(ia)
14670  IF(rsum.LE.0d0) goto 270
14671  260 CONTINUE
14672  270 iip=iap(iacc)
14673  iim=iam(iacc)
14674  ENDIF
14675 
14676 C...Begin scenario II and II' specifics.
14677  ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN
14678 
14679 C...Loop through all string pieces, one from W+ and one from W-.
14680  ncross=0
14681  tc(0)=0d0
14682  DO 340 iip=1,nnp-1
14683  IF(k(inp(iip),2).LT.0) goto 340
14684  i1p=inp(iip)
14685  i2p=inp(iip+1)
14686  DO 330 iim=1,nnm-1
14687  IF(k(inm(iim),2).LT.0) goto 330
14688  i1m=inm(iim)
14689  i2m=inm(iim+1)
14690 
14691 C...Find endpoint velocity vectors.
14692  DO 280 j=1,3
14693  v1p(j)=p(i1p,j)/p(i1p,4)
14694  v2p(j)=p(i2p,j)/p(i2p,4)
14695  v1m(j)=p(i1m,j)/p(i1m,4)
14696  v2m(j)=p(i2m,j)/p(i2m,4)
14697  280 CONTINUE
14698 
14699 C...Define q matrix and find t.
14700  DO 290 j=1,3
14701  q(1,j)=v2p(j)-v1p(j)
14702  q(2,j)=-(v2m(j)-v1m(j))
14703  q(3,j)=xp(j)-xm(j)-tp*v1p(j)+tm*v1m(j)
14704  q(4,j)=v1p(j)-v1m(j)
14705  290 CONTINUE
14706  t=-deter(1,2,3)/deter(1,2,4)
14707 
14708 C...Find alpha and beta; i.e. coordinates of crossing point.
14709  s11=q(1,1)*(t-tp)
14710  s12=q(2,1)*(t-tm)
14711  s13=q(3,1)+q(4,1)*t
14712  s21=q(1,2)*(t-tp)
14713  s22=q(2,2)*(t-tm)
14714  s23=q(3,2)+q(4,2)*t
14715  den=s11*s22-s12*s21
14716  alp=(s12*s23-s22*s13)/den
14717  bet=(s21*s13-s11*s23)/den
14718 
14719 C...Check if solution acceptable.
14720  iansw=1
14721  IF(t.LT.gtmax) iansw=0
14722  IF(alp.LT.0d0.OR.alp.GT.1d0) iansw=0
14723  IF(bet.LT.0d0.OR.bet.GT.1d0) iansw=0
14724 
14725 C...Find point of crossing and check that not inconsistent.
14726  DO 300 j=1,3
14727  xpp(j)=xp(j)+(v1p(j)+alp*(v2p(j)-v1p(j)))*(t-tp)
14728  xmm(j)=xm(j)+(v1m(j)+bet*(v2m(j)-v1m(j)))*(t-tm)
14729  300 CONTINUE
14730  d2pm=(xpp(1)-xmm(1))**2+(xpp(2)-xmm(2))**2+
14731  & (xpp(3)-xmm(3))**2
14732  d2p=xpp(1)**2+xpp(2)**2+xpp(3)**2
14733  d2m=xmm(1)**2+xmm(2)**2+xmm(3)**2
14734  IF(d2pm.GT.1d-4*(d2p+d2m)) iansw=-1
14735 
14736 C...Find string eigentimes at crossing.
14737  IF(iansw.EQ.1) THEN
14738  taup=sqrt(max(0d0,(t-tp)**2-(xpp(1)-xp(1))**2-
14739  & (xpp(2)-xp(2))**2-(xpp(3)-xp(3))**2))
14740  taum=sqrt(max(0d0,(t-tm)**2-(xmm(1)-xm(1))**2-
14741  & (xmm(2)-xm(2))**2-(xmm(3)-xm(3))**2))
14742  ELSE
14743  taup=0d0
14744  taum=0d0
14745  ENDIF
14746 
14747 C...Order crossings by time. End loop over crossings.
14748  IF(iansw.EQ.1.AND.ncross.LT.20) THEN
14749  ncross=ncross+1
14750  DO 310 i1=ncross,1,-1
14751  IF(t.GT.tc(i1-1).OR.i1.EQ.1) THEN
14752  ipc(i1)=iip
14753  imc(i1)=iim
14754  tc(i1)=t
14755  tpc(i1)=taup
14756  tmc(i1)=taum
14757  goto 320
14758  ELSE
14759  ipc(i1)=ipc(i1-1)
14760  imc(i1)=imc(i1-1)
14761  tc(i1)=tc(i1-1)
14762  tpc(i1)=tpc(i1-1)
14763  tmc(i1)=tmc(i1-1)
14764  ENDIF
14765  310 CONTINUE
14766  320 CONTINUE
14767  ENDIF
14768  330 CONTINUE
14769  340 CONTINUE
14770 
14771 C...Loop over crossings; find first (if any) acceptable one.
14772  iacc=0
14773  IF(ncross.GE.1) THEN
14774  DO 350 ic=1,ncross
14775  pnfrag=exp(-(tpc(ic)**2+tmc(ic)**2)/tfrag**2)
14776  IF(pnfrag.GT.pyr(0)) THEN
14777 C...Scenario II: only compare with fragmentation time.
14778  IF(mstp(115).EQ.2) THEN
14779  iacc=ic
14780  iip=ipc(iacc)
14781  iim=imc(iacc)
14782  goto 360
14783 C...Scenario II': also require that string length decreases.
14784  ELSE
14785  iip=ipc(ic)
14786  iim=imc(ic)
14787  i1p=inp(iip)
14788  i2p=inp(iip+1)
14789  i1m=inm(iim)
14790  i2m=inm(iim+1)
14791  elold=four(i1p,i2p)*four(i1m,i2m)
14792  elnew=four(i1p,i2m)*four(i1m,i2p)
14793  IF(elnew.LT.elold) THEN
14794  iacc=ic
14795  iip=ipc(iacc)
14796  iim=imc(iacc)
14797  goto 360
14798  ENDIF
14799  ENDIF
14800  ENDIF
14801  350 CONTINUE
14802  360 CONTINUE
14803  ENDIF
14804 
14805 C...Begin scenario GH specifics.
14806  ELSEIF(mstp(115).EQ.5) THEN
14807 
14808 C...Loop through all string pieces, one from W+ and one from W-.
14809  iacc=0
14810  elmin=1d0
14811  DO 380 iip=1,nnp-1
14812  IF(k(inp(iip),2).LT.0) goto 380
14813  i1p=inp(iip)
14814  i2p=inp(iip+1)
14815  DO 370 iim=1,nnm-1
14816  IF(k(inm(iim),2).LT.0) goto 370
14817  i1m=inm(iim)
14818  i2m=inm(iim+1)
14819 
14820 C...Look for largest decrease of (exponent of) Lambda measure.
14821  elold=four(i1p,i2p)*four(i1m,i2m)
14822  elnew=four(i1p,i2m)*four(i1m,i2p)
14823  eldif=elnew/max(1d-10,elold)
14824  IF(eldif.LT.elmin) THEN
14825  iacc=iip+iim
14826  elmin=eldif
14827  ipc(1)=iip
14828  imc(1)=iim
14829  ENDIF
14830  370 CONTINUE
14831  380 CONTINUE
14832  iip=ipc(1)
14833  iim=imc(1)
14834  ENDIF
14835 
14836 C...Common for scenarios I, II, II' and GH: reconnect strings.
14837  IF(iacc.NE.0) THEN
14838  mint(32)=1
14839  njoin=0
14840  DO 390 is=1,nnp+nnm
14841  njoin=njoin+1
14842  IF(is.LE.iip) THEN
14843  i=inp(is)
14844  ELSEIF(is.LE.iip+nnm-iim) THEN
14845  i=inm(is-iip+iim)
14846  ELSEIF(is.LE.iip+nnm) THEN
14847  i=inm(is-iip-nnm+iim)
14848  ELSE
14849  i=inp(is-nnm)
14850  ENDIF
14851  ijoin(njoin)=i
14852  IF(k(i,2).LT.0) THEN
14853  CALL pyjoin(njoin,ijoin)
14854  njoin=0
14855  ENDIF
14856  390 CONTINUE
14857 
14858 C...Restore original event record if no reconnection.
14859  ELSE
14860  DO 400 i=nsd1+1,nold
14861  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
14862  k(i,4)=mod(k(i,4),mstu(5)**2)
14863  k(i,5)=mod(k(i,5),mstu(5)**2)
14864  ENDIF
14865  400 CONTINUE
14866  DO 410 i=nold+1,n
14867  k(k(i,3),1)=3
14868  410 CONTINUE
14869  n=nold
14870  ENDIF
14871 
14872 C...Boost back system.
14873  CALL pyrobo(iw1,iw1,0d0,0d0,beww(1),beww(2),beww(3))
14874  CALL pyrobo(iw2,iw2,0d0,0d0,beww(1),beww(2),beww(3))
14875  IF(n.GT.nold) CALL pyrobo(nold+1,n,0d0,0d0,
14876  & beww(1),beww(2),beww(3))
14877 
14878 C...Common part for intermediate and instantaneous scenarios.
14879  ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
14880  mint(32)=1
14881 
14882 C...Remove old shower products and reset showering ones.
14883  n=nsd1+4
14884  DO 420 i=nsd1+1,nsd1+4
14885  k(i,1)=3
14886  k(i,4)=mod(k(i,4),mstu(5)**2)
14887  k(i,5)=mod(k(i,5),mstu(5)**2)
14888  420 CONTINUE
14889 
14890 C...Identify quark-antiquark pairs.
14891  iq1=nsd1+1
14892  iq2=nsd1+2
14893  iq3=nsd1+3
14894  IF(k(iq1,2)*k(iq3,2).LT.0) iq3=nsd1+4
14895  iq4=2*nsd1+7-iq3
14896 
14897 C...Reconnect strings.
14898  ijoin(1)=iq1
14899  ijoin(2)=iq4
14900  CALL pyjoin(2,ijoin)
14901  ijoin(1)=iq3
14902  ijoin(2)=iq2
14903  CALL pyjoin(2,ijoin)
14904 
14905 C...Do new parton showers in intermediate scenario.
14906  IF(mstp(71).GE.1.AND.mstp(115).EQ.11) THEN
14907  CALL pyshow(iq1,iq2,p(iw1,5))
14908  CALL pyshow(iq3,iq4,p(iw2,5))
14909 
14910 C...Do new parton showers in instantaneous scenario.
14911  ELSEIF(mstp(71).GE.1.AND.mstp(115).EQ.12) THEN
14912  ppm2=(p(iq1,4)+p(iq4,4))**2-(p(iq1,1)+p(iq4,1))**2-
14913  & (p(iq1,2)+p(iq4,2))**2-(p(iq1,3)+p(iq4,3))**2
14914  ppm=sqrt(max(0d0,ppm2))
14915  CALL pyshow(iq1,iq4,ppm)
14916  ppm2=(p(iq3,4)+p(iq2,4))**2-(p(iq3,1)+p(iq2,1))**2-
14917  & (p(iq3,2)+p(iq2,2))**2-(p(iq3,3)+p(iq2,3))**2
14918  ppm=sqrt(max(0d0,ppm2))
14919  CALL pyshow(iq3,iq2,ppm)
14920  ENDIF
14921  ENDIF
14922 
14923  RETURN
14924  END
14925 
14926 C***********************************************************************
14927 
14928 C...PYKLIM
14929 C...Checks generated variables against pre-set kinematical limits;
14930 C...also calculates limits on variables used in generation.
14931 
14932  SUBROUTINE pyklim(ILIM)
14933 
14934 C...Double precision and integer declarations.
14935  IMPLICIT DOUBLE PRECISION(a-h, o-z)
14936  INTEGER pyk,pychge,pycomp
14937 C...Commonblocks.
14938  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
14939  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14940  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14941  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
14942  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
14943  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14944  common/pyint1/mint(400),vint(400)
14945  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
14946  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
14947  &/pyint1/,/pyint2/
14948 
14949 C...Common kinematical expressions.
14950  mint(51)=0
14951  isub=mint(1)
14952  istsb=iset(isub)
14953  IF(isub.EQ.96) goto 100
14954  sqm3=vint(63)
14955  sqm4=vint(64)
14956  IF(ilim.NE.0) THEN
14957  IF(abs(sqm3).LT.1d-4.AND.abs(sqm4).LT.1d-4) THEN
14958  ckin09=max(ckin(9),ckin(13))
14959  ckin10=min(ckin(10),ckin(14))
14960  ckin11=max(ckin(11),ckin(15))
14961  ckin12=min(ckin(12),ckin(16))
14962  ELSE
14963  ckin09=max(ckin(9),min(0d0,ckin(13)))
14964  ckin10=min(ckin(10),max(0d0,ckin(14)))
14965  ckin11=max(ckin(11),min(0d0,ckin(15)))
14966  ckin12=min(ckin(12),max(0d0,ckin(16)))
14967  ENDIF
14968  ENDIF
14969  IF(ilim.NE.1) THEN
14970  tau=vint(21)
14971  rm3=sqm3/(tau*vint(2))
14972  rm4=sqm4/(tau*vint(2))
14973  be34=sqrt(max(1d-20,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
14974  ENDIF
14975  pthmin=ckin(3)
14976  IF(min(sqm3,sqm4).LT.ckin(6)**2.AND.istsb.NE.1.AND.istsb.NE.3)
14977  &pthmin=max(ckin(3),ckin(5))
14978 
14979  IF(ilim.EQ.0) THEN
14980 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
14981 C...pre-set kinematical limits.
14982  yst=vint(22)
14983  cth=vint(23)
14984  taup=vint(26)
14985  taue=tau
14986  IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
14987  x1=sqrt(taue)*exp(yst)
14988  x2=sqrt(taue)*exp(-yst)
14989  xf=x1-x2
14990  IF(mint(47).NE.1) THEN
14991  IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1
14992  IF(ckin(2).GE.0d0.AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1
14993  IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1
14994  IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1
14995  ENDIF
14996  IF(mint(45).NE.1) THEN
14997  IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1
14998  ENDIF
14999  IF(mint(46).NE.1) THEN
15000  IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1
15001  ENDIF
15002  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
15003  pth=0.5d0*be34*sqrt(tau*vint(2)*max(0d0,1d0-cth**2))
15004  expy3=max(1.d-10,(1d0+rm3-rm4+be34*cth)/
15005  & max(1.d-10,(1d0+rm3-rm4-be34*cth)))
15006  expy4=max(1.d-10,(1d0-rm3+rm4-be34*cth)/
15007  & max(1.d-10,(1d0-rm3+rm4+be34*cth)))
15008  y3=yst+0.5d0*log(expy3)
15009  y4=yst+0.5d0*log(expy4)
15010  ylarge=max(y3,y4)
15011  ysmall=min(y3,y4)
15012  etalar=10d0
15013  etasma=-10d0
15014  sth=sqrt(max(0d0,1d0-cth**2))
15015  exsq3=sqrt(max(1d-20,((1d0+rm3-rm4)*cosh(yst)+be34*sinh(yst)*
15016  & cth)**2-4d0*rm3))
15017  exsq4=sqrt(max(1d-20,((1d0-rm3+rm4)*cosh(yst)-be34*sinh(yst)*
15018  & cth)**2-4d0*rm4))
15019  IF(sth.GE.1.d-6) THEN
15020  expet3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+exsq3)/
15021  & (be34*sth)
15022  expet4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+exsq4)/
15023  & (be34*sth)
15024  eta3=log(min(1.d10,max(1.d-10,expet3)))
15025  eta4=log(min(1.d10,max(1.d-10,expet4)))
15026  etalar=max(eta3,eta4)
15027  etasma=min(eta3,eta4)
15028  ENDIF
15029  cts3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/exsq3
15030  cts4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/exsq4
15031  ctslar=min(1d0,max(cts3,cts4))
15032  ctssma=max(-1d0,min(cts3,cts4))
15033  sh=tau*vint(2)
15034  rpts=4d0*vint(71)**2/sh
15035  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
15036  rm34=max(1d-20,2d0*rm3*rm4)
15037  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
15038  & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
15039  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
15040  tha=0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)
15041  uha=0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
15042  IF(pth.LT.pthmin) mint(51)=1
15043  IF(ckin(4).GE.0d0.AND.pth.GT.ckin(4)) mint(51)=1
15044  IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1
15045  IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1
15046  IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1
15047  IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1
15048  IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1
15049  IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1
15050  IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1
15051  IF(tha.LT.ckin(35)) mint(51)=1
15052  IF(ckin(36).GE.0d0.AND.tha.GT.ckin(36)) mint(51)=1
15053  IF(uha.LT.ckin(37)) mint(51)=1
15054  IF(ckin(38).GE.0d0.AND.uha.GT.ckin(38)) mint(51)=1
15055  ENDIF
15056  IF(istsb.GE.3.AND.istsb.LE.5) THEN
15057  IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1
15058  IF(ckin(32).GE.0d0.AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1
15059  ENDIF
15060 
15061 C...Additional cuts on W2 (approximately) in DIS.
15062  IF(isub.EQ.10) THEN
15063  xbj=x2
15064  IF(iabs(mint(12)).LT.20) xbj=x1
15065  q2bj=tha
15066  w2bj=q2bj*(1d0-xbj)/xbj
15067  IF(w2bj.LT.ckin(39)) mint(51)=1
15068  IF(ckin(40).GT.0d0.AND.w2bj.GT.ckin(40)) mint(51)=1
15069  ENDIF
15070 
15071  ELSEIF(ilim.EQ.1) THEN
15072 C...Calculate limits on tau
15073 C...0) due to definition
15074  taumn0=0d0
15075  taumx0=1d0
15076 C...1) due to limits on subsystem mass
15077  taumn1=ckin(1)**2/vint(2)
15078  taumx1=1d0
15079  IF(ckin(2).GE.0d0) taumx1=ckin(2)**2/vint(2)
15080 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15081  tm3=sqrt(sqm3+pthmin**2)
15082  tm4=sqrt(sqm4+pthmin**2)
15083  ydcosh=1d0
15084  IF(ckin09.GT.ckin12) ydcosh=cosh(ckin09-ckin12)
15085  taumn2=(tm3**2+2d0*tm3*tm4*ydcosh+tm4**2)/vint(2)
15086  taumx2=1d0
15087 C...3) due to limits on pT-hat and cos(theta-hat)
15088  cth2mn=min(ckin(27)**2,ckin(28)**2)
15089  cth2mx=max(ckin(27)**2,ckin(28)**2)
15090  taumn3=0d0
15091  IF(ckin(27)*ckin(28).GT.0d0) taumn3=
15092  & (sqrt(sqm3+pthmin**2/(1d0-cth2mn))+
15093  & sqrt(sqm4+pthmin**2/(1d0-cth2mn)))**2/vint(2)
15094  taumx3=1d0
15095  IF(ckin(4).GE.0d0.AND.cth2mx.LT.1d0) taumx3=
15096  & (sqrt(sqm3+ckin(4)**2/(1d0-cth2mx))+
15097  & sqrt(sqm4+ckin(4)**2/(1d0-cth2mx)))**2/vint(2)
15098 C...4) due to limits on x1 and x2
15099  taumn4=ckin(21)*ckin(23)
15100  taumx4=ckin(22)*ckin(24)
15101 C...5) due to limits on xF
15102  taumn5=0d0
15103  taumx5=max(1d0-ckin(25),1d0+ckin(26))
15104 C...6) due to limits on that and uhat
15105  taumn6=(sqm3+sqm4+ckin(35)+ckin(37))/vint(2)
15106  taumx6=1d0
15107  IF(ckin(36).GT.0d0.AND.ckin(38).GT.0d0) taumx6=
15108  & (sqm3+sqm4+ckin(36)+ckin(38))/vint(2)
15109 
15110 C...Net effect of all separate limits.
15111  vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5,taumn6)
15112  vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5,taumx6)
15113  IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
15114  vint(11)=0.99999d0
15115  vint(31)=1.00001d0
15116  ELSEIF(mint(47).EQ.5) THEN
15117  vint(31)=min(vint(31),0.999998d0)
15118  ENDIF
15119  IF(vint(31).LE.vint(11)) mint(51)=1
15120 
15121  ELSEIF(ilim.EQ.2) THEN
15122 C...Calculate limits on y*
15123  taue=tau
15124  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
15125  taurt=sqrt(taue)
15126 C...0) due to kinematics
15127  ystmn0=log(taurt)
15128  ystmx0=-ystmn0
15129 C...1) due to explicit limits
15130  ystmn1=ckin(7)
15131  ystmx1=ckin(8)
15132 C...2) due to limits on x1
15133  ystmn2=log(max(taue,ckin(21))/taurt)
15134  ystmx2=log(max(taue,ckin(22))/taurt)
15135 C...3) due to limits on x2
15136  ystmn3=-log(max(taue,ckin(24))/taurt)
15137  ystmx3=-log(max(taue,ckin(23))/taurt)
15138 C...4) due to limits on xF
15139  yepmn4=0.5d0*abs(ckin(25))/taurt
15140  ystmn4=sign(log(max(1d-20,sqrt(1d0+yepmn4**2)+yepmn4)),ckin(25))
15141  yepmx4=0.5d0*abs(ckin(26))/taurt
15142  ystmx4=sign(log(max(1d-20,sqrt(1d0+yepmx4**2)+yepmx4)),ckin(26))
15143 C...5) due to simultaneous limits on y-large and y-small
15144  yepsmn=(rm3-rm4)*sinh(ckin09-ckin11)
15145  yepsmx=(rm3-rm4)*sinh(ckin10-ckin12)
15146  ydifmn=abs(log(max(1d-20,sqrt(1d0+yepsmn**2)-yepsmn)))
15147  ydifmx=abs(log(max(1d-20,sqrt(1d0+yepsmx**2)-yepsmx)))
15148  ystmn5=0.5d0*(ckin09+ckin11-ydifmn)
15149  ystmx5=0.5d0*(ckin10+ckin12+ydifmx)
15150 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15151 C... y-small
15152  cthlim=sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*taue*vint(2))))
15153  rzmn=be34*max(ckin(27),-cthlim)
15154  rzmx=be34*min(ckin(28),cthlim)
15155  yex3mx=(1d0+rm3-rm4+rzmx)/max(1d-10,1d0+rm3-rm4-rzmx)
15156  yex4mx=(1d0+rm4-rm3-rzmn)/max(1d-10,1d0+rm4-rm3+rzmn)
15157  yex3mn=max(1d-10,1d0+rm3-rm4+rzmn)/(1d0+rm3-rm4-rzmn)
15158  yex4mn=max(1d-10,1d0+rm4-rm3-rzmx)/(1d0+rm4-rm3+rzmx)
15159  ystmn6=ckin09-0.5d0*log(max(yex3mx,yex4mx))
15160  ystmx6=ckin12-0.5d0*log(min(yex3mn,yex4mn))
15161 
15162 C...Net effect of all separate limits.
15163  vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)
15164  vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)
15165  IF(mint(47).EQ.1) THEN
15166  vint(12)=-0.00001d0
15167  vint(32)=0.00001d0
15168  ELSEIF(mint(47).EQ.2) THEN
15169  vint(12)=0.99999d0*ystmx0
15170  vint(32)=1.00001d0*ystmx0
15171  ELSEIF(mint(47).EQ.3) THEN
15172  vint(12)=-1.00001d0*ystmx0
15173  vint(32)=-0.99999d0*ystmx0
15174  ELSEIF(mint(47).EQ.5) THEN
15175  ystee=log(0.999999d0/taurt)
15176  vint(12)=max(vint(12),-ystee)
15177  vint(32)=min(vint(32),ystee)
15178  ENDIF
15179  IF(vint(32).LE.vint(12)) mint(51)=1
15180 
15181  ELSEIF(ilim.EQ.3) THEN
15182 C...Calculate limits on cos(theta-hat)
15183  yst=vint(22)
15184 C...0) due to definition
15185  ctnmn0=-1d0
15186  ctnmx0=0d0
15187  ctpmn0=0d0
15188  ctpmx0=1d0
15189 C...1) due to explicit limits
15190  ctnmn1=min(0d0,ckin(27))
15191  ctnmx1=min(0d0,ckin(28))
15192  ctpmn1=max(0d0,ckin(27))
15193  ctpmx1=max(0d0,ckin(28))
15194 C...2) due to limits on pT-hat
15195  ctnmn2=-sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*tau*vint(2))))
15196  ctpmx2=-ctnmn2
15197  ctnmx2=0d0
15198  ctpmn2=0d0
15199  IF(ckin(4).GE.0d0) THEN
15200  ctnmx2=-sqrt(max(0d0,1d0-4d0*ckin(4)**2/
15201  & (be34**2*tau*vint(2))))
15202  ctpmn2=-ctnmx2
15203  ENDIF
15204 C...3) due to limits on y-large and y-small
15205  ctnmn3=min(0d0,max((1d0+rm3-rm4)/be34*tanh(ckin11-yst),
15206  & -(1d0-rm3+rm4)/be34*tanh(ckin10-yst)))
15207  ctnmx3=min(0d0,(1d0+rm3-rm4)/be34*tanh(ckin12-yst),
15208  & -(1d0-rm3+rm4)/be34*tanh(ckin09-yst))
15209  ctpmn3=max(0d0,(1d0+rm3-rm4)/be34*tanh(ckin09-yst),
15210  & -(1d0-rm3+rm4)/be34*tanh(ckin12-yst))
15211  ctpmx3=max(0d0,min((1d0+rm3-rm4)/be34*tanh(ckin10-yst),
15212  & -(1d0-rm3+rm4)/be34*tanh(ckin11-yst)))
15213 C...4) due to limits on that
15214  ctnmn4=-1d0
15215  ctnmx4=0d0
15216  ctpmn4=0d0
15217  ctpmx4=1d0
15218  sh=tau*vint(2)
15219  IF(ckin(35).GT.0d0) THEN
15220  ctlim=(1d0-rm3-rm4-2d0*ckin(35)/sh)/be34
15221  IF(ctlim.GT.0d0) THEN
15222  ctpmx4=ctlim
15223  ELSE
15224  ctpmx4=0d0
15225  ctnmx4=ctlim
15226  ENDIF
15227  ENDIF
15228  IF(ckin(36).GT.0d0) THEN
15229  ctlim=(1d0-rm3-rm4-2d0*ckin(36)/sh)/be34
15230  IF(ctlim.LT.0d0) THEN
15231  ctnmn4=ctlim
15232  ELSE
15233  ctnmn4=0d0
15234  ctpmn4=ctlim
15235  ENDIF
15236  ENDIF
15237 C...5) due to limits on uhat
15238  ctnmn5=-1d0
15239  ctnmx5=0d0
15240  ctpmn5=0d0
15241  ctpmx5=1d0
15242  IF(ckin(37).GT.0d0) THEN
15243  ctlim=(2d0*ckin(37)/sh-(1d0-rm3-rm4))/be34
15244  IF(ctlim.LT.0d0) THEN
15245  ctnmn5=ctlim
15246  ELSE
15247  ctnmn5=0d0
15248  ctpmn5=ctlim
15249  ENDIF
15250  ENDIF
15251  IF(ckin(38).GT.0d0) THEN
15252  ctlim=(2d0*ckin(38)/sh-(1d0-rm3-rm4))/be34
15253  IF(ctlim.GT.0d0) THEN
15254  ctpmx5=ctlim
15255  ELSE
15256  ctpmx5=0d0
15257  ctnmx5=ctlim
15258  ENDIF
15259  ENDIF
15260 
15261 C...Net effect of all separate limits.
15262  vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3,ctnmn4,ctnmn5)
15263  vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3,ctnmx4,ctnmx5)
15264  vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3,ctpmn4,ctpmn5)
15265  vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3,ctpmx4,ctpmx5)
15266  IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1
15267 
15268  ELSEIF(ilim.EQ.4) THEN
15269 C...Calculate limits on tau'
15270 C...0) due to kinematics
15271  tapmn0=tau
15272  IF(istsb.EQ.5.AND.kfpr(isub,2).GT.0) THEN
15273  pqrat=2d0*pmas(pycomp(kfpr(isub,2)),1)/vint(1)
15274  tapmn0=(sqrt(tau)+pqrat)**2
15275  ENDIF
15276  tapmx0=1d0
15277 C...1) due to explicit limits
15278  tapmn1=ckin(31)**2/vint(2)
15279  tapmx1=1d0
15280  IF(ckin(32).GE.0d0) tapmx1=ckin(32)**2/vint(2)
15281 
15282 C...Net effect of all separate limits.
15283  vint(16)=max(tapmn0,tapmn1)
15284  vint(36)=min(tapmx0,tapmx1)
15285  IF(mint(47).EQ.1) THEN
15286  vint(16)=0.99999d0
15287  vint(36)=1.00001d0
15288  ENDIF
15289  IF(vint(36).LE.vint(16)) mint(51)=1
15290 
15291  ENDIF
15292  RETURN
15293 
15294 C...Special case for low-pT and multiple interactions:
15295 C...effective kinematical limits for tau, y*, cos(theta-hat).
15296  100 IF(ilim.EQ.0) THEN
15297  ELSEIF(ilim.EQ.1) THEN
15298  IF(mstp(82).LE.1) vint(11)=4d0*parp(81)**2/vint(2)
15299  IF(mstp(82).GE.2) vint(11)=parp(82)**2/vint(2)
15300  vint(31)=1d0
15301  ELSEIF(ilim.EQ.2) THEN
15302  vint(12)=0.5d0*log(vint(21))
15303  vint(32)=-vint(12)
15304  ELSEIF(ilim.EQ.3) THEN
15305  IF(mstp(82).LE.1) st2eff=4d0*parp(81)**2/(vint(21)*vint(2))
15306  IF(mstp(82).GE.2) st2eff=0.01d0*parp(82)**2/(vint(21)*vint(2))
15307  vint(13)=-sqrt(max(0d0,1d0-st2eff))
15308  vint(33)=0d0
15309  vint(14)=0d0
15310  vint(34)=-vint(13)
15311  ENDIF
15312 
15313  RETURN
15314  END
15315 
15316 C*********************************************************************
15317 
15318 C...PYKMAP
15319 C...Maps a uniform distribution into a distribution of a kinematical
15320 C...variable according to one of the possibilities allowed. It is
15321 C...assumed that kinematical limits have been set by a PYKLIM call.
15322 
15323  SUBROUTINE pykmap(IVAR,MVAR,VVAR)
15324 
15325 C...Double precision and integer declarations.
15326  IMPLICIT DOUBLE PRECISION(a-h, o-z)
15327  INTEGER pyk,pychge,pycomp
15328 C...Commonblocks.
15329  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15330  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
15331  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
15332  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15333  common/pyint1/mint(400),vint(400)
15334  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15335  SAVE /pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,/pyint2/
15336 
15337 C...Convert VVAR to tau variable.
15338  isub=mint(1)
15339  istsb=iset(isub)
15340  IF(ivar.EQ.1) THEN
15341  taumin=vint(11)
15342  taumax=vint(31)
15343  IF(mvar.EQ.3.OR.mvar.EQ.4) THEN
15344  taure=vint(73)
15345  gamre=vint(74)
15346  ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN
15347  taure=vint(75)
15348  gamre=vint(76)
15349  ENDIF
15350  IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
15351  tau=1d0
15352  ELSEIF(mvar.EQ.1) THEN
15353  tau=taumin*(taumax/taumin)**vvar
15354  ELSEIF(mvar.EQ.2) THEN
15355  tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)
15356  ELSEIF(mvar.EQ.3.OR.mvar.EQ.5) THEN
15357  ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax
15358  tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)
15359  ELSEIF(mvar.EQ.4.OR.mvar.EQ.6) THEN
15360  aupp=atan((taumax-taure)/gamre)
15361  alow=atan((taumin-taure)/gamre)
15362  tau=taure+gamre*tan(alow+(aupp-alow)*vvar)
15363  ELSE
15364  aupp=log(max(2d-6,1d0-taumax))
15365  alow=log(max(2d-6,1d0-taumin))
15366  tau=1d0-exp(aupp+vvar*(alow-aupp))
15367  ENDIF
15368  vint(21)=min(taumax,max(taumin,tau))
15369 
15370 C...Convert VVAR to y* variable.
15371  ELSEIF(ivar.EQ.2) THEN
15372  ystmin=vint(12)
15373  ystmax=vint(32)
15374  taue=vint(21)
15375  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
15376  IF(mint(47).EQ.1) THEN
15377  yst=0d0
15378  ELSEIF(mint(47).EQ.2) THEN
15379  yst=-0.5d0*log(taue)
15380  ELSEIF(mint(47).EQ.3) THEN
15381  yst=0.5d0*log(taue)
15382  ELSEIF(mvar.EQ.1) THEN
15383  yst=ystmin+(ystmax-ystmin)*sqrt(vvar)
15384  ELSEIF(mvar.EQ.2) THEN
15385  yst=ystmax-(ystmax-ystmin)*sqrt(1d0-vvar)
15386  ELSEIF(mvar.EQ.3) THEN
15387  aupp=atan(exp(ystmax))
15388  alow=atan(exp(ystmin))
15389  yst=log(tan(alow+(aupp-alow)*vvar))
15390  ELSEIF(mvar.EQ.4) THEN
15391  yst0=-0.5d0*log(taue)
15392  aupp=log(max(1d-6,exp(yst0-ystmin)-1d0))
15393  alow=log(max(1d-6,exp(yst0-ystmax)-1d0))
15394  yst=yst0-log(1d0+exp(alow+vvar*(aupp-alow)))
15395  ELSE
15396  yst0=-0.5d0*log(taue)
15397  aupp=log(max(1d-6,exp(yst0+ystmin)-1d0))
15398  alow=log(max(1d-6,exp(yst0+ystmax)-1d0))
15399  yst=log(1d0+exp(aupp+vvar*(alow-aupp)))-yst0
15400  ENDIF
15401  vint(22)=min(ystmax,max(ystmin,yst))
15402 
15403 C...Convert VVAR to cos(theta-hat) variable.
15404  ELSEIF(ivar.EQ.3) THEN
15405  rm34=max(1d-20,2d0*vint(63)*vint(64)/(vint(21)*vint(2))**2)
15406  rsqm=1d0+rm34
15407  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
15408  & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
15409  ctnmin=vint(13)
15410  ctnmax=vint(33)
15411  ctpmin=vint(14)
15412  ctpmax=vint(34)
15413  IF(mvar.EQ.1) THEN
15414  aneg=ctnmax-ctnmin
15415  apos=ctpmax-ctpmin
15416  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
15417  vctn=vvar*(aneg+apos)/aneg
15418  cth=ctnmin+(ctnmax-ctnmin)*vctn
15419  ELSE
15420  vctp=(vvar*(aneg+apos)-aneg)/apos
15421  cth=ctpmin+(ctpmax-ctpmin)*vctp
15422  ENDIF
15423  ELSEIF(mvar.EQ.2) THEN
15424  rmnmin=max(rm34,rsqm-ctnmin)
15425  rmnmax=max(rm34,rsqm-ctnmax)
15426  rmpmin=max(rm34,rsqm-ctpmin)
15427  rmpmax=max(rm34,rsqm-ctpmax)
15428  aneg=log(rmnmin/rmnmax)
15429  apos=log(rmpmin/rmpmax)
15430  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
15431  vctn=vvar*(aneg+apos)/aneg
15432  cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn
15433  ELSE
15434  vctp=(vvar*(aneg+apos)-aneg)/apos
15435  cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp
15436  ENDIF
15437  ELSEIF(mvar.EQ.3) THEN
15438  rmnmin=max(rm34,rsqm+ctnmin)
15439  rmnmax=max(rm34,rsqm+ctnmax)
15440  rmpmin=max(rm34,rsqm+ctpmin)
15441  rmpmax=max(rm34,rsqm+ctpmax)
15442  aneg=log(rmnmax/rmnmin)
15443  apos=log(rmpmax/rmpmin)
15444  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
15445  vctn=vvar*(aneg+apos)/aneg
15446  cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm
15447  ELSE
15448  vctp=(vvar*(aneg+apos)-aneg)/apos
15449  cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm
15450  ENDIF
15451  ELSEIF(mvar.EQ.4) THEN
15452  rmnmin=max(rm34,rsqm-ctnmin)
15453  rmnmax=max(rm34,rsqm-ctnmax)
15454  rmpmin=max(rm34,rsqm-ctpmin)
15455  rmpmax=max(rm34,rsqm-ctpmax)
15456  aneg=1d0/rmnmax-1d0/rmnmin
15457  apos=1d0/rmpmax-1d0/rmpmin
15458  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
15459  vctn=vvar*(aneg+apos)/aneg
15460  cth=rsqm-1d0/(1d0/rmnmin+aneg*vctn)
15461  ELSE
15462  vctp=(vvar*(aneg+apos)-aneg)/apos
15463  cth=rsqm-1d0/(1d0/rmpmin+apos*vctp)
15464  ENDIF
15465  ELSEIF(mvar.EQ.5) THEN
15466  rmnmin=max(rm34,rsqm+ctnmin)
15467  rmnmax=max(rm34,rsqm+ctnmax)
15468  rmpmin=max(rm34,rsqm+ctpmin)
15469  rmpmax=max(rm34,rsqm+ctpmax)
15470  aneg=1d0/rmnmin-1d0/rmnmax
15471  apos=1d0/rmpmin-1d0/rmpmax
15472  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
15473  vctn=vvar*(aneg+apos)/aneg
15474  cth=1d0/(1d0/rmnmin-aneg*vctn)-rsqm
15475  ELSE
15476  vctp=(vvar*(aneg+apos)-aneg)/apos
15477  cth=1d0/(1d0/rmpmin-apos*vctp)-rsqm
15478  ENDIF
15479  ENDIF
15480  IF(cth.LT.0d0) cth=min(ctnmax,max(ctnmin,cth))
15481  IF(cth.GT.0d0) cth=min(ctpmax,max(ctpmin,cth))
15482  vint(23)=cth
15483 
15484 C...Convert VVAR to tau' variable.
15485  ELSEIF(ivar.EQ.4) THEN
15486  tau=vint(21)
15487  taupmn=vint(16)
15488  taupmx=vint(36)
15489  IF(mint(47).EQ.1) THEN
15490  taup=1d0
15491  ELSEIF(mvar.EQ.1) THEN
15492  taup=taupmn*(taupmx/taupmn)**vvar
15493  ELSEIF(mvar.EQ.2) THEN
15494  aupp=(1d0-tau/taupmx)**4
15495  alow=(1d0-tau/taupmn)**4
15496  taup=tau/max(1d-7,1d0-(alow+(aupp-alow)*vvar)**0.25d0)
15497  ELSE
15498  aupp=log(max(2d-6,1d0-taupmx))
15499  alow=log(max(2d-6,1d0-taupmn))
15500  taup=1d0-exp(aupp+vvar*(alow-aupp))
15501  ENDIF
15502  vint(26)=min(taupmx,max(taupmn,taup))
15503 
15504 C...Selection of extra variables needed in 2 -> 3 process:
15505 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
15506 C...Since no options are available, the functions of PYKLIM
15507 C...and PYKMAP are joint for these choices.
15508  ELSEIF(ivar.EQ.5) THEN
15509 
15510 C...Read out total energy and particle masses.
15511  mint(51)=0
15512  mptpk=1
15513  IF(isub.EQ.123.OR.isub.EQ.124.OR.isub.EQ.173.OR.isub.EQ.174
15514  & .OR.isub.EQ.178.OR.isub.EQ.179) mptpk=2
15515  shp=vint(26)*vint(2)
15516  shpr=sqrt(shp)
15517  pm1=vint(201)
15518  pm2=vint(206)
15519  pm3=sqrt(vint(21))*vint(1)
15520  IF(pm1+pm2+pm3.GT.0.9999d0*shpr) THEN
15521  mint(51)=1
15522  RETURN
15523  ENDIF
15524  pmrs1=vint(204)**2
15525  pmrs2=vint(209)**2
15526 
15527 C...Specify coefficients of pT choice; upper and lower limits.
15528  IF(mptpk.EQ.1) THEN
15529  hwt1=0.4d0
15530  hwt2=0.4d0
15531  ELSE
15532  hwt1=0.05d0
15533  hwt2=0.05d0
15534  ENDIF
15535  hwt3=1d0-hwt1-hwt2
15536  ptsmx1=((shp-pm1**2-(pm2+pm3)**2)**2-(2d0*pm1*(pm2+pm3))**2)/
15537  & (4d0*shp)
15538  IF(ckin(52).GT.0d0) ptsmx1=min(ptsmx1,ckin(52)**2)
15539  ptsmn1=ckin(51)**2
15540  ptsmx2=((shp-pm2**2-(pm1+pm3)**2)**2-(2d0*pm2*(pm1+pm3))**2)/
15541  & (4d0*shp)
15542  IF(ckin(54).GT.0d0) ptsmx2=min(ptsmx2,ckin(54)**2)
15543  ptsmn2=ckin(53)**2
15544 
15545 C...Select transverse momenta according to
15546 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
15547  hmx=pmrs1+ptsmx1
15548  hmn=pmrs1+ptsmn1
15549  IF(hmx.LT.1.0001d0*hmn) THEN
15550  mint(51)=1
15551  RETURN
15552  ENDIF
15553  hde=ptsmx1-ptsmn1
15554  rpt=pyr(0)
15555  IF(rpt.LT.hwt1) THEN
15556  pts1=ptsmn1+pyr(0)*hde
15557  ELSEIF(rpt.LT.hwt1+hwt2) THEN
15558  pts1=max(ptsmn1,hmn*(hmx/hmn)**pyr(0)-pmrs1)
15559  ELSE
15560  pts1=max(ptsmn1,hmn*hmx/(hmn+pyr(0)*hde)-pmrs1)
15561  ENDIF
15562  wtpts1=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs1+pts1))+
15563  & hwt3*hmn*hmx/(pmrs1+pts1)**2)
15564  hmx=pmrs2+ptsmx2
15565  hmn=pmrs2+ptsmn2
15566  IF(hmx.LT.1.0001d0*hmn) THEN
15567  mint(51)=1
15568  RETURN
15569  ENDIF
15570  hde=ptsmx2-ptsmn2
15571  rpt=pyr(0)
15572  IF(rpt.LT.hwt1) THEN
15573  pts2=ptsmn2+pyr(0)*hde
15574  ELSEIF(rpt.LT.hwt1+hwt2) THEN
15575  pts2=max(ptsmn2,hmn*(hmx/hmn)**pyr(0)-pmrs2)
15576  ELSE
15577  pts2=max(ptsmn2,hmn*hmx/(hmn+pyr(0)*hde)-pmrs2)
15578  ENDIF
15579  wtpts2=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs2+pts2))+
15580  & hwt3*hmn*hmx/(pmrs2+pts2)**2)
15581 
15582 C...Select azimuthal angles and check pT choice.
15583  phi1=paru(2)*pyr(0)
15584  phi2=paru(2)*pyr(0)
15585  phir=phi2-phi1
15586  pts3=max(0d0,pts1+pts2+2d0*sqrt(pts1*pts2)*cos(phir))
15587  IF(pts3.LT.ckin(55)**2.OR.(ckin(56).GT.0d0.AND.pts3.GT.
15588  & ckin(56)**2)) THEN
15589  mint(51)=1
15590  RETURN
15591  ENDIF
15592 
15593 C...Calculate transverse masses and check phase space not closed.
15594  pms1=pm1**2+pts1
15595  pms2=pm2**2+pts2
15596  pms3=pm3**2+pts3
15597  pmt1=sqrt(pms1)
15598  pmt2=sqrt(pms2)
15599  pmt3=sqrt(pms3)
15600  pm12=(pmt1+pmt2)**2
15601  IF(pmt1+pmt2+pmt3.GT.0.9999d0*shpr) THEN
15602  mint(51)=1
15603  RETURN
15604  ENDIF
15605 
15606 C...Select rapidity for particle 3 and check phase space not closed.
15607  y3max=log((shp+pms3-pm12+sqrt(max(0d0,(shp-pms3-pm12)**2-
15608  & 4d0*pms3*pm12)))/(2d0*shpr*pmt3))
15609  IF(y3max.LT.1d-6) THEN
15610  mint(51)=1
15611  RETURN
15612  ENDIF
15613  y3=(2d0*pyr(0)-1d0)*0.999999d0*y3max
15614  pz3=pmt3*sinh(y3)
15615  pe3=pmt3*cosh(y3)
15616 
15617 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
15618  pz12=-pz3
15619  pe12=shpr-pe3
15620  pms12=pe12**2-pz12**2
15621  sql12=sqrt(max(0d0,(pms12-pms1-pms2)**2-4d0*pms1*pms2))
15622  IF(sql12.LT.1d-6*shp) THEN
15623  mint(51)=1
15624  RETURN
15625  ENDIF
15626  pmm1=pms12+pms1-pms2
15627  pmm2=pms12+pms2-pms1
15628  tfac=-shpr/(2d0*pms12)
15629  t1p=tfac*(pe12-pz12)*(pmm1-sql12)
15630  t1n=tfac*(pe12-pz12)*(pmm1+sql12)
15631  t2p=tfac*(pe12+pz12)*(pmm2-sql12)
15632  t2n=tfac*(pe12+pz12)*(pmm2+sql12)
15633 
15634 C...Construct relative mirror weights and make choice.
15635  IF(mptpk.EQ.1) THEN
15636  wtpu=1d0
15637  wtnu=1d0
15638  ELSE
15639  wtpu=1d0/((t1p-pmrs1)*(t2p-pmrs2))**2
15640  wtnu=1d0/((t1n-pmrs1)*(t2n-pmrs2))**2
15641  ENDIF
15642  wtp=wtpu/(wtpu+wtnu)
15643  wtn=wtnu/(wtpu+wtnu)
15644  eps=1d0
15645  IF(wtn.GT.pyr(0)) eps=-1d0
15646 
15647 C...Store result of variable choice and associated weights.
15648  vint(202)=pts1
15649  vint(207)=pts2
15650  vint(203)=phi1
15651  vint(208)=phi2
15652  vint(205)=wtpts1
15653  vint(210)=wtpts2
15654  vint(211)=y3
15655  vint(212)=y3max
15656  vint(213)=eps
15657  IF(eps.GT.0d0) THEN
15658  vint(214)=1d0/wtp
15659  vint(215)=t1p
15660  vint(216)=t2p
15661  ELSE
15662  vint(214)=1d0/wtn
15663  vint(215)=t1n
15664  vint(216)=t2n
15665  ENDIF
15666  vint(217)=-0.5d0*tfac*(pe12-pz12)*(pmm2+eps*sql12)
15667  vint(218)=-0.5d0*tfac*(pe12+pz12)*(pmm1+eps*sql12)
15668  vint(219)=0.5d0*(pms12-pts3)
15669  vint(220)=sql12
15670  ENDIF
15671 
15672  RETURN
15673  END
15674 
15675 C***********************************************************************
15676 
15677 C...PYSIGH
15678 C...Differential matrix elements for all included subprocesses
15679 C...Note that what is coded is (disregarding the COMFAC factor)
15680 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15681 C...when d(sigma-hat) is given in the zero-width limit, the delta
15682 C...function in tau is replaced by a (modified) Breit-Wigner:
15683 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
15684 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
15685 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15686 C...i.e., dimensionless quantities
15687 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
15688 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
15689 C...(2pi)^4 delta^4(P - sum p_i)
15690 C...COMFAC contains the factor pi/s (or equivalent) and
15691 C...the conversion factor from GeV^-2 to mb
15692 
15693  SUBROUTINE pysigh(NCHN,SIGS)
15694 
15695 C...Double precision and integer declarations
15696  IMPLICIT DOUBLE PRECISION(a-h, o-z)
15697  INTEGER pyk,pychge,pycomp
15698 C...Parameter statement to help give large particle numbers.
15699  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
15700 C...Commonblocks
15701  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15702  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15703  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
15704  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
15705  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
15706  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15707  common/pyint1/mint(400),vint(400)
15708  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15709  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
15710  common/pyint4/mwid(500),wids(500,5)
15711  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
15712  common/pyint7/sigt(0:6,0:6,0:5)
15713  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
15714  &sfmix(16,4)
15715  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
15716  &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,
15717  &/pyssmt/
15718 C...Local arrays and complex variables
15719  dimension x(2),xpq(-25:25),kfac(2,-40:40),wdtp(0:200),
15720  &wdte(0:200,0:5),hgz(6,3),hl3(3),hr3(3),hl4(3),hr4(3)
15721  COMPLEX a004,a204,a114,a00u,a20u,a11u
15722  COMPLEX cigtot,ciztot,f0alp,f1alp,f2alp,f0bet,f1bet,f2bet,fif,
15723  &coulck,coulcp,coulcd,coulcr,coulcs
15724  REAL a00l,a11l,a20l,coulxx
15725 
15726 C...Reset number of channels and cross-section
15727  nchn=0
15728  sigs=0d0
15729 
15730 C...Convert H or A process into equivalent h one
15731  isub=mint(1)
15732  isubsv=isub
15733  ihigg=1
15734  kfhigg=25
15735  IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
15736  &isub.LE.190)) THEN
15737  ihigg=2
15738  IF(mod(isub-1,10).GE.5) ihigg=3
15739  kfhigg=33+ihigg
15740  IF(isub.EQ.151.OR.isub.EQ.156) isub=3
15741  IF(isub.EQ.152.OR.isub.EQ.157) isub=102
15742  IF(isub.EQ.153.OR.isub.EQ.158) isub=103
15743  IF(isub.EQ.171.OR.isub.EQ.176) isub=24
15744  IF(isub.EQ.172.OR.isub.EQ.177) isub=26
15745  IF(isub.EQ.173.OR.isub.EQ.178) isub=123
15746  IF(isub.EQ.174.OR.isub.EQ.179) isub=124
15747  IF(isub.EQ.181.OR.isub.EQ.186) isub=121
15748  IF(isub.EQ.182.OR.isub.EQ.187) isub=122
15749  ENDIF
15750 
15751 CMRENNA++
15752 C...Convert almost equivalent SUSY processes into each other
15753 C...Extract differences in flavours and couplings
15754  IF(isub.GE.200.AND.isub.LE.280) THEN
15755 
15756 C...Sleptons and sneutrinos
15757  IF(isub.EQ.201.OR.isub.EQ.204.OR.isub.EQ.207) THEN
15758  kfid=mod(kfpr(isub,1),ksusy1)
15759  isub=201
15760  ilr=0
15761  ELSEIF(isub.EQ.202.OR.isub.EQ.205.OR.isub.EQ.208) THEN
15762  kfid=mod(kfpr(isub,1),ksusy1)
15763  isub=201
15764  ilr=1
15765  ELSEIF(isub.EQ.203.OR.isub.EQ.206.OR.isub.EQ.209) THEN
15766  kfid=mod(kfpr(isub,1),ksusy1)
15767  isub=203
15768  ELSEIF(isub.GE.210.AND.isub.LE.212) THEN
15769  IF(isub.EQ.210) THEN
15770  rkf=2.0d0
15771  ELSEIF(isub.EQ.211) THEN
15772  rkf=sfmix(15,1)**2
15773  ELSEIF(isub.EQ.212) THEN
15774  rkf=sfmix(15,2)**2
15775  ENDIF
15776  isub=210
15777  ELSEIF(isub.EQ.213.OR.isub.EQ.214) THEN
15778  IF(isub.EQ.213) THEN
15779  kfid=mod(kfpr(isub,1),ksusy1)
15780  rkf=2.0d0
15781  ELSEIF(isub.EQ.214) THEN
15782  kfid=16
15783  rkf=1.0d0
15784  ENDIF
15785  isub=213
15786 
15787 C...Neutralinos
15788  ELSEIF(isub.GE.216.AND.isub.LE.225) THEN
15789  IF(isub.EQ.216) THEN
15790  izid1=1
15791  izid2=1
15792  ELSEIF(isub.EQ.217) THEN
15793  izid1=2
15794  izid2=2
15795  ELSEIF(isub.EQ.218) THEN
15796  izid1=3
15797  izid2=3
15798  ELSEIF(isub.EQ.219) THEN
15799  izid1=4
15800  izid2=4
15801  ELSEIF(isub.EQ.220) THEN
15802  izid1=1
15803  izid2=2
15804  ELSEIF(isub.EQ.221) THEN
15805  izid1=1
15806  izid2=3
15807  ELSEIF(isub.EQ.222) THEN
15808  izid1=1
15809  izid2=4
15810  ELSEIF(isub.EQ.223) THEN
15811  izid1=2
15812  izid2=3
15813  ELSEIF(isub.EQ.224) THEN
15814  izid1=2
15815  izid2=4
15816  ELSEIF(isub.EQ.225) THEN
15817  izid1=3
15818  izid2=4
15819  ENDIF
15820  isub=216
15821 
15822 C...Charginos
15823  ELSEIF(isub.GE.226.AND.isub.LE.228) THEN
15824  IF(isub.EQ.226) THEN
15825  izid1=1
15826  izid2=1
15827  ELSEIF(isub.EQ.227) THEN
15828  izid1=2
15829  izid2=2
15830  ELSEIF(isub.EQ.228) THEN
15831  izid1=1
15832  izid2=2
15833  ENDIF
15834  isub=226
15835 
15836 C...Neutralino + chargino
15837  ELSEIF(isub.GE.229.AND.isub.LE.236) THEN
15838  IF(isub.EQ.229) THEN
15839  izid1=1
15840  izid2=1
15841  ELSEIF(isub.EQ.230) THEN
15842  izid1=1
15843  izid2=2
15844  ELSEIF(isub.EQ.231) THEN
15845  izid1=1
15846  izid2=3
15847  ELSEIF(isub.EQ.232) THEN
15848  izid1=1
15849  izid2=4
15850  ELSEIF(isub.EQ.233) THEN
15851  izid1=2
15852  izid2=1
15853  ELSEIF(isub.EQ.234) THEN
15854  izid1=2
15855  izid2=2
15856  ELSEIF(isub.EQ.235) THEN
15857  izid1=2
15858  izid2=3
15859  ELSEIF(isub.EQ.236) THEN
15860  izid1=2
15861  izid2=4
15862  ENDIF
15863  isub=229
15864 
15865 C...Gluino + neutralino
15866  ELSEIF(isub.GE.237.AND.isub.LE.240) THEN
15867  IF(isub.EQ.237) THEN
15868  izid=1
15869  ELSEIF(isub.EQ.238) THEN
15870  izid=2
15871  ELSEIF(isub.EQ.239) THEN
15872  izid=3
15873  ELSEIF(isub.EQ.240) THEN
15874  izid=4
15875  ENDIF
15876  isub=237
15877 
15878 C...Gluino + chargino
15879  ELSEIF(isub.GE.241.AND.isub.LE.242) THEN
15880  IF(isub.EQ.241) THEN
15881  izid=1
15882  ELSEIF(isub.EQ.242) THEN
15883  izid=2
15884  ENDIF
15885  isub=241
15886 
15887 C...Squark + neutralino
15888  ELSEIF(isub.GE.246.AND.isub.LE.253) THEN
15889  ilr=0
15890  IF(mod(isub,2).NE.0) ilr=1
15891  IF(isub.LE.247) THEN
15892  izid=1
15893  ELSEIF(isub.LE.249) THEN
15894  izid=2
15895  ELSEIF(isub.LE.251) THEN
15896  izid=3
15897  ELSEIF(isub.LE.253) THEN
15898  izid=4
15899  ENDIF
15900  isub=246
15901  rkf=5d0
15902 
15903 C...Squark + chargino
15904  ELSEIF(isub.GE.254.AND.isub.LE.257) THEN
15905  IF(isub.LE.255) THEN
15906  izid=1
15907  ELSEIF(isub.LE.257) THEN
15908  izid=2
15909  ENDIF
15910  IF(mod(isub,2).EQ.0) THEN
15911  ilr=0
15912  ELSE
15913  ilr=1
15914  ENDIF
15915  isub=254
15916  rkf=5d0
15917 
15918 C...Squark + gluino
15919  ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN
15920  isub=258
15921  rkf=5d0
15922 
15923 C...Stops
15924  ELSEIF(isub.EQ.261.OR.isub.EQ.262) THEN
15925  ilr=0
15926  IF(isub.EQ.262) ilr=1
15927  isub=261
15928  ELSEIF(isub.EQ.265) THEN
15929  isub=264
15930 
15931 C...Squarks
15932  ELSEIF(isub.GE.271.AND.isub.LE.280) THEN
15933  ilr=0
15934  IF(isub.LE.273) THEN
15935  IF(isub.EQ.273) ilr=1
15936  isub=271
15937  rkf=25d0
15938  ELSEIF(isub.LE.276) THEN
15939  IF(isub.EQ.276) ilr=1
15940  isub=274
15941  rkf=25d0
15942  ELSEIF(isub.LE.278) THEN
15943  IF(isub.EQ.278) ilr=1
15944  isub=277
15945  rkf=5d0
15946  ELSE
15947  IF(isub.EQ.280) ilr=1
15948  isub=279
15949  rkf=5d0
15950  ENDIF
15951  ENDIF
15952  ENDIF
15953 CMRENNA--
15954 
15955 C...Read kinematical variables and limits
15956  istsb=iset(isubsv)
15957  taumin=vint(11)
15958  ystmin=vint(12)
15959  ctnmin=vint(13)
15960  ctpmin=vint(14)
15961  taupmn=vint(16)
15962  tau=vint(21)
15963  yst=vint(22)
15964  cth=vint(23)
15965  xt2=vint(25)
15966  taup=vint(26)
15967  taumax=vint(31)
15968  ystmax=vint(32)
15969  ctnmax=vint(33)
15970  ctpmax=vint(34)
15971  taupmx=vint(36)
15972 
15973 C...Derive kinematical quantities
15974  taue=tau
15975  IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
15976  x(1)=sqrt(taue)*exp(yst)
15977  x(2)=sqrt(taue)*exp(-yst)
15978  IF(mint(45).EQ.2.AND.istsb.GE.1) THEN
15979  IF(x(1).GT.0.9999d0) RETURN
15980  ELSEIF(mint(45).EQ.3) THEN
15981  x(1)=min(0.9999989d0,x(1))
15982  ENDIF
15983  IF(mint(46).EQ.2.AND.istsb.GE.1) THEN
15984  IF(x(2).GT.0.9999d0) RETURN
15985  ELSEIF(mint(46).EQ.3) THEN
15986  x(2)=min(0.9999989d0,x(2))
15987  ENDIF
15988  sh=tau*vint(2)
15989  sqm3=vint(63)
15990  sqm4=vint(64)
15991  rm3=sqm3/sh
15992  rm4=sqm4/sh
15993  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
15994  rpts=4d0*vint(71)**2/sh
15995  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
15996  rm34=max(1d-20,2d0*rm3*rm4)
15997  rsqm=1d0+rm34
15998  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0) rm34=max(rm34,
15999  &2d0*vint(71)**2/(vint(21)*vint(2)))
16000  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
16001  IF(istsb.EQ.0) THEN
16002  th=vint(45)
16003  uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
16004  sqpth=max(vint(71)**2,0.25d0*sh*be34**2*vint(59)**2)
16005  ELSE
16006  th=-0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)
16007  uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
16008  sqpth=max(vint(71)**2,0.25d0*sh*be34**2*(1d0-cth**2))
16009  ENDIF
16010  shr=sqrt(sh)
16011  sh2=sh**2
16012  th2=th**2
16013  uh2=uh**2
16014 
16015 C...Choice of Q2 scale: hard, parton distributions, parton showers
16016  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
16017  q2=sh
16018  ELSEIF(mod(istsb,2).EQ.0.OR.istsb.EQ.9) THEN
16019  IF(mstp(32).EQ.1) THEN
16020  q2=2d0*sh*th*uh/(sh**2+th**2+uh**2)
16021  ELSEIF(mstp(32).EQ.2) THEN
16022  q2=sqpth+0.5d0*(sqm3+sqm4)
16023  ELSEIF(mstp(32).EQ.3) THEN
16024  q2=min(-th,-uh)
16025  ELSEIF(mstp(32).EQ.4) THEN
16026  q2=sh
16027  ELSEIF(mstp(32).EQ.5) THEN
16028  q2=-th
16029  ENDIF
16030  IF(istsb.EQ.9) q2=sqpth
16031  IF((istsb.EQ.9.AND.mstp(82).GE.2).OR.(istsb.NE.9.AND.
16032  & mstp(85).EQ.1)) q2=q2+parp(82)**2
16033  ENDIF
16034  q2sf=q2
16035  IF(istsb.GE.3.AND.istsb.LE.5) THEN
16036  q2sf=pmas(23,1)**2
16037  IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77.OR.isub.EQ.124)
16038  & q2sf=pmas(24,1)**2
16039  IF(isub.EQ.121.OR.isub.EQ.122) THEN
16040  q2sf=pmas(pycomp(kfpr(isubsv,2)),1)**2
16041  IF(mstp(39).EQ.2) q2sf=q2sf+max(vint(202),vint(207))
16042  IF(mstp(39).EQ.3) q2sf=sh
16043  IF(mstp(39).EQ.4) q2sf=vint(26)*vint(2)
16044  ENDIF
16045  ENDIF
16046  q2ps=q2sf
16047  q2sf=q2sf*parp(34)
16048  IF(mstp(68).GE.2.AND.mint(47).EQ.5) q2sf=vint(2)
16049  IF(mstp(22).GE.1.AND.(isub.EQ.10.OR.isub.EQ.83).AND.
16050  &(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
16051  xbj=x(2)
16052  IF(mint(43).EQ.3) xbj=x(1)
16053  IF(mstp(22).EQ.1) THEN
16054  q2ps=-th
16055  ELSEIF(mstp(22).EQ.2) THEN
16056  q2ps=((1d0-xbj)/xbj)*(-th)
16057  ELSEIF(mstp(22).EQ.3) THEN
16058  q2ps=sqrt((1d0-xbj)/xbj)*(-th)
16059  ELSE
16060  q2ps=(1d0-xbj)*max(1d0,-log(xbj))*(-th)
16061  ENDIF
16062  ENDIF
16063  IF(mstp(68).GE.1.AND.mint(47).EQ.5) q2ps=vint(2)
16064 
16065 C...Store derived kinematical quantities
16066  vint(41)=x(1)
16067  vint(42)=x(2)
16068  vint(44)=sh
16069  vint(43)=sqrt(sh)
16070  vint(45)=th
16071  vint(46)=uh
16072  vint(48)=sqpth
16073  vint(47)=sqrt(sqpth)
16074  vint(50)=taup*vint(2)
16075  vint(49)=sqrt(max(0d0,vint(50)))
16076  vint(52)=q2
16077  vint(51)=sqrt(q2)
16078  vint(54)=q2sf
16079  vint(53)=sqrt(q2sf)
16080  vint(56)=q2ps
16081  vint(55)=sqrt(q2ps)
16082 
16083 C...Calculate parton distributions
16084  IF(istsb.LE.0) goto 170
16085  IF(mint(47).GE.2) THEN
16086  DO 110 i=3-min(2,mint(45)),min(2,mint(46))
16087  xsf=x(i)
16088  IF(istsb.EQ.9) xsf=x(i)/vint(142+i)
16089  mint(105)=mint(102+i)
16090  mint(109)=mint(106+i)
16091  IF(mstp(57).LE.1) THEN
16092  CALL pypdfu(mint(10+i),xsf,q2sf,xpq)
16093  ELSE
16094  CALL pypdfl(mint(10+i),xsf,q2sf,xpq)
16095  ENDIF
16096  DO 100 kfl=-25,25
16097  xsfx(i,kfl)=xpq(kfl)
16098  100 CONTINUE
16099  110 CONTINUE
16100  ENDIF
16101 
16102 C...Calculate alpha_em, alpha_strong and K-factor
16103  xw=paru(102)
16104  xwv=xw
16105  IF(mstp(8).GE.2.OR.(isub.GE.71.AND.isub.LE.77)) xw=
16106  &1d0-(pmas(24,1)/pmas(23,1))**2
16107  xw1=1d0-xw
16108  xwc=1d0/(16d0*xw*xw1)
16109  aem=pyalem(q2)
16110  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
16111  IF(mstp(33).NE.3) as=pyalps(parp(34)*q2)
16112  fack=1d0
16113  faca=1d0
16114  IF(mstp(33).EQ.1) THEN
16115  fack=parp(31)
16116  ELSEIF(mstp(33).EQ.2) THEN
16117  fack=parp(31)
16118  faca=parp(32)/parp(31)
16119  ELSEIF(mstp(33).EQ.3) THEN
16120  q2as=parp(33)*q2
16121  IF(istsb.EQ.9.AND.mstp(82).GE.2) q2as=q2as+
16122  & paru(112)*parp(82)
16123  as=pyalps(q2as)
16124  ENDIF
16125  vint(138)=1d0
16126  vint(57)=aem
16127  vint(58)=as
16128 
16129 C...Set flags for allowed reacting partons/leptons
16130  DO 140 i=1,2
16131  DO 120 j=-25,25
16132  kfac(i,j)=0
16133  120 CONTINUE
16134  IF(mint(44+i).EQ.1) THEN
16135  kfac(i,mint(10+i))=1
16136  ELSEIF(mint(40+i).EQ.1.AND.mstp(12).EQ.0) THEN
16137  kfac(i,mint(10+i))=1
16138  kfac(i,22)=1
16139  kfac(i,24)=1
16140  kfac(i,-24)=1
16141  ELSE
16142  DO 130 j=-25,25
16143  kfac(i,j)=kfin(i,j)
16144  IF(iabs(j).GT.mstp(58).AND.iabs(j).LE.10) kfac(i,j)=0
16145  IF(xsfx(i,j).LT.1d-10) kfac(i,j)=0
16146  130 CONTINUE
16147  ENDIF
16148  140 CONTINUE
16149 
16150 C...Lower and upper limit for fermion flavour loops
16151  mmin1=0
16152  mmax1=0
16153  mmin2=0
16154  mmax2=0
16155  DO 150 j=-20,20
16156  IF(kfac(1,-j).EQ.1) mmin1=-j
16157  IF(kfac(1,j).EQ.1) mmax1=j
16158  IF(kfac(2,-j).EQ.1) mmin2=-j
16159  IF(kfac(2,j).EQ.1) mmax2=j
16160  150 CONTINUE
16161  mmina=min(mmin1,mmin2)
16162  mmaxa=max(mmax1,mmax2)
16163 
16164 C...Common resonance mass and width combinations
16165  sqmz=pmas(23,1)**2
16166  sqmw=pmas(24,1)**2
16167  sqmh=pmas(kfhigg,1)**2
16168  gmmz=pmas(23,1)*pmas(23,2)
16169  gmmw=pmas(24,1)*pmas(24,2)
16170  gmmh=pmas(kfhigg,1)*pmas(kfhigg,2)
16171 C...MRENNA+++
16172  zwid=pmas(23,2)
16173  wwid=pmas(24,2)
16174 C...MRENNA---
16175 
16176 C...Phase space integral in tau
16177  comfac=paru(1)*paru(5)/vint(2)
16178  IF(mint(41).EQ.2.AND.mint(42).EQ.2) comfac=comfac*fack
16179  IF((mint(47).GE.2.OR.(istsb.GE.3.AND.istsb.LE.5)).AND.
16180  &istsb.NE.9) THEN
16181  atau1=log(taumax/taumin)
16182  atau2=(taumax-taumin)/(taumax*taumin)
16183  h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/tau
16184  IF(mint(72).GE.1) THEN
16185  taur1=vint(73)
16186  gamr1=vint(74)
16187  ataud=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))
16188  atau3=ataud/taur1
16189  IF(ataud.GT.1d-6) h1=h1+
16190  & (atau1/atau3)*coef(isubsv,3)/(tau+taur1)
16191  ataud=atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1)
16192  atau4=ataud/gamr1
16193  IF(ataud.GT.1d-6) h1=h1+
16194  & (atau1/atau4)*coef(isubsv,4)*tau/((tau-taur1)**2+gamr1**2)
16195  ENDIF
16196  IF(mint(72).EQ.2) THEN
16197  taur2=vint(75)
16198  gamr2=vint(76)
16199  ataud=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))
16200  atau5=ataud/taur2
16201  IF(ataud.GT.1d-6) h1=h1+
16202  & (atau1/atau5)*coef(isubsv,5)/(tau+taur2)
16203  ataud=atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2)
16204  atau6=ataud/gamr2
16205  IF(ataud.GT.1d-6) h1=h1+
16206  & (atau1/atau6)*coef(isubsv,6)*tau/((tau-taur2)**2+gamr2**2)
16207  ENDIF
16208  IF(mint(47).EQ.5.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
16209  atau7=log(max(2d-6,1d0-taumin)/max(2d-6,1d0-taumax))
16210  IF(atau7.GT.1d-6) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
16211  & max(2d-6,1d0-tau)
16212  ENDIF
16213  comfac=comfac*atau1/(tau*h1)
16214  ENDIF
16215 
16216 C...Phase space integral in y*
16217  IF(mint(47).GE.4.AND.istsb.NE.9) THEN
16218  ayst0=ystmax-ystmin
16219  IF(ayst0.LT.1d-6) THEN
16220  comfac=0d0
16221  ELSE
16222  ayst1=0.5d0*(ystmax-ystmin)**2
16223  ayst2=ayst1
16224  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
16225  h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
16226  & (ayst0/ayst2)*coef(isubsv,9)*(ystmax-yst)+
16227  & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
16228  IF(mint(45).EQ.3) THEN
16229  yst0=-0.5d0*log(taue)
16230  ayst4=log(max(1d-6,exp(yst0-ystmin)-1d0)/
16231  & max(1d-6,exp(yst0-ystmax)-1d0))
16232  IF(ayst4.GT.1d-6) h2=h2+(ayst0/ayst4)*coef(isubsv,11)/
16233  & max(1d-6,1d0-exp(yst-yst0))
16234  ENDIF
16235  IF(mint(46).EQ.3) THEN
16236  yst0=-0.5d0*log(taue)
16237  ayst5=log(max(1d-6,exp(yst0+ystmax)-1d0)/
16238  & max(1d-6,exp(yst0+ystmin)-1d0))
16239  IF(ayst5.GT.1d-6) h2=h2+(ayst0/ayst5)*coef(isubsv,12)/
16240  & max(1d-6,1d0-exp(-yst-yst0))
16241  ENDIF
16242  comfac=comfac*ayst0/h2
16243  ENDIF
16244  ENDIF
16245 
16246 C...2 -> 1 processes: reduction in angular part of phase space integral
16247 C...for case of decaying resonance
16248  acth0=ctnmax-ctnmin+ctpmax-ctpmin
16249  IF((istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5)) THEN
16250  IF(mdcy(pycomp(kfpr(isubsv,1)),1).EQ.1) THEN
16251  IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37.OR.
16252  & kfpr(isub,1).EQ.39) THEN
16253  comfac=comfac*0.5d0*acth0
16254  ELSE
16255  comfac=comfac*0.125d0*(3d0*acth0+ctnmax**3-ctnmin**3+
16256  & ctpmax**3-ctpmin**3)
16257  ENDIF
16258  ENDIF
16259 
16260 C...2 -> 2 processes: angular part of phase space integral
16261  ELSEIF(istsb.EQ.2.OR.istsb.EQ.4) THEN
16262  acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/
16263  & (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))
16264  acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/
16265  & (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))
16266  acth3=1d0/max(rm34,rsqm-ctnmax)-1d0/max(rm34,rsqm-ctnmin)+
16267  & 1d0/max(rm34,rsqm-ctpmax)-1d0/max(rm34,rsqm-ctpmin)
16268  acth4=1d0/max(rm34,rsqm+ctnmin)-1d0/max(rm34,rsqm+ctnmax)+
16269  & 1d0/max(rm34,rsqm+ctpmin)-1d0/max(rm34,rsqm+ctpmax)
16270  h3=coef(isubsv,13)+
16271  & (acth0/acth1)*coef(isubsv,14)/max(rm34,rsqm-cth)+
16272  & (acth0/acth2)*coef(isubsv,15)/max(rm34,rsqm+cth)+
16273  & (acth0/acth3)*coef(isubsv,16)/max(rm34,rsqm-cth)**2+
16274  & (acth0/acth4)*coef(isubsv,17)/max(rm34,rsqm+cth)**2
16275  comfac=comfac*acth0*0.5d0*be34/h3
16276 
16277 C...2 -> 2 processes: take into account final state Breit-Wigners
16278  comfac=comfac*vint(80)
16279  ENDIF
16280 
16281 C...2 -> 3, 4 processes: phace space integral in tau'
16282  IF(mint(47).GE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN
16283  ataup1=log(taupmx/taupmn)
16284  ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
16285  h4=coef(isubsv,18)+
16286  & (ataup1/ataup2)*coef(isubsv,19)*(1d0-tau/taup)**3/taup
16287  IF(mint(47).EQ.5) THEN
16288  ataup3=log(max(2d-6,1d0-taupmn)/max(2d-6,1d0-taupmx))
16289  h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(2d-6,1d0-taup)
16290  ENDIF
16291  comfac=comfac*ataup1/h4
16292  ENDIF
16293 
16294 C...2 -> 3, 4 processes: effective W/Z parton distributions
16295  IF(istsb.EQ.3.OR.istsb.EQ.4) THEN
16296  IF(1d0-tau/taup.GT.1.d-4) THEN
16297  fzw=(1d0+tau/taup)*log(taup/tau)-2d0*(1d0-tau/taup)
16298  ELSE
16299  fzw=1d0/6d0*(1d0-tau/taup)**3*tau/taup
16300  ENDIF
16301  comfac=comfac*fzw
16302  ENDIF
16303 
16304 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
16305  IF(istsb.EQ.5) THEN
16306  comfac=comfac*vint(205)*vint(210)*vint(212)*vint(214)/
16307  & (128d0*paru(1)**4*vint(220))*(tau**2/taup)
16308  ENDIF
16309 
16310 C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
16311  IF(mstp(85).EQ.1.AND.mod(istsb,2).EQ.0) comfac=comfac*
16312  &sqpth**2/(parp(82)**2+sqpth)**2
16313 
16314 C...gamma + gamma: include factor 2 when different nature
16315  IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4)
16316  &comfac=2d0*comfac
16317 
16318 C...Phase space integral for low-pT and multiple interactions
16319  IF(istsb.EQ.9) THEN
16320  comfac=paru(1)*paru(5)*fack*0.5d0*vint(2)/sh2
16321  atau1=log(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)
16322  atau2=2d0*atan(1d0/xt2-1d0)/sqrt(xt2)
16323  h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/sqrt(tau)
16324  comfac=comfac*atau1/h1
16325  ayst0=ystmax-ystmin
16326  ayst1=0.5d0*(ystmax-ystmin)**2
16327  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
16328  h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
16329  & (ayst0/ayst1)*coef(isubsv,9)*(ystmax-yst)+
16330  & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
16331  comfac=comfac*ayst0/h2
16332  IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1d0/vint(149)-1d0)
16333 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16334 C...introduced to make cross-section finite for xT2 -> 0
16335  IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*
16336  & (1d0+vint(149)))
16337  ENDIF
16338 
16339 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
16340  IF((mstp(46).GE.3.AND.mstp(46).LE.6).AND.(isub.EQ.71.OR.isub.EQ.
16341  &72.OR.isub.EQ.73.OR.isub.EQ.76.OR.isub.EQ.77)) THEN
16342 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
16343  IF(mstp(46).LE.4) THEN
16344  hdtlh=log(pmas(25,1)/parp(44))
16345  hdtmr=(4.5d0*paru(1)/sqrt(3d0)-74d0/9d0)/8d0+hdtlh/12d0
16346  hdtnr=-1d0/18d0+hdtlh/6d0
16347  ELSE
16348  hdtnm=0.125d0*(1d0/(288d0*paru(1)**2)+(parp(47)/parp(45))**2)
16349  hdtlq=log(parp(45)/parp(44))
16350  hdtmr=-(4d0*paru(1))**2*0.5d0*hdtnm+hdtlq/12d0
16351  hdtnr=(4d0*paru(1))**2*hdtnm+hdtlq/6d0
16352  ENDIF
16353 
16354 C...Calculate lowest and next-to-lowest order partial wave amplitudes
16355  hdtv=1d0/(16d0*paru(1)*parp(47)**2)
16356  a00l=sngl(hdtv*sh)
16357  a20l=-0.5*a00l
16358  a11l=a00l/6.
16359  hdtls=log(sh/parp(44)**2)
16360  a004=sngl((hdtv*sh)**2/(4d0*paru(1)))*
16361  & cmplx(sngl((176d0*hdtmr+112d0*hdtnr)/3d0+11d0/27d0-
16362  & (50d0/9d0)*hdtls),sngl(4d0*paru(1)))
16363  a204=sngl((hdtv*sh)**2/(4d0*paru(1)))*
16364  & cmplx(sngl(32d0*(hdtmr+2d0*hdtnr)/3d0+25d0/54d0-
16365  & (20d0/9d0)*hdtls),sngl(paru(1)))
16366  a114=sngl((hdtv*sh)**2/(6d0*paru(1)))*
16367  & cmplx(sngl(4d0*(-2d0*hdtmr+hdtnr)-1d0/18d0),sngl(paru(1)/6d0))
16368 
16369 C...Unitarize partial wave amplitudes with Pade or K-matrix method
16370  IF(mstp(46).EQ.3.OR.mstp(46).EQ.5) THEN
16371  a00u=a00l/(1.-a004/a00l)
16372  a20u=a20l/(1.-a204/a20l)
16373  a11u=a11l/(1.-a114/a11l)
16374  ELSE
16375  a00u=(a00l+REAL(a004))/(1.-cmplx(0.,a00l+REAL(a004)))
16376  a20u=(a20l+REAL(a204))/(1.-cmplx(0.,a20l+REAL(a204)))
16377  a11u=(a11l+REAL(a114))/(1.-cmplx(0.,a11l+REAL(a114)))
16378  ENDIF
16379  ENDIF
16380 
16381 C...Supersymmetric processes - all of type 2 -> 2 :
16382 C...correct final-state Breit-Wigners from fixed to running width.
16383  IF(isub.GE.200.AND.isub.LE.280.AND.mstp(42).GT.0) THEN
16384  DO 160 i=1,2
16385  kflw=kfpr(isubsv,i)
16386  kcw=pycomp(kflw)
16387  IF(pmas(kcw,2).LT.parp(41)) goto 160
16388  IF(i.EQ.1) sqmi=sqm3
16389  IF(i.EQ.2) sqmi=sqm4
16390  sqms=pmas(kcw,1)**2
16391  gmms=pmas(kcw,1)*pmas(kcw,2)
16392  hbws=gmms/((sqmi-sqms)**2+gmms**2)
16393  CALL pywidt(kflw,sqmi,wdtp,wdte)
16394  gmmi=sqrt(sqmi)*wdtp(0)
16395  hbwi=gmmi/((sqmi-sqms)**2+gmmi**2)
16396  comfac=comfac*(hbwi/hbws)
16397  160 CONTINUE
16398  ENDIF
16399 
16400 C...A: 2 -> 1, tree diagrams
16401 
16402  170 IF(isub.LE.10) THEN
16403  IF(isub.EQ.1) THEN
16404 C...f + fbar -> gamma*/Z0
16405  mint(61)=2
16406  CALL pywidt(23,sh,wdtp,wdte)
16407  hs=shr*wdtp(0)
16408  facz=4d0*comfac*3d0
16409  hp0=aem/3d0*sh
16410  hp1=aem/3d0*xwc*sh
16411  DO 180 i=mmina,mmaxa
16412  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 180
16413  ei=kchg(iabs(i),1)/3d0
16414  ai=sign(1d0,ei)
16415  vi=ai-4d0*ei*xwv
16416  hi0=hp0
16417  IF(iabs(i).LE.10) hi0=hi0*faca/3d0
16418  hi1=hp1
16419  IF(iabs(i).LE.10) hi1=hi1*faca/3d0
16420  nchn=nchn+1
16421  isig(nchn,1)=i
16422  isig(nchn,2)=-i
16423  isig(nchn,3)=1
16424  sigh(nchn)=facz*(ei**2/sh2*hi0*hp0*vint(111)+
16425  & ei*vi*(1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*
16426  & (hi0*hp1+hi1*hp0)*vint(112)+(vi**2+ai**2)/
16427  & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114))
16428  180 CONTINUE
16429 
16430  ELSEIF(isub.EQ.2) THEN
16431 C...f + fbar' -> W+/-
16432  CALL pywidt(24,sh,wdtp,wdte)
16433  hs=shr*wdtp(0)
16434  facbw=4d0*comfac/((sh-sqmw)**2+hs**2)*3d0
16435  hp=aem/(24d0*xw)*sh
16436  DO 200 i=mmin1,mmax1
16437  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 200
16438  ia=iabs(i)
16439  DO 190 j=mmin2,mmax2
16440  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 190
16441  ja=iabs(j)
16442  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 190
16443  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
16444  & goto 190
16445  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16446  hi=hp*2d0
16447  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
16448  nchn=nchn+1
16449  isig(nchn,1)=i
16450  isig(nchn,2)=j
16451  isig(nchn,3)=1
16452  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
16453  sigh(nchn)=hi*facbw*hf
16454  190 CONTINUE
16455  200 CONTINUE
16456 
16457  ELSEIF(isub.EQ.3) THEN
16458 C...f + fbar -> h0 (or H0, or A0)
16459  CALL pywidt(kfhigg,sh,wdtp,wdte)
16460  hs=shr*wdtp(0)
16461  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
16462  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
16463  & facbw=0d0
16464  hp=aem/(8d0*xw)*sh/sqmw*sh
16465  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
16466  DO 210 i=mmina,mmaxa
16467  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 210
16468  ia=iabs(i)
16469  rmq=pmas(ia,1)**2/sh
16470  hi=hp*rmq
16471  IF(ia.LE.10) hi=hp*rmq*faca/3d0
16472  IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) hi=hi*
16473  & (log(max(4d0,parp(37)**2*rmq*sh/paru(117)**2))/
16474  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
16475  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
16476  ikfi=1
16477  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
16478  IF(ia.GT.10) ikfi=3
16479  hi=hi*paru(150+10*ihigg+ikfi)**2
16480  ENDIF
16481  nchn=nchn+1
16482  isig(nchn,1)=i
16483  isig(nchn,2)=-i
16484  isig(nchn,3)=1
16485  sigh(nchn)=hi*facbw*hf
16486  210 CONTINUE
16487 
16488  ELSEIF(isub.EQ.4) THEN
16489 C...gamma + W+/- -> W+/-
16490 
16491  ELSEIF(isub.EQ.5) THEN
16492 C...Z0 + Z0 -> h0
16493  CALL pywidt(25,sh,wdtp,wdte)
16494  hs=shr*wdtp(0)
16495  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
16496  IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
16497  hp=aem/(8d0*xw)*sh/sqmw*sh
16498  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
16499  hi=hp/4d0
16500  faci=8d0/(paru(1)**2*xw1)*(aem*xwc)**2
16501  DO 230 i=mmin1,mmax1
16502  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 230
16503  DO 220 j=mmin2,mmax2
16504  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 220
16505  ei=kchg(iabs(i),1)/3d0
16506  ai=sign(1d0,ei)
16507  vi=ai-4d0*ei*xwv
16508  ej=kchg(iabs(j),1)/3d0
16509  aj=sign(1d0,ej)
16510  vj=aj-4d0*ej*xwv
16511  nchn=nchn+1
16512  isig(nchn,1)=i
16513  isig(nchn,2)=j
16514  isig(nchn,3)=1
16515  sigh(nchn)=faci*(vi**2+ai**2)*(vj**2+aj**2)*hi*facbw*hf
16516  220 CONTINUE
16517  230 CONTINUE
16518 
16519  ELSEIF(isub.EQ.6) THEN
16520 C...Z0 + W+/- -> W+/-
16521 
16522  ELSEIF(isub.EQ.7) THEN
16523 C...W+ + W- -> Z0
16524 
16525  ELSEIF(isub.EQ.8) THEN
16526 C...W+ + W- -> h0
16527  CALL pywidt(25,sh,wdtp,wdte)
16528  hs=shr*wdtp(0)
16529  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
16530  IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
16531  hp=aem/(8d0*xw)*sh/sqmw*sh
16532  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
16533  hi=hp/2d0
16534  faci=1d0/(4d0*paru(1)**2)*(aem/xw)**2
16535  DO 250 i=mmin1,mmax1
16536  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 250
16537  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
16538  DO 240 j=mmin2,mmax2
16539  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 240
16540  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
16541  IF(ei*ej.GT.0d0) goto 240
16542  nchn=nchn+1
16543  isig(nchn,1)=i
16544  isig(nchn,2)=j
16545  isig(nchn,3)=1
16546  sigh(nchn)=faci*vint(180+i)*vint(180+j)*hi*facbw*hf
16547  240 CONTINUE
16548  250 CONTINUE
16549 
16550 C...B: 2 -> 2, tree diagrams
16551 
16552  ELSEIF(isub.EQ.10) THEN
16553 C...f + f' -> f + f' (gamma/Z/W exchange)
16554  facggf=comfac*aem**2*2d0*(sh2+uh2)/th2
16555  facgzf=comfac*aem**2*xwc*4d0*sh2/(th*(th-sqmz))
16556  faczzf=comfac*(aem*xwc)**2*2d0*sh2/(th-sqmz)**2
16557  facwwf=comfac*(0.5d0*aem/xw)**2*sh2/(th-sqmw)**2
16558  DO 270 i=mmin1,mmax1
16559  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 270
16560  ia=iabs(i)
16561  DO 260 j=mmin2,mmax2
16562  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 260
16563  ja=iabs(j)
16564 C...Electroweak couplings
16565  ei=kchg(ia,1)*isign(1,i)/3d0
16566  ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
16567  vi=ai-4d0*ei*xwv
16568  ej=kchg(ja,1)*isign(1,j)/3d0
16569  aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
16570  vj=aj-4d0*ej*xwv
16571  epsij=isign(1,i*j)
16572 C...gamma/Z exchange, only gamma exchange, or only Z exchange
16573  IF(mstp(21).GE.1.AND.mstp(21).LE.4) THEN
16574  IF(mstp(21).EQ.1.OR.mstp(21).EQ.4) THEN
16575  facncf=facggf*ei**2*ej**2+facgzf*ei*ej*
16576  & (vi*vj*(1d0+uh2/sh2)+ai*aj*epsij*(1d0-uh2/sh2))+
16577  & faczzf*((vi**2+ai**2)*(vj**2+aj**2)*(1d0+uh2/sh2)+
16578  & 4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
16579  ELSEIF(mstp(21).EQ.2) THEN
16580  facncf=facggf*ei**2*ej**2
16581  ELSE
16582  facncf=faczzf*((vi**2+ai**2)*(vj**2+aj**2)*
16583  & (1d0+uh2/sh2)+4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
16584  ENDIF
16585  nchn=nchn+1
16586  isig(nchn,1)=i
16587  isig(nchn,2)=j
16588  isig(nchn,3)=1
16589  sigh(nchn)=facncf
16590  ENDIF
16591 C...W exchange
16592  IF((mstp(21).EQ.1.OR.mstp(21).EQ.5).AND.ai*aj.LT.0d0) THEN
16593  facccf=facwwf*vint(180+i)*vint(180+j)
16594  IF(epsij.LT.0d0) facccf=facccf*uh2/sh2
16595  IF(ia.GT.10.AND.mod(ia,2).EQ.0) facccf=2d0*facccf
16596  IF(ja.GT.10.AND.mod(ja,2).EQ.0) facccf=2d0*facccf
16597  nchn=nchn+1
16598  isig(nchn,1)=i
16599  isig(nchn,2)=j
16600  isig(nchn,3)=2
16601  sigh(nchn)=facccf
16602  ENDIF
16603  260 CONTINUE
16604  270 CONTINUE
16605  ENDIF
16606 
16607  ELSEIF(isub.LE.20) THEN
16608  IF(isub.EQ.11) THEN
16609 C...f + f' -> f + f' (g exchange)
16610  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
16611  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
16612  & mstp(34)*2d0/3d0*uh2/(sh*th))
16613  facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-
16614  & mstp(34)*2d0/3d0*sh2/(th*uh))
16615  IF(mstp(5).GE.1) THEN
16616 C...Modifications from contact interactions (compositeness)
16617  facci1=facqq1+comfac*(sh2/paru(155)**4)
16618  faccib=facqqb+comfac*(8d0/9d0)*(as*paru(156)/paru(155)**2)*
16619  & (uh2/th+uh2/sh)+comfac*(5d0/3d0)*(uh2/paru(155)**4)
16620  facci2=facqq2+comfac*(8d0/9d0)*(as*paru(156)/paru(155)**2)*
16621  & (sh2/th+sh2/uh)+comfac*(5d0/3d0)*(sh2/paru(155)**4)
16622  facci3=facqq1+comfac*(uh2/paru(155)**4)
16623  ENDIF
16624  DO 290 i=mmin1,mmax1
16625  ia=iabs(i)
16626  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 290
16627  DO 280 j=mmin2,mmax2
16628  ja=iabs(j)
16629  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 280
16630  nchn=nchn+1
16631  isig(nchn,1)=i
16632  isig(nchn,2)=j
16633  isig(nchn,3)=1
16634  IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.(ia.GE.3.OR.
16635  & ja.GE.3))) THEN
16636  sigh(nchn)=facqq1
16637  IF(i.EQ.-j) sigh(nchn)=facqqb
16638  ELSE
16639  sigh(nchn)=facci1
16640  IF(i*j.LT.0) sigh(nchn)=facci3
16641  IF(i.EQ.-j) sigh(nchn)=faccib
16642  ENDIF
16643  IF(i.EQ.j) THEN
16644  sigh(nchn)=0.5d0*sigh(nchn)
16645  nchn=nchn+1
16646  isig(nchn,1)=i
16647  isig(nchn,2)=j
16648  isig(nchn,3)=2
16649  IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.ia.GE.3)) THEN
16650  sigh(nchn)=0.5d0*facqq2
16651  ELSE
16652  sigh(nchn)=0.5d0*facci2
16653  ENDIF
16654  ENDIF
16655  280 CONTINUE
16656  290 CONTINUE
16657 
16658  ELSEIF(isub.EQ.12) THEN
16659 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
16660  CALL pywidt(21,sh,wdtp,wdte)
16661  facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
16662  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
16663  IF(mstp(5).EQ.1) THEN
16664 C...Modifications from contact interactions (compositeness)
16665  faccib=facqqb
16666  DO 300 i=1,2
16667  faccib=faccib+comfac*(uh2/paru(155)**4)*(wdte(i,1)+
16668  & wdte(i,2)+wdte(i,4))
16669  300 CONTINUE
16670  ELSEIF(mstp(5).GE.2) THEN
16671  faccib=facqqb+comfac*(uh2/paru(155)**4)*
16672  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
16673  ENDIF
16674  DO 310 i=mmina,mmaxa
16675  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
16676  & kfac(1,i)*kfac(2,-i).EQ.0) goto 310
16677  nchn=nchn+1
16678  isig(nchn,1)=i
16679  isig(nchn,2)=-i
16680  isig(nchn,3)=1
16681  IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.iabs(i).GE.3)) THEN
16682  sigh(nchn)=facqqb
16683  ELSE
16684  sigh(nchn)=faccib
16685  ENDIF
16686  310 CONTINUE
16687 
16688  ELSEIF(isub.EQ.13) THEN
16689 C...f + fbar -> g + g (q + qbar -> g + g only)
16690  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
16691  & uh2/sh2)
16692  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
16693  & th2/sh2)
16694  DO 320 i=mmina,mmaxa
16695  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
16696  & kfac(1,i)*kfac(2,-i).EQ.0) goto 320
16697  nchn=nchn+1
16698  isig(nchn,1)=i
16699  isig(nchn,2)=-i
16700  isig(nchn,3)=1
16701  sigh(nchn)=0.5d0*facgg1
16702  nchn=nchn+1
16703  isig(nchn,1)=i
16704  isig(nchn,2)=-i
16705  isig(nchn,3)=2
16706  sigh(nchn)=0.5d0*facgg2
16707  320 CONTINUE
16708 
16709  ELSEIF(isub.EQ.14) THEN
16710 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
16711  facgg=comfac*as*aem*8d0/9d0*(th2+uh2)/(th*uh)
16712  DO 330 i=mmina,mmaxa
16713  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
16714  & kfac(1,i)*kfac(2,-i).EQ.0) goto 330
16715  ei=kchg(iabs(i),1)/3d0
16716  nchn=nchn+1
16717  isig(nchn,1)=i
16718  isig(nchn,2)=-i
16719  isig(nchn,3)=1
16720  sigh(nchn)=facgg*ei**2
16721  330 CONTINUE
16722 
16723  ELSEIF(isub.EQ.15) THEN
16724 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
16725  faczg=comfac*as*aem*(8d0/9d0)*(th2+uh2+2d0*sqm4*sh)/(th*uh)
16726 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16727  hfgg=0d0
16728  hfgz=0d0
16729  hfzz=0d0
16730  radc4=1d0+pyalps(sqm4)/paru(1)
16731  DO 340 i=1,min(16,mdcy(23,3))
16732  idc=i+mdcy(23,2)-1
16733  IF(mdme(idc,1).LT.0) goto 340
16734  imdm=0
16735  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
16736  & imdm=1
16737  IF(i.LE.8) THEN
16738  ef=kchg(i,1)/3d0
16739  af=sign(1d0,ef+0.1d0)
16740  vf=af-4d0*ef*xwv
16741  ELSEIF(i.LE.16) THEN
16742  ef=kchg(i+2,1)/3d0
16743  af=sign(1d0,ef+0.1d0)
16744  vf=af-4d0*ef*xwv
16745  ENDIF
16746  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
16747  IF(4d0*rm1.LT.1d0) THEN
16748  fcof=1d0
16749  IF(i.LE.8) fcof=3d0*radc4
16750  be34=sqrt(max(0d0,1d0-4d0*rm1))
16751  IF(imdm.EQ.1) THEN
16752  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
16753  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
16754  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
16755  & af**2*(1d0-4d0*rm1))*be34
16756  ENDIF
16757  ENDIF
16758  340 CONTINUE
16759 C...Propagators: as simulated in PYOFSH and as desired
16760  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
16761  mint(15)=1
16762  mint(61)=1
16763  CALL pywidt(23,sqm4,wdtp,wdte)
16764  hfaem=(paru(108)/paru(2))*(2d0/3d0)
16765  hfgg=hfgg*hfaem*vint(111)/sqm4
16766  hfgz=hfgz*hfaem*vint(112)/sqm4
16767  hfzz=hfzz*hfaem*vint(114)/sqm4
16768 C...Loop over flavours; consider full gamma/Z structure
16769  DO 350 i=mmina,mmaxa
16770  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
16771  & kfac(1,i)*kfac(2,-i).EQ.0) goto 350
16772  ei=kchg(iabs(i),1)/3d0
16773  ai=sign(1d0,ei)
16774  vi=ai-4d0*ei*xwv
16775  nchn=nchn+1
16776  isig(nchn,1)=i
16777  isig(nchn,2)=-i
16778  isig(nchn,3)=1
16779  sigh(nchn)=faczg*(ei**2*hfgg+ei*vi*hfgz+
16780  & (vi**2+ai**2)*hfzz)/hbw4
16781  350 CONTINUE
16782 
16783  ELSEIF(isub.EQ.16) THEN
16784 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
16785  facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)
16786 C...Propagators: as simulated in PYOFSH and as desired
16787  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
16788  CALL pywidt(24,sqm4,wdtp,wdte)
16789  gmmwc=sqrt(sqm4)*wdtp(0)
16790  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
16791  facwg=facwg*hbw4c/hbw4
16792  DO 370 i=mmin1,mmax1
16793  ia=iabs(i)
16794  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 370
16795  DO 360 j=mmin2,mmax2
16796  ja=iabs(j)
16797  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 360
16798  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 360
16799  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16800  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
16801  fckm=vckm((ia+1)/2,(ja+1)/2)
16802  nchn=nchn+1
16803  isig(nchn,1)=i
16804  isig(nchn,2)=j
16805  isig(nchn,3)=1
16806  sigh(nchn)=facwg*fckm*widsc
16807  360 CONTINUE
16808  370 CONTINUE
16809 
16810  ELSEIF(isub.EQ.17) THEN
16811 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
16812 
16813  ELSEIF(isub.EQ.18) THEN
16814 C...f + fbar -> gamma + gamma
16815  facgg=comfac*aem**2*2d0*(th2+uh2)/(th*uh)
16816  DO 380 i=mmina,mmaxa
16817  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 380
16818  ei=kchg(iabs(i),1)/3d0
16819  fcoi=1d0
16820  IF(iabs(i).LE.10) fcoi=faca/3d0
16821  nchn=nchn+1
16822  isig(nchn,1)=i
16823  isig(nchn,2)=-i
16824  isig(nchn,3)=1
16825  sigh(nchn)=0.5d0*facgg*fcoi*ei**4
16826  380 CONTINUE
16827 
16828  ELSEIF(isub.EQ.19) THEN
16829 C...f + fbar -> gamma + (gamma*/Z0)
16830  facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)
16831 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16832  hfgg=0d0
16833  hfgz=0d0
16834  hfzz=0d0
16835  radc4=1d0+pyalps(sqm4)/paru(1)
16836  DO 390 i=1,min(16,mdcy(23,3))
16837  idc=i+mdcy(23,2)-1
16838  IF(mdme(idc,1).LT.0) goto 390
16839  imdm=0
16840  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
16841  & imdm=1
16842  IF(i.LE.8) THEN
16843  ef=kchg(i,1)/3d0
16844  af=sign(1d0,ef+0.1d0)
16845  vf=af-4d0*ef*xwv
16846  ELSEIF(i.LE.16) THEN
16847  ef=kchg(i+2,1)/3d0
16848  af=sign(1d0,ef+0.1d0)
16849  vf=af-4d0*ef*xwv
16850  ENDIF
16851  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
16852  IF(4d0*rm1.LT.1d0) THEN
16853  fcof=1d0
16854  IF(i.LE.8) fcof=3d0*radc4
16855  be34=sqrt(max(0d0,1d0-4d0*rm1))
16856  IF(imdm.EQ.1) THEN
16857  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
16858  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
16859  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
16860  & af**2*(1d0-4d0*rm1))*be34
16861  ENDIF
16862  ENDIF
16863  390 CONTINUE
16864 C...Propagators: as simulated in PYOFSH and as desired
16865  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
16866  mint(15)=1
16867  mint(61)=1
16868  CALL pywidt(23,sqm4,wdtp,wdte)
16869  hfaem=(paru(108)/paru(2))*(2d0/3d0)
16870  hfgg=hfgg*hfaem*vint(111)/sqm4
16871  hfgz=hfgz*hfaem*vint(112)/sqm4
16872  hfzz=hfzz*hfaem*vint(114)/sqm4
16873 C...Loop over flavours; consider full gamma/Z structure
16874  DO 400 i=mmina,mmaxa
16875  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 400
16876  ei=kchg(iabs(i),1)/3d0
16877  ai=sign(1d0,ei)
16878  vi=ai-4d0*ei*xwv
16879  fcoi=1d0
16880  IF(iabs(i).LE.10) fcoi=faca/3d0
16881  nchn=nchn+1
16882  isig(nchn,1)=i
16883  isig(nchn,2)=-i
16884  isig(nchn,3)=1
16885  sigh(nchn)=facgz*fcoi*ei**2*(ei**2*hfgg+ei*vi*hfgz+
16886  & (vi**2+ai**2)*hfzz)/hbw4
16887  400 CONTINUE
16888 
16889  ELSEIF(isub.EQ.20) THEN
16890 C...f + fbar' -> gamma + W+/-
16891  facgw=comfac*0.5d0*aem**2/xw
16892 C...Propagators: as simulated in PYOFSH and as desired
16893  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
16894  CALL pywidt(24,sqm4,wdtp,wdte)
16895  gmmwc=sqrt(sqm4)*wdtp(0)
16896  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
16897  facgw=facgw*hbw4c/hbw4
16898 C...Anomalous couplings
16899  term1=(th2+uh2+2d0*sqm4*sh)/(th*uh)
16900  term2=0d0
16901  term3=0d0
16902  IF(mstp(5).GE.1) THEN
16903  term2=paru(153)*(th-uh)/(th+uh)
16904  term3=0.5d0*paru(153)**2*(th*uh+(th2+uh2)*sh/
16905  & (4d0*sqmw))/(th+uh)**2
16906  ENDIF
16907  DO 420 i=mmin1,mmax1
16908  ia=iabs(i)
16909  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 420
16910  DO 410 j=mmin2,mmax2
16911  ja=iabs(j)
16912  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 410
16913  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 410
16914  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
16915  & goto 410
16916  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
16917  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
16918  IF(ia.LE.10) THEN
16919  facwr=uh/(th+uh)-1d0/3d0
16920  fckm=vckm((ia+1)/2,(ja+1)/2)
16921  fcoi=faca/3d0
16922  ELSE
16923  facwr=-th/(th+uh)
16924  fckm=1d0
16925  fcoi=1d0
16926  ENDIF
16927  facwk=term1*facwr**2+term2*facwr+term3
16928  nchn=nchn+1
16929  isig(nchn,1)=i
16930  isig(nchn,2)=j
16931  isig(nchn,3)=1
16932  sigh(nchn)=facgw*facwk*fcoi*fckm*widsc
16933  410 CONTINUE
16934  420 CONTINUE
16935  ENDIF
16936 
16937  ELSEIF(isub.LE.30) THEN
16938  IF(isub.EQ.21) THEN
16939 C...f + fbar -> gamma + h0
16940 
16941  ELSEIF(isub.EQ.22) THEN
16942 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
16943 C...Kinematics dependence
16944  faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-
16945  & sqm3*sqm4*(1d0/th2+1d0/uh2))
16946 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16947  DO 440 i=1,6
16948  DO 430 j=1,3
16949  hgz(i,j)=0d0
16950  430 CONTINUE
16951  440 CONTINUE
16952  radc3=1d0+pyalps(sqm3)/paru(1)
16953  radc4=1d0+pyalps(sqm4)/paru(1)
16954  DO 450 i=1,min(16,mdcy(23,3))
16955  idc=i+mdcy(23,2)-1
16956  IF(mdme(idc,1).LT.0) goto 450
16957  imdm=0
16958  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2) imdm=1
16959  IF(mdme(idc,1).EQ.4.OR.mdme(idc,1).EQ.5) imdm=mdme(idc,1)-2
16960  IF(i.LE.8) THEN
16961  ef=kchg(i,1)/3d0
16962  af=sign(1d0,ef+0.1d0)
16963  vf=af-4d0*ef*xwv
16964  ELSEIF(i.LE.16) THEN
16965  ef=kchg(i+2,1)/3d0
16966  af=sign(1d0,ef+0.1d0)
16967  vf=af-4d0*ef*xwv
16968  ENDIF
16969  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm3
16970  IF(4d0*rm1.LT.1d0) THEN
16971  fcof=1d0
16972  IF(i.LE.8) fcof=3d0*radc3
16973  be34=sqrt(max(0d0,1d0-4d0*rm1))
16974  IF(imdm.GE.1) THEN
16975  hgz(1,imdm)=hgz(1,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
16976  hgz(2,imdm)=hgz(2,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
16977  hgz(3,imdm)=hgz(3,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
16978  & af**2*(1d0-4d0*rm1))*be34
16979  ENDIF
16980  ENDIF
16981  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
16982  IF(4d0*rm1.LT.1d0) THEN
16983  fcof=1d0
16984  IF(i.LE.8) fcof=3d0*radc4
16985  be34=sqrt(max(0d0,1d0-4d0*rm1))
16986  IF(imdm.GE.1) THEN
16987  hgz(4,imdm)=hgz(4,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
16988  hgz(5,imdm)=hgz(5,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
16989  hgz(6,imdm)=hgz(6,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
16990  & af**2*(1d0-4d0*rm1))*be34
16991  ENDIF
16992  ENDIF
16993  450 CONTINUE
16994 C...Propagators: as simulated in PYOFSH and as desired
16995  hbw3=(1d0/paru(1))*gmmz/((sqm3-sqmz)**2+gmmz**2)
16996  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
16997  mint(15)=1
16998  mint(61)=1
16999  CALL pywidt(23,sqm3,wdtp,wdte)
17000  hfaem=(paru(108)/paru(2))*(2d0/3d0)
17001  DO 460 j=1,3
17002  hgz(1,j)=hgz(1,j)*hfaem*vint(111)/sqm3
17003  hgz(2,j)=hgz(2,j)*hfaem*vint(112)/sqm3
17004  hgz(3,j)=hgz(3,j)*hfaem*vint(114)/sqm3
17005  460 CONTINUE
17006  mint(61)=1
17007  CALL pywidt(23,sqm4,wdtp,wdte)
17008  hfaem=(paru(108)/paru(2))*(2d0/3d0)
17009  DO 470 j=1,3
17010  hgz(4,j)=hgz(4,j)*hfaem*vint(111)/sqm4
17011  hgz(5,j)=hgz(5,j)*hfaem*vint(112)/sqm4
17012  hgz(6,j)=hgz(6,j)*hfaem*vint(114)/sqm4
17013  470 CONTINUE
17014 C...Loop over flavours; separate left- and right-handed couplings
17015  DO 490 i=mmina,mmaxa
17016  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 490
17017  ei=kchg(iabs(i),1)/3d0
17018  ai=sign(1d0,ei)
17019  vi=ai-4d0*ei*xwv
17020  vali=vi-ai
17021  vari=vi+ai
17022  fcoi=1d0
17023  IF(iabs(i).LE.10) fcoi=faca/3d0
17024  DO 480 j=1,3
17025  hl3(j)=ei**2*hgz(1,j)+ei*vali*hgz(2,j)+vali**2*hgz(3,j)
17026  hr3(j)=ei**2*hgz(1,j)+ei*vari*hgz(2,j)+vari**2*hgz(3,j)
17027  hl4(j)=ei**2*hgz(4,j)+ei*vali*hgz(5,j)+vali**2*hgz(6,j)
17028  hr4(j)=ei**2*hgz(4,j)+ei*vari*hgz(5,j)+vari**2*hgz(6,j)
17029  480 CONTINUE
17030  faclr=hl3(1)*hl4(1)+hl3(1)*(hl4(2)+hl4(3))+
17031  & hl4(1)*(hl3(2)+hl3(3))+hl3(2)*hl4(3)+hl4(2)*hl3(3)+
17032  & hr3(1)*hr4(1)+hr3(1)*(hr4(2)+hr4(3))+
17033  & hr4(1)*(hr3(2)+hr3(3))+hr3(2)*hr4(3)+hr4(2)*hr3(3)
17034  nchn=nchn+1
17035  isig(nchn,1)=i
17036  isig(nchn,2)=-i
17037  isig(nchn,3)=1
17038  sigh(nchn)=0.5d0*faczz*fcoi*faclr/(hbw3*hbw4)
17039  490 CONTINUE
17040 
17041  ELSEIF(isub.EQ.23) THEN
17042 C...f + fbar' -> Z0 + W+/-
17043  faczw=comfac*0.5d0*(aem/xw)**2
17044  faczw=faczw*wids(23,2)
17045  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
17046  facbw=1d0/((sh-sqmw)**2+gmmw**2)
17047  DO 510 i=mmin1,mmax1
17048  ia=iabs(i)
17049  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 510
17050  DO 500 j=mmin2,mmax2
17051  ja=iabs(j)
17052  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 500
17053  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 500
17054  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
17055  & goto 500
17056  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
17057  ei=kchg(ia,1)/3d0
17058  ai=sign(1d0,ei+0.1d0)
17059  vi=ai-4d0*ei*xwv
17060  ej=kchg(ja,1)/3d0
17061  aj=sign(1d0,ej+0.1d0)
17062  vj=aj-4d0*ej*xwv
17063  IF(vi+ai.GT.0) THEN
17064  visav=vi
17065  aisav=ai
17066  vi=vj
17067  ai=aj
17068  vj=visav
17069  aj=aisav
17070  ENDIF
17071  fckm=1d0
17072  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
17073  fcoi=1d0
17074  IF(ia.LE.10) fcoi=faca/3d0
17075  nchn=nchn+1
17076  isig(nchn,1)=i
17077  isig(nchn,2)=j
17078  isig(nchn,3)=1
17079  sigh(nchn)=faczw*fcoi*fckm*(facbw*((9d0-8d0*xw)/4d0*thuh+
17080  & (8d0*xw-6d0)/4d0*sh*(sqm3+sqm4))+(thuh-sh*(sqm3+sqm4))*
17081  & (sh-sqmw)*facbw*0.5d0*((vj+aj)/th-(vi+ai)/uh)+
17082  & thuh/(16d0*xw1)*((vj+aj)**2/th2+(vi+ai)**2/uh2)+
17083  & sh*(sqm3+sqm4)/(8d0*xw1)*(vi+ai)*(vj+aj)/(th*uh))*
17084  & wids(24,(5-kchw)/2)
17085  500 CONTINUE
17086  510 CONTINUE
17087 
17088  ELSEIF(isub.EQ.24) THEN
17089 C...f + fbar -> Z0 + h0 (or H0, or A0)
17090  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
17091  fachz=comfac*8d0*(aem*xwc)**2*
17092  & (thuh+2d0*sh*sqm3)/((sh-sqmz)**2+gmmz**2)
17093  fachz=fachz*wids(23,2)*wids(kfhigg,2)
17094  IF(mstp(4).GE.1.OR.ihigg.GE.2) fachz=fachz*
17095  & paru(154+10*ihigg)**2
17096  DO 520 i=mmina,mmaxa
17097  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 520
17098  ei=kchg(iabs(i),1)/3d0
17099  ai=sign(1d0,ei)
17100  vi=ai-4d0*ei*xwv
17101  fcoi=1d0
17102  IF(iabs(i).LE.10) fcoi=faca/3d0
17103  nchn=nchn+1
17104  isig(nchn,1)=i
17105  isig(nchn,2)=-i
17106  isig(nchn,3)=1
17107  sigh(nchn)=fachz*fcoi*(vi**2+ai**2)
17108  520 CONTINUE
17109 
17110  ELSEIF(isub.EQ.25) THEN
17111 C...f + fbar -> W+ + W-
17112 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
17113  CALL pywidt(23,sh,wdtp,wdte)
17114  gmmzc=shr*wdtp(0)
17115  hbwzc=sh**2/((sh-sqmz)**2+gmmzc**2)
17116  hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
17117  CALL pywidt(24,sqm3,wdtp,wdte)
17118  gmmw3=sqrt(sqm3)*wdtp(0)
17119  hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
17120  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
17121  CALL pywidt(24,sqm4,wdtp,wdte)
17122  gmmw4=sqrt(sqm4)*wdtp(0)
17123  hbw4c=gmmw4/((sqm4-sqmw)**2+gmmw4**2)
17124 C...Kinematical functions
17125  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
17126  thuh34=(2d0*sh*(sqm3+sqm4)+thuh)/(sqm3*sqm4)
17127  gs=(((sh-sqm3-sqm4)**2-4d0*sqm3*sqm4)*thuh34+12d0*thuh)/sh2
17128  gt=thuh34+4d0*thuh/th2
17129  gst=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/th)/sh
17130  gu=thuh34+4d0*thuh/uh2
17131  gsu=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/uh)/sh
17132 C...Common factors and couplings
17133  facww=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)
17134  facww=facww*wids(24,1)
17135  cgg=aem**2/2d0
17136  cgz=aem**2/(4d0*xw)*hbwzc*(1d0-sqmz/sh)
17137  czz=aem**2/(32d0*xw**2)*hbwzc
17138  cng=aem**2/(4d0*xw)
17139  cnz=aem**2/(16d0*xw**2)*hbwzc*(1d0-sqmz/sh)
17140  cnn=aem**2/(16d0*xw**2)
17141 C...Coulomb factor for W+W- pair
17142  IF(mstp(40).GE.1.AND.mstp(40).LE.3) THEN
17143  coule=(sh-4d0*sqmw)/(4d0*pmas(24,1))
17144  coulp=max(1d-10,0.5d0*be34*sqrt(sh))
17145  IF(coule.LT.100d0*pmas(24,2)) THEN
17146  coulp1=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
17147  & pmas(24,2)**2)-coule))
17148  ELSE
17149  coulp1=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/coule))
17150  ENDIF
17151  IF(coule.GT.-100d0*pmas(24,2)) THEN
17152  coulp2=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
17153  & pmas(24,2)**2)+coule))
17154  ELSE
17155  coulp2=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/
17156  & abs(coule)))
17157  ENDIF
17158  IF(mstp(40).EQ.1) THEN
17159  couldc=paru(1)-2d0*atan((coulp1**2+coulp2**2-coulp**2)/
17160  & max(1d-10,2d0*coulp*coulp1))
17161  faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
17162  ELSEIF(mstp(40).EQ.2) THEN
17163  coulck=cmplx(sngl(coulp1),sngl(coulp2))
17164  coulcp=cmplx(0.,sngl(coulp))
17165  coulcd=(coulck+coulcp)/(coulck-coulcp)
17166  coulcr=1.+sngl(paru(101)*sqrt(sh))/(4.*coulcp)*log(coulcd)
17167  coulcs=cmplx(0.,0.)
17168  nstp=100
17169  DO 530 istp=1,nstp
17170  coulxx=(istp-0.5)/nstp
17171  coulcs=coulcs+(1./coulxx)*log((1.+coulxx*coulcd)/
17172  & (1.+coulxx/coulcd))
17173  530 CONTINUE
17174  coulcr=coulcr+sngl(paru(101)**2*sh)/(16.*coulcp*coulck)*
17175  & (coulcs/nstp)
17176  faccou=abs(coulcr)**2
17177  ELSEIF(mstp(40).EQ.3) THEN
17178  couldc=paru(1)-2d0*(1d0-be34)**2*atan((coulp1**2+
17179  & coulp2**2-coulp**2)/max(1d-10,2d0*coulp*coulp1))
17180  faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
17181  ENDIF
17182  ELSEIF(mstp(40).EQ.4) THEN
17183  faccou=1d0+0.5d0*paru(101)*paru(1)/max(1d-5,be34)
17184  ELSE
17185  faccou=1d0
17186  ENDIF
17187  vint(95)=faccou
17188  facww=facww*faccou
17189 C...Loop over allowed flavours
17190  DO 540 i=mmina,mmaxa
17191  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 540
17192  ei=kchg(iabs(i),1)/3d0
17193  ai=sign(1d0,ei+0.1d0)
17194  vi=ai-4d0*ei*xwv
17195  fcoi=1d0
17196  IF(iabs(i).LE.10) fcoi=faca/3d0
17197  IF(ai.LT.0d0) THEN
17198  dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs+
17199  & (cng*ei+cnz*(vi+ai))*gst+cnn*gt
17200  ELSE
17201  dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs-
17202  & (cng*ei+cnz*(vi+ai))*gsu+cnn*gu
17203  ENDIF
17204  nchn=nchn+1
17205  isig(nchn,1)=i
17206  isig(nchn,2)=-i
17207  isig(nchn,3)=1
17208  sigh(nchn)=facww*fcoi*dsigww
17209  540 CONTINUE
17210 
17211  ELSEIF(isub.EQ.26) THEN
17212 C...f + fbar' -> W+/- + h0 (or H0, or A0)
17213  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
17214  fachw=comfac*0.125d0*(aem/xw)**2*(thuh+2d0*sh*sqm3)/
17215  & ((sh-sqmw)**2+gmmw**2)
17216  fachw=fachw*wids(kfhigg,2)
17217  IF(mstp(4).GE.1.OR.ihigg.GE.2) fachw=fachw*
17218  & paru(155+10*ihigg)**2
17219  DO 560 i=mmin1,mmax1
17220  ia=iabs(i)
17221  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 560
17222  DO 550 j=mmin2,mmax2
17223  ja=iabs(j)
17224  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(1,j).EQ.0) goto 550
17225  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 550
17226  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
17227  & goto 550
17228  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
17229  fckm=1d0
17230  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
17231  fcoi=1d0
17232  IF(ia.LE.10) fcoi=faca/3d0
17233  nchn=nchn+1
17234  isig(nchn,1)=i
17235  isig(nchn,2)=j
17236  isig(nchn,3)=1
17237  sigh(nchn)=fachw*fcoi*fckm*wids(24,(5-kchw)/2)
17238  550 CONTINUE
17239  560 CONTINUE
17240 
17241  ELSEIF(isub.EQ.27) THEN
17242 C...f + fbar -> h0 + h0
17243 
17244  ELSEIF(isub.EQ.28) THEN
17245 C...f + g -> f + g (q + g -> q + g only)
17246  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
17247  & uh/sh)*faca
17248  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
17249  & sh/uh)
17250  DO 580 i=mmina,mmaxa
17251  IF(i.EQ.0.OR.iabs(i).GT.10) goto 580
17252  DO 570 isde=1,2
17253  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 570
17254  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 570
17255  nchn=nchn+1
17256  isig(nchn,isde)=i
17257  isig(nchn,3-isde)=21
17258  isig(nchn,3)=1
17259  sigh(nchn)=facqg1
17260  nchn=nchn+1
17261  isig(nchn,isde)=i
17262  isig(nchn,3-isde)=21
17263  isig(nchn,3)=2
17264  sigh(nchn)=facqg2
17265  570 CONTINUE
17266  580 CONTINUE
17267 
17268  ELSEIF(isub.EQ.29) THEN
17269 C...f + g -> f + gamma (q + g -> q + gamma only)
17270  fgq=comfac*faca*as*aem*1d0/3d0*(sh2+uh2)/(-sh*uh)
17271  DO 600 i=mmina,mmaxa
17272  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 600
17273  ei=kchg(iabs(i),1)/3d0
17274  facgq=fgq*ei**2
17275  DO 590 isde=1,2
17276  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 590
17277  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 590
17278  nchn=nchn+1
17279  isig(nchn,isde)=i
17280  isig(nchn,3-isde)=21
17281  isig(nchn,3)=1
17282  sigh(nchn)=facgq
17283  590 CONTINUE
17284  600 CONTINUE
17285 
17286  ELSEIF(isub.EQ.30) THEN
17287 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
17288  fzq=comfac*faca*as*aem*(1d0/3d0)*(sh2+uh2+2d0*sqm4*th)/
17289  & (-sh*uh)
17290 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17291  hfgg=0d0
17292  hfgz=0d0
17293  hfzz=0d0
17294  radc4=1d0+pyalps(sqm4)/paru(1)
17295  DO 610 i=1,min(16,mdcy(23,3))
17296  idc=i+mdcy(23,2)-1
17297  IF(mdme(idc,1).LT.0) goto 610
17298  imdm=0
17299  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
17300  & imdm=1
17301  IF(i.LE.8) THEN
17302  ef=kchg(i,1)/3d0
17303  af=sign(1d0,ef+0.1d0)
17304  vf=af-4d0*ef*xwv
17305  ELSEIF(i.LE.16) THEN
17306  ef=kchg(i+2,1)/3d0
17307  af=sign(1d0,ef+0.1d0)
17308  vf=af-4d0*ef*xwv
17309  ENDIF
17310  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
17311  IF(4d0*rm1.LT.1d0) THEN
17312  fcof=1d0
17313  IF(i.LE.8) fcof=3d0*radc4
17314  be34=sqrt(max(0d0,1d0-4d0*rm1))
17315  IF(imdm.EQ.1) THEN
17316  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
17317  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
17318  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
17319  & af**2*(1d0-4d0*rm1))*be34
17320  ENDIF
17321  ENDIF
17322  610 CONTINUE
17323 C...Propagators: as simulated in PYOFSH and as desired
17324  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
17325  mint(15)=1
17326  mint(61)=1
17327  CALL pywidt(23,sqm4,wdtp,wdte)
17328  hfaem=(paru(108)/paru(2))*(2d0/3d0)
17329  hfgg=hfgg*hfaem*vint(111)/sqm4
17330  hfgz=hfgz*hfaem*vint(112)/sqm4
17331  hfzz=hfzz*hfaem*vint(114)/sqm4
17332 C...Loop over flavours; consider full gamma/Z structure
17333  DO 630 i=mmina,mmaxa
17334  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 630
17335  ei=kchg(iabs(i),1)/3d0
17336  ai=sign(1d0,ei)
17337  vi=ai-4d0*ei*xwv
17338  faczq=fzq*(ei**2*hfgg+ei*vi*hfgz+
17339  & (vi**2+ai**2)*hfzz)/hbw4
17340  DO 620 isde=1,2
17341  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 620
17342  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 620
17343  nchn=nchn+1
17344  isig(nchn,isde)=i
17345  isig(nchn,3-isde)=21
17346  isig(nchn,3)=1
17347  sigh(nchn)=faczq
17348  620 CONTINUE
17349  630 CONTINUE
17350  ENDIF
17351 
17352  ELSEIF(isub.LE.40) THEN
17353  IF(isub.EQ.31) THEN
17354 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
17355  facwq=comfac*faca*as*aem/xw*1d0/12d0*
17356  & (sh2+uh2+2d0*sqm4*th)/(-sh*uh)
17357 C...Propagators: as simulated in PYOFSH and as desired
17358  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
17359  CALL pywidt(24,sqm4,wdtp,wdte)
17360  gmmwc=sqrt(sqm4)*wdtp(0)
17361  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
17362  facwq=facwq*hbw4c/hbw4
17363  DO 650 i=mmina,mmaxa
17364  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 650
17365  ia=iabs(i)
17366  kchw=isign(1,kchg(ia,1)*isign(1,i))
17367  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
17368  DO 640 isde=1,2
17369  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 640
17370  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 640
17371  nchn=nchn+1
17372  isig(nchn,isde)=i
17373  isig(nchn,3-isde)=21
17374  isig(nchn,3)=1
17375  sigh(nchn)=facwq*vint(180+i)*widsc
17376  640 CONTINUE
17377  650 CONTINUE
17378 
17379  ELSEIF(isub.EQ.32) THEN
17380 C...f + g -> f + h0 (q + g -> q + h0 only)
17381 
17382  ELSEIF(isub.EQ.33) THEN
17383 C...f + gamma -> f + g (q + gamma -> q + g only)
17384  fgq=comfac*as*aem*8d0/3d0*(sh2+uh2)/(-sh*uh)
17385  DO 670 i=mmina,mmaxa
17386  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 670
17387  ei=kchg(iabs(i),1)/3d0
17388  facgq=fgq*ei**2
17389  DO 660 isde=1,2
17390  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 660
17391  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 660
17392  nchn=nchn+1
17393  isig(nchn,isde)=i
17394  isig(nchn,3-isde)=22
17395  isig(nchn,3)=1
17396  sigh(nchn)=facgq
17397  660 CONTINUE
17398  670 CONTINUE
17399 
17400  ELSEIF(isub.EQ.34) THEN
17401 C...f + gamma -> f + gamma
17402  fgq=comfac*aem**2*2d0*(sh2+uh2)/(-sh*uh)
17403  DO 690 i=mmina,mmaxa
17404  IF(i.EQ.0) goto 690
17405  ei=kchg(iabs(i),1)/3d0
17406  facgq=fgq*ei**4
17407  DO 680 isde=1,2
17408  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 680
17409  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 680
17410  nchn=nchn+1
17411  isig(nchn,isde)=i
17412  isig(nchn,3-isde)=22
17413  isig(nchn,3)=1
17414  sigh(nchn)=facgq
17415  680 CONTINUE
17416  690 CONTINUE
17417 
17418  ELSEIF(isub.EQ.35) THEN
17419 C...f + gamma -> f + (gamma*/Z0)
17420  fzqn=comfac*2d0*aem**2*(sh2+uh2+2d0*sqm4*th)
17421  fzqd=sqpth*sqm4-sh*uh
17422 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17423  hfgg=0d0
17424  hfgz=0d0
17425  hfzz=0d0
17426  radc4=1d0+pyalps(sqm4)/paru(1)
17427  DO 700 i=1,min(16,mdcy(23,3))
17428  idc=i+mdcy(23,2)-1
17429  IF(mdme(idc,1).LT.0) goto 700
17430  imdm=0
17431  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
17432  & imdm=1
17433  IF(i.LE.8) THEN
17434  ef=kchg(i,1)/3d0
17435  af=sign(1d0,ef+0.1d0)
17436  vf=af-4d0*ef*xwv
17437  ELSEIF(i.LE.16) THEN
17438  ef=kchg(i+2,1)/3d0
17439  af=sign(1d0,ef+0.1d0)
17440  vf=af-4d0*ef*xwv
17441  ENDIF
17442  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
17443  IF(4d0*rm1.LT.1d0) THEN
17444  fcof=1d0
17445  IF(i.LE.8) fcof=3d0*radc4
17446  be34=sqrt(max(0d0,1d0-4d0*rm1))
17447  IF(imdm.EQ.1) THEN
17448  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
17449  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
17450  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
17451  & af**2*(1d0-4d0*rm1))*be34
17452  ENDIF
17453  ENDIF
17454  700 CONTINUE
17455 C...Propagators: as simulated in PYOFSH and as desired
17456  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
17457  mint(15)=1
17458  mint(61)=1
17459  CALL pywidt(23,sqm4,wdtp,wdte)
17460  hfaem=(paru(108)/paru(2))*(2d0/3d0)
17461  hfgg=hfgg*hfaem*vint(111)/sqm4
17462  hfgz=hfgz*hfaem*vint(112)/sqm4
17463  hfzz=hfzz*hfaem*vint(114)/sqm4
17464 C...Loop over flavours; consider full gamma/Z structure
17465  DO 720 i=mmina,mmaxa
17466  IF(i.EQ.0) goto 720
17467  ei=kchg(iabs(i),1)/3d0
17468  ai=sign(1d0,ei)
17469  vi=ai-4d0*ei*xwv
17470  faczq=ei**2*(ei**2*hfgg+ei*vi*hfgz+
17471  & (vi**2+ai**2)*hfzz)/hbw4
17472  DO 710 isde=1,2
17473  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 710
17474  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 710
17475  nchn=nchn+1
17476  isig(nchn,isde)=i
17477  isig(nchn,3-isde)=22
17478  isig(nchn,3)=1
17479  sigh(nchn)=faczq*fzqn/max(pmas(iabs(i),1)**2*sqm4,fzqd)
17480  710 CONTINUE
17481  720 CONTINUE
17482 
17483  ELSEIF(isub.EQ.36) THEN
17484 C...f + gamma -> f' + W+/-
17485  fwq=comfac*aem**2/(2d0*xw)*
17486  & (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)
17487 C...Propagators: as simulated in PYOFSH and as desired
17488  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
17489  CALL pywidt(24,sqm4,wdtp,wdte)
17490  gmmwc=sqrt(sqm4)*wdtp(0)
17491  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
17492  fwq=fwq*hbw4c/hbw4
17493  DO 740 i=mmina,mmaxa
17494  IF(i.EQ.0) goto 740
17495  ia=iabs(i)
17496  eia=abs(kchg(iabs(i),1)/3d0)
17497  facwq=fwq*(eia-sh/(sh+uh))**2
17498  kchw=isign(1,kchg(ia,1)*isign(1,i))
17499  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
17500  DO 730 isde=1,2
17501  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 730
17502  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 730
17503  nchn=nchn+1
17504  isig(nchn,isde)=i
17505  isig(nchn,3-isde)=22
17506  isig(nchn,3)=1
17507  sigh(nchn)=facwq*vint(180+i)*widsc
17508  730 CONTINUE
17509  740 CONTINUE
17510 
17511  ELSEIF(isub.EQ.37) THEN
17512 C...f + gamma -> f + h0
17513 
17514  ELSEIF(isub.EQ.38) THEN
17515 C...f + Z0 -> f + g (q + Z0 -> q + g only)
17516 
17517  ELSEIF(isub.EQ.39) THEN
17518 C...f + Z0 -> f + gamma
17519 
17520  ELSEIF(isub.EQ.40) THEN
17521 C...f + Z0 -> f + Z0
17522  ENDIF
17523 
17524  ELSEIF(isub.LE.50) THEN
17525  IF(isub.EQ.41) THEN
17526 C...f + Z0 -> f' + W+/-
17527 
17528  ELSEIF(isub.EQ.42) THEN
17529 C...f + Z0 -> f + h0
17530 
17531  ELSEIF(isub.EQ.43) THEN
17532 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
17533 
17534  ELSEIF(isub.EQ.44) THEN
17535 C...f + W+/- -> f' + gamma
17536 
17537  ELSEIF(isub.EQ.45) THEN
17538 C...f + W+/- -> f' + Z0
17539 
17540  ELSEIF(isub.EQ.46) THEN
17541 C...f + W+/- -> f' + W+/-
17542 
17543  ELSEIF(isub.EQ.47) THEN
17544 C...f + W+/- -> f' + h0
17545 
17546  ELSEIF(isub.EQ.48) THEN
17547 C...f + h0 -> f + g (q + h0 -> q + g only)
17548 
17549  ELSEIF(isub.EQ.49) THEN
17550 C...f + h0 -> f + gamma
17551 
17552  ELSEIF(isub.EQ.50) THEN
17553 C...f + h0 -> f + Z0
17554  ENDIF
17555 
17556  ELSEIF(isub.LE.60) THEN
17557  IF(isub.EQ.51) THEN
17558 C...f + h0 -> f' + W+/-
17559 
17560  ELSEIF(isub.EQ.52) THEN
17561 C...f + h0 -> f + h0
17562 
17563  ELSEIF(isub.EQ.53) THEN
17564 C...g + g -> f + fbar (g + g -> q + qbar only)
17565  CALL pywidt(21,sh,wdtp,wdte)
17566  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
17567  & uh2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
17568  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
17569  & th2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
17570  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 750
17571  nchn=nchn+1
17572  isig(nchn,1)=21
17573  isig(nchn,2)=21
17574  isig(nchn,3)=1
17575  sigh(nchn)=facqq1
17576  nchn=nchn+1
17577  isig(nchn,1)=21
17578  isig(nchn,2)=21
17579  isig(nchn,3)=2
17580  sigh(nchn)=facqq2
17581  750 CONTINUE
17582 
17583  ELSEIF(isub.EQ.54) THEN
17584 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
17585  CALL pywidt(21,sh,wdtp,wdte)
17586  wdtesu=0d0
17587  DO 760 i=1,min(8,mdcy(21,3))
17588  ef=kchg(i,1)/3d0
17589  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
17590  & wdte(i,4))
17591  760 CONTINUE
17592  facqq=comfac*aem*as*wdtesu*(th2+uh2)/(th*uh)
17593  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
17594  nchn=nchn+1
17595  isig(nchn,1)=21
17596  isig(nchn,2)=22
17597  isig(nchn,3)=1
17598  sigh(nchn)=facqq
17599  ENDIF
17600  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
17601  nchn=nchn+1
17602  isig(nchn,1)=22
17603  isig(nchn,2)=21
17604  isig(nchn,3)=1
17605  sigh(nchn)=facqq
17606  ENDIF
17607 
17608  ELSEIF(isub.EQ.55) THEN
17609 C...g + Z -> f + fbar (g + Z -> q + qbar only)
17610 
17611  ELSEIF(isub.EQ.56) THEN
17612 C...g + W -> f + f'bar (g + W -> q + q'bar only)
17613 
17614  ELSEIF(isub.EQ.57) THEN
17615 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
17616 
17617  ELSEIF(isub.EQ.58) THEN
17618 C...gamma + gamma -> f + fbar
17619  CALL pywidt(22,sh,wdtp,wdte)
17620  wdtesu=0d0
17621  DO 770 i=1,min(12,mdcy(22,3))
17622  IF(i.LE.8) ef= kchg(i,1)/3d0
17623  IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
17624  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
17625  & wdte(i,4))
17626  770 CONTINUE
17627  facff=comfac*aem**2*wdtesu*2d0*(th2+uh2)/(th*uh)
17628  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
17629  nchn=nchn+1
17630  isig(nchn,1)=22
17631  isig(nchn,2)=22
17632  isig(nchn,3)=1
17633  sigh(nchn)=facff
17634  ENDIF
17635 
17636  ELSEIF(isub.EQ.59) THEN
17637 C...gamma + Z0 -> f + fbar
17638 
17639  ELSEIF(isub.EQ.60) THEN
17640 C...gamma + W+/- -> f + fbar'
17641  ENDIF
17642 
17643  ELSEIF(isub.LE.70) THEN
17644  IF(isub.EQ.61) THEN
17645 C...gamma + h0 -> f + fbar
17646 
17647  ELSEIF(isub.EQ.62) THEN
17648 C...Z0 + Z0 -> f + fbar
17649 
17650  ELSEIF(isub.EQ.63) THEN
17651 C...Z0 + W+/- -> f + fbar'
17652 
17653  ELSEIF(isub.EQ.64) THEN
17654 C...Z0 + h0 -> f + fbar
17655 
17656  ELSEIF(isub.EQ.65) THEN
17657 C...W+ + W- -> f + fbar
17658 
17659  ELSEIF(isub.EQ.66) THEN
17660 C...W+/- + h0 -> f + fbar'
17661 
17662  ELSEIF(isub.EQ.67) THEN
17663 C...h0 + h0 -> f + fbar
17664 
17665  ELSEIF(isub.EQ.68) THEN
17666 C...g + g -> g + g
17667  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+2d0*th/sh+
17668  & th2/sh2)*faca
17669  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+2d0*sh/uh+
17670  & sh2/uh2)*faca
17671  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+2d0*uh/th+
17672  & uh2/th2)
17673  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 780
17674  nchn=nchn+1
17675  isig(nchn,1)=21
17676  isig(nchn,2)=21
17677  isig(nchn,3)=1
17678  sigh(nchn)=0.5d0*facgg1
17679  nchn=nchn+1
17680  isig(nchn,1)=21
17681  isig(nchn,2)=21
17682  isig(nchn,3)=2
17683  sigh(nchn)=0.5d0*facgg2
17684  nchn=nchn+1
17685  isig(nchn,1)=21
17686  isig(nchn,2)=21
17687  isig(nchn,3)=3
17688  sigh(nchn)=0.5d0*facgg3
17689  780 CONTINUE
17690 
17691  ELSEIF(isub.EQ.69) THEN
17692 C...gamma + gamma -> W+ + W-
17693  sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
17694  fprop=sh2/((sqmwe-th)*(sqmwe-uh))
17695  facww=comfac*6d0*aem**2*(1d0-fprop*(4d0/3d0+2d0*sqmwe/sh)+
17696  & fprop**2*(2d0/3d0+2d0*(sqmwe/sh)**2))*wids(24,1)
17697  IF(kfac(1,22)*kfac(2,22).EQ.0) goto 790
17698  nchn=nchn+1
17699  isig(nchn,1)=22
17700  isig(nchn,2)=22
17701  isig(nchn,3)=1
17702  sigh(nchn)=facww
17703  790 CONTINUE
17704 
17705  ELSEIF(isub.EQ.70) THEN
17706 C...gamma + W+/- -> Z0 + W+/-
17707  sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
17708  fprop=(th-sqmwe)**2/(-sh*(sqmwe-uh))
17709  faczw=comfac*6d0*aem**2*(xw1/xw)*
17710  & (1d0-fprop*(4d0/3d0+2d0*sqmwe/(th-sqmwe))+
17711  & fprop**2*(2d0/3d0+2d0*(sqmwe/(th-sqmwe))**2))*wids(23,2)
17712  DO 810 kchw=1,-1,-2
17713  DO 800 isde=1,2
17714  IF(kfac(isde,22)*kfac(3-isde,24*kchw).EQ.0) goto 800
17715  nchn=nchn+1
17716  isig(nchn,isde)=22
17717  isig(nchn,3-isde)=24*kchw
17718  isig(nchn,3)=1
17719  sigh(nchn)=faczw*wids(24,(5-kchw)/2)
17720  800 CONTINUE
17721  810 CONTINUE
17722  ENDIF
17723 
17724  ELSEIF(isub.LE.80) THEN
17725  IF(isub.EQ.71) THEN
17726 C...Z0 + Z0 -> Z0 + Z0
17727  IF(sh.LE.4.01d0*sqmz) goto 840
17728 
17729  IF(mstp(46).LE.2) THEN
17730 C...Exact scattering ME:s for on-mass-shell gauge bosons
17731  be2=1d0-4d0*sqmz/sh
17732  th=-0.5d0*sh*be2*(1d0-cth)
17733  uh=-0.5d0*sh*be2*(1d0+cth)
17734  IF(max(th,uh).GT.-1d0) goto 840
17735  shang=1d0/xw1*sqmw/sqmz*(1d0+be2)**2
17736  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17737  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17738  thang=1d0/xw1*sqmw/sqmz*(be2-cth)**2
17739  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
17740  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
17741  uhang=1d0/xw1*sqmw/sqmz*(be2+cth)**2
17742  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
17743  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
17744  faczz=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
17745  & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
17746  IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
17747  IF(mstp(46).EQ.1) faczz=faczz*((ashre+athre+auhre)**2+
17748  & (ashim+athim+auhim)**2)
17749  IF(mstp(46).EQ.2) faczz=0d0
17750 
17751  ELSE
17752 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17753  faczz=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
17754  & abs(a00u+2.*a20u)**2
17755  ENDIF
17756  faczz=faczz*wids(23,1)
17757 
17758  DO 830 i=mmin1,mmax1
17759  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 830
17760  ei=kchg(iabs(i),1)/3d0
17761  ai=sign(1d0,ei)
17762  vi=ai-4d0*ei*xwv
17763  avi=ai**2+vi**2
17764  DO 820 j=mmin2,mmax2
17765  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 820
17766  ej=kchg(iabs(j),1)/3d0
17767  aj=sign(1d0,ej)
17768  vj=aj-4d0*ej*xwv
17769  avj=aj**2+vj**2
17770  nchn=nchn+1
17771  isig(nchn,1)=i
17772  isig(nchn,2)=j
17773  isig(nchn,3)=1
17774  sigh(nchn)=0.5d0*faczz*avi*avj
17775  820 CONTINUE
17776  830 CONTINUE
17777  840 CONTINUE
17778 
17779  ELSEIF(isub.EQ.72) THEN
17780 C...Z0 + Z0 -> W+ + W-
17781  IF(sh.LE.4.01d0*sqmz) goto 870
17782 
17783  IF(mstp(46).LE.2) THEN
17784 C...Exact scattering ME:s for on-mass-shell gauge bosons
17785  be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
17786  cth2=cth**2
17787  th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
17788  uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
17789  IF(max(th,uh).GT.-1d0) goto 870
17790  shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
17791  & (1d0-2d0*sqmz/sh)
17792  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17793  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17794  atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
17795  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
17796  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
17797  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
17798  & 2d0*(sqmw+sqmz)/sh*be2*cth))
17799  atwim=0d0
17800  auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
17801  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
17802  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
17803  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
17804  & 2d0*(sqmw+sqmz)/sh*be2*cth))
17805  auwim=0d0
17806  a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
17807  a4im=0d0
17808  facww=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
17809  & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
17810  IF(mstp(46).LE.0) facww=facww*(ashre**2+ashim**2)
17811  IF(mstp(46).EQ.1) facww=facww*((ashre+atwre+auwre+a4re)**2+
17812  & (ashim+atwim+auwim+a4im)**2)
17813  IF(mstp(46).EQ.2) facww=facww*((atwre+auwre+a4re)**2+
17814  & (atwim+auwim+a4im)**2)
17815 
17816  ELSE
17817 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17818  facww=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
17819  & abs(a00u-a20u)**2
17820  ENDIF
17821  facww=facww*wids(24,1)
17822 
17823  DO 860 i=mmin1,mmax1
17824  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 860
17825  ei=kchg(iabs(i),1)/3d0
17826  ai=sign(1d0,ei)
17827  vi=ai-4d0*ei*xwv
17828  avi=ai**2+vi**2
17829  DO 850 j=mmin2,mmax2
17830  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 850
17831  ej=kchg(iabs(j),1)/3d0
17832  aj=sign(1d0,ej)
17833  vj=aj-4d0*ej*xwv
17834  avj=aj**2+vj**2
17835  nchn=nchn+1
17836  isig(nchn,1)=i
17837  isig(nchn,2)=j
17838  isig(nchn,3)=1
17839  sigh(nchn)=facww*avi*avj
17840  850 CONTINUE
17841  860 CONTINUE
17842  870 CONTINUE
17843 
17844  ELSEIF(isub.EQ.73) THEN
17845 C...Z0 + W+/- -> Z0 + W+/-
17846  IF(sh.LE.2d0*sqmz+2d0*sqmw) goto 900
17847 
17848  IF(mstp(46).LE.2) THEN
17849 C...Exact scattering ME:s for on-mass-shell gauge bosons
17850  be2=1d0-2d0*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2
17851  ep1=1d0-(sqmz-sqmw)/sh
17852  ep2=1d0+(sqmz-sqmw)/sh
17853  th=-0.5d0*sh*be2*(1d0-cth)
17854  uh=(sqmz-sqmw)**2/sh-0.5d0*sh*be2*(1d0+cth)
17855  IF(max(th,uh).GT.-1d0) goto 900
17856  thang=(be2-ep1*cth)*(be2-ep2*cth)
17857  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
17858  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
17859  aswre=-xw1/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+
17860  & 1d0/4d0*(be2+ep1*ep2)**2*((ep1-ep2)**2-4d0*be2*cth)+
17861  & 2d0*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-
17862  & 1d0/16d0*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)
17863  aswim=0d0
17864  auwre=xw1/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*
17865  & (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*
17866  & (be2+ep1*ep2*cth)*(2d0*ep2-ep2*cth+ep1)-
17867  & be2*(ep2+ep1*cth)**2*(be2-ep2**2*cth)-1d0/8d0*
17868  & (be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2d0*be2*(1d0-cth))+
17869  & 1d0/32d0*sh/sqmw*(be2+ep1*ep2*cth)**2*
17870  & (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*
17871  & (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*
17872  & (2d0*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*
17873  & (be2-ep1**2*cth)-1d0/8d0*(be2+ep1*ep2*cth)**2*
17874  & ((ep1+ep2)**2+2d0*be2*(1d0-cth))+1d0/32d0*sh/sqmw*
17875  & (be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)
17876  auwim=0d0
17877  a4re=xw1/sqmz*(ep1**2*ep2**2*(cth**2-1d0)-
17878  & 2d0*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2d0*be2*ep1*ep2)
17879  a4im=0d0
17880  faczw=comfac*1d0/(4096d0*paru(1)**2*4d0*xw1)*(aem/xw)**4*
17881  & (sh/sqmw)**2*sqrt(sqmz/sqmw)*sh2
17882  IF(mstp(46).LE.0) faczw=0d0
17883  IF(mstp(46).EQ.1) faczw=faczw*((athre+aswre+auwre+a4re)**2+
17884  & (athim+aswim+auwim+a4im)**2)
17885  IF(mstp(46).EQ.2) faczw=faczw*((aswre+auwre+a4re)**2+
17886  & (aswim+auwim+a4im)**2)
17887 
17888  ELSE
17889 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17890  faczw=comfac*aem**2/(64d0*paru(1)**2*xw**2*xw1)*16d0*
17891  & abs(a20u+3.*a11u*sngl(cth))**2
17892  ENDIF
17893  faczw=faczw*wids(23,2)
17894 
17895  DO 890 i=mmin1,mmax1
17896  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 890
17897  ei=kchg(iabs(i),1)/3d0
17898  ai=sign(1d0,ei)
17899  vi=ai-4d0*ei*xwv
17900  avi=ai**2+vi**2
17901  kchwi=isign(1,kchg(iabs(i),1)*isign(1,i))
17902  DO 880 j=mmin2,mmax2
17903  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 880
17904  ej=kchg(iabs(j),1)/3d0
17905  aj=sign(1d0,ej)
17906  vj=ai-4d0*ej*xwv
17907  avj=aj**2+vj**2
17908  kchwj=isign(1,kchg(iabs(j),1)*isign(1,j))
17909  nchn=nchn+1
17910  isig(nchn,1)=i
17911  isig(nchn,2)=j
17912  isig(nchn,3)=1
17913  sigh(nchn)=faczw*avi*vint(180+j)*wids(24,(5-kchwj)/2)
17914  nchn=nchn+1
17915  isig(nchn,1)=i
17916  isig(nchn,2)=j
17917  isig(nchn,3)=2
17918  sigh(nchn)=faczw*vint(180+i)*wids(24,(5-kchwi)/2)*avj
17919  880 CONTINUE
17920  890 CONTINUE
17921  900 CONTINUE
17922 
17923  ELSEIF(isub.EQ.75) THEN
17924 C...W+ + W- -> gamma + gamma
17925 
17926  ELSEIF(isub.EQ.76) THEN
17927 C...W+ + W- -> Z0 + Z0
17928  IF(sh.LE.4.01d0*sqmz) goto 930
17929 
17930  IF(mstp(46).LE.2) THEN
17931 C...Exact scattering ME:s for on-mass-shell gauge bosons
17932  be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
17933  cth2=cth**2
17934  th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
17935  uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
17936  IF(max(th,uh).GT.-1d0) goto 930
17937  shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
17938  & (1d0-2d0*sqmz/sh)
17939  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
17940  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
17941  atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
17942  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
17943  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
17944  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
17945  & 2d0*(sqmw+sqmz)/sh*be2*cth))
17946  atwim=0d0
17947  auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
17948  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
17949  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
17950  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
17951  & 2d0*(sqmw+sqmz)/sh*be2*cth))
17952  auwim=0d0
17953  a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
17954  a4im=0d0
17955  faczz=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
17956  & (sh/sqmw)**2*sh2
17957  IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
17958  IF(mstp(46).EQ.1) faczz=faczz*((ashre+atwre+auwre+a4re)**2+
17959  & (ashim+atwim+auwim+a4im)**2)
17960  IF(mstp(46).EQ.2) faczz=faczz*((atwre+auwre+a4re)**2+
17961  & (atwim+auwim+a4im)**2)
17962 
17963  ELSE
17964 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17965  faczz=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
17966  & abs(a00u-a20u)**2
17967  ENDIF
17968  faczz=faczz*wids(23,1)
17969 
17970  DO 920 i=mmin1,mmax1
17971  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 920
17972  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
17973  DO 910 j=mmin2,mmax2
17974  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 910
17975  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
17976  IF(ei*ej.GT.0d0) goto 910
17977  nchn=nchn+1
17978  isig(nchn,1)=i
17979  isig(nchn,2)=j
17980  isig(nchn,3)=1
17981  sigh(nchn)=0.5d0*faczz*vint(180+i)*vint(180+j)
17982  910 CONTINUE
17983  920 CONTINUE
17984  930 CONTINUE
17985 
17986  ELSEIF(isub.EQ.77) THEN
17987 C...W+/- + W+/- -> W+/- + W+/-
17988  IF(sh.LE.4.01d0*sqmw) goto 960
17989 
17990  IF(mstp(46).LE.2) THEN
17991 C...Exact scattering ME:s for on-mass-shell gauge bosons
17992  be2=1d0-4d0*sqmw/sh
17993  be4=be2**2
17994  cth2=cth**2
17995  cth3=cth**3
17996  th=-0.5d0*sh*be2*(1d0-cth)
17997  uh=-0.5d0*sh*be2*(1d0+cth)
17998  IF(max(th,uh).GT.-1d0) goto 960
17999  shang=(1d0+be2)**2
18000  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
18001  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
18002  thang=(be2-cth)**2
18003  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
18004  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
18005  uhang=(be2+cth)**2
18006  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
18007  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
18008  sgzang=1d0/sqmw*be2*(3d0-be2)**2*cth
18009  asgre=xw*sgzang
18010  asgim=0d0
18011  aszre=xw1*sh/(sh-sqmz)*sgzang
18012  aszim=0d0
18013  tgzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)+be2*(4d0-10d0*be2+
18014  & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2+be2*cth3)
18015  atgre=0.5d0*xw*sh/th*tgzang
18016  atgim=0d0
18017  atzre=0.5d0*xw1*sh/(th-sqmz)*tgzang
18018  atzim=0d0
18019  ugzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)-be2*(4d0-10d0*be2+
18020  & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2-be2*cth3)
18021  augre=0.5d0*xw*sh/uh*ugzang
18022  augim=0d0
18023  auzre=0.5d0*xw1*sh/(uh-sqmz)*ugzang
18024  auzim=0d0
18025  a4are=1d0/sqmw*(1d0+2d0*be2-6d0*be2*cth-cth2)
18026  a4aim=0d0
18027  a4sre=2d0/sqmw*(1d0+2d0*be2-cth2)
18028  a4sim=0d0
18029  fww=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
18030  & (sh/sqmw)**2*sh2
18031  IF(mstp(46).LE.0) THEN
18032  awware=ashre
18033  awwaim=ashim
18034  awwsre=0d0
18035  awwsim=0d0
18036  ELSEIF(mstp(46).EQ.1) THEN
18037  awware=ashre+athre+asgre+aszre+atgre+atzre+a4are
18038  awwaim=ashim+athim+asgim+aszim+atgim+atzim+a4aim
18039  awwsre=-athre-auhre+atgre+atzre+augre+auzre+a4sre
18040  awwsim=-athim-auhim+atgim+atzim+augim+auzim+a4sim
18041  ELSE
18042  awware=asgre+aszre+atgre+atzre+a4are
18043  awwaim=asgim+aszim+atgim+atzim+a4aim
18044  awwsre=atgre+atzre+augre+auzre+a4sre
18045  awwsim=atgim+atzim+augim+auzim+a4sim
18046  ENDIF
18047  awwa2=awware**2+awwaim**2
18048  awws2=awwsre**2+awwsim**2
18049 
18050  ELSE
18051 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18052  fwwa=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
18053  & abs(a00u+0.5*a20u+4.5*a11u*sngl(cth))**2
18054  fwws=comfac*(aem/(4d0*paru(1)*xw))**2*64d0*abs(a20u)**2
18055  ENDIF
18056 
18057  DO 950 i=mmin1,mmax1
18058  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 950
18059  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
18060  DO 940 j=mmin2,mmax2
18061  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 940
18062  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
18063  IF(ei*ej.LT.0d0) THEN
18064 C...W+W-
18065  IF(mstp(45).EQ.1) goto 940
18066  IF(mstp(46).LE.2) facww=fww*awwa2*wids(24,1)
18067  IF(mstp(46).GE.3) facww=fwwa*wids(24,1)
18068  ELSE
18069 C...W+W+/W-W-
18070  IF(mstp(45).EQ.2) goto 940
18071  IF(mstp(46).LE.2) facww=fww*awws2
18072  IF(mstp(46).GE.3) facww=fwws
18073  IF(ei.GT.0d0) facww=facww*wids(24,4)
18074  IF(ei.LT.0d0) facww=facww*wids(24,5)
18075  ENDIF
18076  nchn=nchn+1
18077  isig(nchn,1)=i
18078  isig(nchn,2)=j
18079  isig(nchn,3)=1
18080  sigh(nchn)=facww*vint(180+i)*vint(180+j)
18081  IF(ei*ej.GT.0d0) sigh(nchn)=0.5d0*sigh(nchn)
18082  940 CONTINUE
18083  950 CONTINUE
18084  960 CONTINUE
18085 
18086  ELSEIF(isub.EQ.78) THEN
18087 C...W+/- + h0 -> W+/- + h0
18088 
18089  ELSEIF(isub.EQ.79) THEN
18090 C...h0 + h0 -> h0 + h0
18091 
18092  ELSEIF(isub.EQ.80) THEN
18093 C...q + gamma -> q' + pi+/-
18094  fqpi=comfac*(2d0*aem/9d0)*(-sh/th)*(1d0/sh2+1d0/th2)
18095  assh=pyalps(max(0.5d0,0.5d0*sh))
18096  q2fpsh=0.55d0/log(max(2d0,2d0*sh))
18097  delsh=uh*sqrt(assh*q2fpsh)
18098  asuh=pyalps(max(0.5d0,-0.5d0*uh))
18099  q2fpuh=0.55d0/log(max(2d0,-2d0*uh))
18100  deluh=sh*sqrt(asuh*q2fpuh)
18101  DO 980 i=max(-2,mmina),min(2,mmaxa)
18102  IF(i.EQ.0) goto 980
18103  ei=kchg(iabs(i),1)/3d0
18104  ej=sign(1d0-abs(ei),ei)
18105  DO 970 isde=1,2
18106  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 970
18107  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 970
18108  nchn=nchn+1
18109  isig(nchn,isde)=i
18110  isig(nchn,3-isde)=22
18111  isig(nchn,3)=1
18112  sigh(nchn)=fqpi*(ei*delsh+ej*deluh)**2
18113  970 CONTINUE
18114  980 CONTINUE
18115 
18116  ENDIF
18117 
18118 C...C: 2 -> 2, tree diagrams with masses
18119 
18120  ELSEIF(isub.LE.90) THEN
18121  IF(isub.EQ.81) THEN
18122 C...q + qbar -> Q + Qbar
18123  facqqb=comfac*as**2*4d0/9d0*(((th-sqm3)**2+
18124  & (uh-sqm3)**2)/sh2+2d0*sqm3/sh)
18125  IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqm3,0d0)
18126  wid2=1d0
18127  IF(mint(55).EQ.6) wid2=wids(6,1)
18128  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
18129  facqqb=facqqb*wid2
18130  DO 990 i=mmina,mmaxa
18131  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
18132  & kfac(1,i)*kfac(2,-i).EQ.0) goto 990
18133  nchn=nchn+1
18134  isig(nchn,1)=i
18135  isig(nchn,2)=-i
18136  isig(nchn,3)=1
18137  sigh(nchn)=facqqb
18138  990 CONTINUE
18139 
18140  ELSEIF(isub.EQ.82) THEN
18141 C...g + g -> Q + Qbar
18142  IF(mstp(34).EQ.0) THEN
18143  facqq1=comfac*faca*as**2*(1d0/6d0)*((uh-sqm3)/(th-sqm3)-
18144  & 2d0*(uh-sqm3)**2/sh2+4d0*(sqm3/sh)*(th*uh-sqm3**2)/
18145  & (th-sqm3)**2)
18146  facqq2=comfac*faca*as**2*(1d0/6d0)*((th-sqm3)/(uh-sqm3)-
18147  & 2d0*(th-sqm3)**2/sh2+4d0*(sqm3/sh)*(th*uh-sqm3**2)/
18148  & (uh-sqm3)**2)
18149  ELSE
18150  facqq1=comfac*faca*as**2*(1d0/6d0)*((uh-sqm3)/(th-sqm3)-
18151  & 2.25d0*(uh-sqm3)**2/sh2+4.5d0*(sqm3/sh)*(th*uh-sqm3**2)/
18152  & (th-sqm3)**2+0.5d0*sqm3*th/(th-sqm3)**2-sqm3**2/
18153  & (sh*(th-sqm3)))
18154  facqq2=comfac*faca*as**2*(1d0/6d0)*((th-sqm3)/(uh-sqm3)-
18155  & 2.25d0*(th-sqm3)**2/sh2+4.5d0*(sqm3/sh)*(th*uh-sqm3**2)/
18156  & (uh-sqm3)**2+0.5d0*sqm3*uh/(uh-sqm3)**2-sqm3**2/
18157  & (sh*(uh-sqm3)))
18158  ENDIF
18159  IF(mstp(35).GE.1) THEN
18160  fatre=pyhfth(sh,sqm3,2d0/7d0)
18161  facqq1=facqq1*fatre
18162  facqq2=facqq2*fatre
18163  ENDIF
18164  wid2=1d0
18165  IF(mint(55).EQ.6) wid2=wids(6,1)
18166  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
18167  facqq1=facqq1*wid2
18168  facqq2=facqq2*wid2
18169  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1000
18170  nchn=nchn+1
18171  isig(nchn,1)=21
18172  isig(nchn,2)=21
18173  isig(nchn,3)=1
18174  sigh(nchn)=facqq1
18175  nchn=nchn+1
18176  isig(nchn,1)=21
18177  isig(nchn,2)=21
18178  isig(nchn,3)=2
18179  sigh(nchn)=facqq2
18180  1000 CONTINUE
18181 
18182  ELSEIF(isub.EQ.83) THEN
18183 C...f + q -> f' + Q
18184  facqqs=comfac*(0.5d0*aem/xw)**2*sh*(sh-sqm3)/(sqmw-th)**2
18185  facqqu=comfac*(0.5d0*aem/xw)**2*uh*(uh-sqm3)/(sqmw-th)**2
18186  DO 1020 i=mmin1,mmax1
18187  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1020
18188  DO 1010 j=mmin2,mmax2
18189  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1010
18190  IF(i*j.GT.0.AND.mod(iabs(i+j),2).EQ.0) goto 1010
18191  IF(i*j.LT.0.AND.mod(iabs(i+j),2).EQ.1) goto 1010
18192  IF(iabs(i).LT.mint(55).AND.mod(iabs(i+mint(55)),2).EQ.1)
18193  & THEN
18194  nchn=nchn+1
18195  isig(nchn,1)=i
18196  isig(nchn,2)=j
18197  isig(nchn,3)=1
18198  IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
18199  & (iabs(i)+1)/2)*vint(180+j)
18200  IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(i)/2,
18201  & (mint(55)+1)/2)*vint(180+j)
18202  wid2=1d0
18203  IF(i.GT.0) THEN
18204  IF(mint(55).EQ.6) wid2=wids(6,2)
18205  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
18206  & wids(mint(55),2)
18207  ELSE
18208  IF(mint(55).EQ.6) wid2=wids(6,3)
18209  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
18210  & wids(mint(55),3)
18211  ENDIF
18212  IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
18213  IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
18214  ENDIF
18215  IF(iabs(j).LT.mint(55).AND.mod(iabs(j+mint(55)),2).EQ.1)
18216  & THEN
18217  nchn=nchn+1
18218  isig(nchn,1)=i
18219  isig(nchn,2)=j
18220  isig(nchn,3)=2
18221  IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
18222  & (iabs(j)+1)/2)*vint(180+i)
18223  IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(j)/2,
18224  & (mint(55)+1)/2)*vint(180+i)
18225  IF(j.GT.0) THEN
18226  IF(mint(55).EQ.6) wid2=wids(6,2)
18227  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
18228  & wids(mint(55),2)
18229  ELSE
18230  IF(mint(55).EQ.6) wid2=wids(6,3)
18231  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
18232  & wids(mint(55),3)
18233  ENDIF
18234  IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
18235  IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
18236  ENDIF
18237  1010 CONTINUE
18238  1020 CONTINUE
18239 
18240  ELSEIF(isub.EQ.84) THEN
18241 C...g + gamma -> Q + Qbar
18242  fmtu=sqm3/(sqm3-th)+sqm3/(sqm3-uh)
18243  facqq=comfac*as*aem*(kchg(iabs(mint(55)),1)/3d0)**2*
18244  & ((sqm3-th)/(sqm3-uh)+(sqm3-uh)/(sqm3-th)+4d0*fmtu*(1d0-fmtu))
18245  IF(mstp(35).GE.1) facqq=facqq*pyhfth(sh,sqm3,0d0)
18246  wid2=1d0
18247  IF(mint(55).EQ.6) wid2=wids(6,1)
18248  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
18249  facqq=facqq*wid2
18250  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
18251  nchn=nchn+1
18252  isig(nchn,1)=21
18253  isig(nchn,2)=22
18254  isig(nchn,3)=1
18255  sigh(nchn)=facqq
18256  ENDIF
18257  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
18258  nchn=nchn+1
18259  isig(nchn,1)=22
18260  isig(nchn,2)=21
18261  isig(nchn,3)=1
18262  sigh(nchn)=facqq
18263  ENDIF
18264 
18265  ELSEIF(isub.EQ.85) THEN
18266 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
18267  fmtu=sqm3/(sqm3-th)+sqm3/(sqm3-uh)
18268  facff=comfac*aem**2*(kchg(iabs(mint(56)),1)/3d0)**4*2d0*
18269  & ((sqm3-th)/(sqm3-uh)+(sqm3-uh)/(sqm3-th)+4d0*fmtu*(1d0-fmtu))
18270  IF(iabs(mint(56)).LT.10) facff=3d0*facff
18271  IF(iabs(mint(56)).LT.10.AND.mstp(35).GE.1)
18272  & facff=facff*pyhfth(sh,sqm3,1d0)
18273  wid2=1d0
18274  IF(mint(56).EQ.6) wid2=wids(6,1)
18275  IF(mint(56).EQ.7.OR.mint(56).EQ.8) wid2=wids(mint(56),1)
18276  IF(mint(56).EQ.17) wid2=wids(17,1)
18277  facff=facff*wid2
18278  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
18279  nchn=nchn+1
18280  isig(nchn,1)=22
18281  isig(nchn,2)=22
18282  isig(nchn,3)=1
18283  sigh(nchn)=facff
18284  ENDIF
18285 
18286  ELSEIF(isub.EQ.86) THEN
18287 C...g + g -> J/Psi + g
18288  facqqg=comfac*as**3*(5d0/9d0)*parp(38)*sqrt(sqm3)*
18289  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
18290  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
18291  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
18292  nchn=nchn+1
18293  isig(nchn,1)=21
18294  isig(nchn,2)=21
18295  isig(nchn,3)=1
18296  sigh(nchn)=facqqg
18297  ENDIF
18298 
18299  ELSEIF(isub.EQ.87) THEN
18300 C...g + g -> chi_0c + g
18301  pgtw=(sh*th+th*uh+uh*sh)/sh2
18302  qgtw=(sh*th*uh)/sh**3
18303  rgtw=sqm3/sh
18304  facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
18305  & (9d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
18306  & 6d0*rgtw*pgtw**3*qgtw*(2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)-
18307  & pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)+
18308  & 2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)+6d0*rgtw**2*qgtw**4)/
18309  & (qgtw*(qgtw-rgtw*pgtw)**4)
18310  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
18311  nchn=nchn+1
18312  isig(nchn,1)=21
18313  isig(nchn,2)=21
18314  isig(nchn,3)=1
18315  sigh(nchn)=facqqg
18316  ENDIF
18317 
18318  ELSEIF(isub.EQ.88) THEN
18319 C...g + g -> chi_1c + g
18320  pgtw=(sh*th+th*uh+uh*sh)/sh2
18321  qgtw=(sh*th*uh)/sh**3
18322  rgtw=sqm3/sh
18323  facqqg=comfac*as**3*12d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
18324  & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)+2d0*qgtw*(-rgtw**4+
18325  & 5d0*rgtw**2*pgtw+pgtw**2)-15d0*rgtw*qgtw**2)/
18326  & (qgtw-rgtw*pgtw)**4
18327  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
18328  nchn=nchn+1
18329  isig(nchn,1)=21
18330  isig(nchn,2)=21
18331  isig(nchn,3)=1
18332  sigh(nchn)=facqqg
18333  ENDIF
18334 
18335  ELSEIF(isub.EQ.89) THEN
18336 C...g + g -> chi_2c + g
18337  pgtw=(sh*th+th*uh+uh*sh)/sh2
18338  qgtw=(sh*th*uh)/sh**3
18339  rgtw=sqm3/sh
18340  facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
18341  & (12d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
18342  & 3d0*rgtw*pgtw**3*qgtw*(8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)+
18343  & 2d0*pgtw**2*qgtw**2*(-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)+
18344  & rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)+12d0*rgtw**2*
18345  & qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
18346  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
18347  nchn=nchn+1
18348  isig(nchn,1)=21
18349  isig(nchn,2)=21
18350  isig(nchn,3)=1
18351  sigh(nchn)=facqqg
18352  ENDIF
18353  ENDIF
18354 
18355 C...D: Mimimum bias processes
18356 
18357  ELSEIF(isub.LE.100) THEN
18358  IF(isub.EQ.91) THEN
18359 C...Elastic scattering
18360  sigs=sigt(0,0,1)
18361 
18362  ELSEIF(isub.EQ.92) THEN
18363 C...Single diffractive scattering (first side, i.e. XB)
18364  sigs=sigt(0,0,2)
18365 
18366  ELSEIF(isub.EQ.93) THEN
18367 C...Single diffractive scattering (second side, i.e. AX)
18368  sigs=sigt(0,0,3)
18369 
18370  ELSEIF(isub.EQ.94) THEN
18371 C...Double diffractive scattering
18372  sigs=sigt(0,0,4)
18373 
18374  ELSEIF(isub.EQ.95) THEN
18375 C...Low-pT scattering
18376  sigs=sigt(0,0,5)
18377 
18378  ELSEIF(isub.EQ.96) THEN
18379 C...Multiple interactions: sum of QCD processes
18380  CALL pywidt(21,sh,wdtp,wdte)
18381 
18382 C...q + q' -> q + q'
18383  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
18384  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
18385  & mstp(34)*2d0/3d0*uh2/(sh*th))
18386  facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-
18387  & mstp(34)*2d0/3d0*sh2/(th*uh))
18388  DO 1040 i=-3,3
18389  IF(i.EQ.0) goto 1040
18390  DO 1030 j=-3,3
18391  IF(j.EQ.0) goto 1030
18392  nchn=nchn+1
18393  isig(nchn,1)=i
18394  isig(nchn,2)=j
18395  isig(nchn,3)=111
18396  sigh(nchn)=facqq1
18397  IF(i.EQ.-j) sigh(nchn)=facqqb
18398  IF(i.EQ.j) THEN
18399  sigh(nchn)=0.5d0*sigh(nchn)
18400  nchn=nchn+1
18401  isig(nchn,1)=i
18402  isig(nchn,2)=j
18403  isig(nchn,3)=112
18404  sigh(nchn)=0.5d0*facqq2
18405  ENDIF
18406  1030 CONTINUE
18407  1040 CONTINUE
18408 
18409 C...q + qbar -> q' + qbar' or g + g
18410  facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
18411  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))
18412  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
18413  & uh2/sh2)
18414  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
18415  & th2/sh2)
18416  DO 1050 i=-3,3
18417  IF(i.EQ.0) goto 1050
18418  nchn=nchn+1
18419  isig(nchn,1)=i
18420  isig(nchn,2)=-i
18421  isig(nchn,3)=121
18422  sigh(nchn)=facqqb
18423  nchn=nchn+1
18424  isig(nchn,1)=i
18425  isig(nchn,2)=-i
18426  isig(nchn,3)=131
18427  sigh(nchn)=0.5d0*facgg1
18428  nchn=nchn+1
18429  isig(nchn,1)=i
18430  isig(nchn,2)=-i
18431  isig(nchn,3)=132
18432  sigh(nchn)=0.5d0*facgg2
18433  1050 CONTINUE
18434 
18435 C...q + g -> q + g
18436  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
18437  & uh/sh)*faca
18438  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
18439  & sh/uh)
18440  DO 1070 i=-3,3
18441  IF(i.EQ.0) goto 1070
18442  DO 1060 isde=1,2
18443  nchn=nchn+1
18444  isig(nchn,isde)=i
18445  isig(nchn,3-isde)=21
18446  isig(nchn,3)=281
18447  sigh(nchn)=facqg1
18448  nchn=nchn+1
18449  isig(nchn,isde)=i
18450  isig(nchn,3-isde)=21
18451  isig(nchn,3)=282
18452  sigh(nchn)=facqg2
18453  1060 CONTINUE
18454  1070 CONTINUE
18455 
18456 C...g + g -> q + qbar or g + g
18457  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
18458  & uh2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
18459  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
18460  & th2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca
18461  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
18462  & 2d0*th/sh+th2/sh2)*faca
18463  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
18464  & 2d0*sh/uh+sh2/uh2)*faca
18465  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3+
18466  & 2d0*uh/th+uh2/th2)
18467  nchn=nchn+1
18468  isig(nchn,1)=21
18469  isig(nchn,2)=21
18470  isig(nchn,3)=531
18471  sigh(nchn)=facqq1
18472  nchn=nchn+1
18473  isig(nchn,1)=21
18474  isig(nchn,2)=21
18475  isig(nchn,3)=532
18476  sigh(nchn)=facqq2
18477  nchn=nchn+1
18478  isig(nchn,1)=21
18479  isig(nchn,2)=21
18480  isig(nchn,3)=681
18481  sigh(nchn)=0.5d0*facgg1
18482  nchn=nchn+1
18483  isig(nchn,1)=21
18484  isig(nchn,2)=21
18485  isig(nchn,3)=682
18486  sigh(nchn)=0.5d0*facgg2
18487  nchn=nchn+1
18488  isig(nchn,1)=21
18489  isig(nchn,2)=21
18490  isig(nchn,3)=683
18491  sigh(nchn)=0.5d0*facgg3
18492  ENDIF
18493 
18494 C...E: 2 -> 1, loop diagrams
18495 
18496  ELSEIF(isub.LE.110) THEN
18497  IF(isub.EQ.101) THEN
18498 C...g + g -> gamma*/Z0
18499 
18500  ELSEIF(isub.EQ.102) THEN
18501 C...g + g -> h0 (or H0, or A0)
18502  CALL pywidt(kfhigg,sh,wdtp,wdte)
18503  hs=shr*wdtp(0)
18504  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
18505  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
18506  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
18507  & facbw=0d0
18508  hi=shr*wdtp(13)/32d0
18509  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1080
18510  nchn=nchn+1
18511  isig(nchn,1)=21
18512  isig(nchn,2)=21
18513  isig(nchn,3)=1
18514  sigh(nchn)=hi*facbw*hf
18515  1080 CONTINUE
18516 
18517  ELSEIF(isub.EQ.103) THEN
18518 C...gamma + gamma -> h0 (or H0, or A0)
18519  CALL pywidt(kfhigg,sh,wdtp,wdte)
18520  hs=shr*wdtp(0)
18521  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
18522  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
18523  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
18524  & facbw=0d0
18525  hi=shr*wdtp(14)*2d0
18526  IF(kfac(1,22)*kfac(2,22).EQ.0) goto 1090
18527  nchn=nchn+1
18528  isig(nchn,1)=22
18529  isig(nchn,2)=22
18530  isig(nchn,3)=1
18531  sigh(nchn)=hi*facbw*hf
18532  1090 CONTINUE
18533 
18534 C...F: 2 -> 2, box diagrams
18535 
18536  ELSEIF(isub.EQ.110) THEN
18537 C...f + fbar -> gamma + h0
18538  thuh=max(th*uh,sh*ckin(3)**2)
18539  fachg=comfac*(3d0*aem**4)/(2d0*paru(1)**2*xw*sqmw)*sh*thuh
18540  fachg=fachg*wids(kfhigg,2)
18541 C...Calculate loop contributions for intermediate gamma* and Z0
18542  cigtot=cmplx(0.,0.)
18543  ciztot=cmplx(0.,0.)
18544  jmax=3*mstp(1)+1
18545  DO 1100 j=1,jmax
18546  IF(j.LE.2*mstp(1)) THEN
18547  fnc=1d0
18548  ej=kchg(j,1)/3d0
18549  aj=sign(1d0,ej+0.1d0)
18550  vj=aj-4d0*ej*xwv
18551  balp=sqm4/(2d0*pmas(j,1))**2
18552  bbet=sh/(2d0*pmas(j,1))**2
18553  ELSEIF(j.LE.3*mstp(1)) THEN
18554  fnc=3d0
18555  jl=2*(j-2*mstp(1))-1
18556  ej=kchg(10+jl,1)/3d0
18557  aj=sign(1d0,ej+0.1d0)
18558  vj=aj-4d0*ej*xwv
18559  balp=sqm4/(2d0*pmas(10+jl,1))**2
18560  bbet=sh/(2d0*pmas(10+jl,1))**2
18561  ELSE
18562  balp=sqm4/(2d0*pmas(24,1))**2
18563  bbet=sh/(2d0*pmas(24,1))**2
18564  ENDIF
18565  babi=1d0/(balp-bbet)
18566  IF(balp.LT.1d0) THEN
18567  f0alp=cmplx(sngl(asin(sqrt(balp))),0.)
18568  f1alp=f0alp**2
18569  ELSE
18570  f0alp=cmplx(sngl(log(sqrt(balp)+sqrt(balp-1d0))),
18571  & -sngl(0.5d0*paru(1)))
18572  f1alp=-f0alp**2
18573  ENDIF
18574  f2alp=sngl(sqrt(abs(balp-1d0)/balp))*f0alp
18575  IF(bbet.LT.1d0) THEN
18576  f0bet=cmplx(sngl(asin(sqrt(bbet))),0.)
18577  f1bet=f0bet**2
18578  ELSE
18579  f0bet=cmplx(sngl(log(sqrt(bbet)+sqrt(bbet-1d0))),
18580  & -sngl(0.5d0*paru(1)))
18581  f1bet=-f0bet**2
18582  ENDIF
18583  f2bet=sngl(sqrt(abs(bbet-1d0)/bbet))*f0bet
18584  IF(j.LE.3*mstp(1)) THEN
18585  fif=sngl(0.5d0*babi)+sngl(babi**2)*(sngl(0.5d0*(1d0-balp+
18586  & bbet))*(f1bet-f1alp)+sngl(bbet)*(f2bet-f2alp))
18587  cigtot=cigtot+sngl(fnc*ej**2)*fif
18588  ciztot=ciztot+sngl(fnc*ej*vj)*fif
18589  ELSE
18590  txw=xw/xw1
18591  cigtot=cigtot-0.5*(sngl(babi*(1.5d0+balp))+sngl(babi**2)*
18592  & (sngl(1.5d0-3d0*balp+4d0*bbet)*(f1bet-f1alp)+
18593  & sngl(bbet*(2d0*balp+3d0))*(f2bet-f2alp)))
18594  ciztot=ciztot-sngl(0.5d0*babi*xw1)*(sngl(5d0-txw+2d0*balp*
18595  & (1d0-txw))*(1.+sngl(2d0*babi*bbet)*(f2bet-f2alp))+
18596  & sngl(babi*(4d0*bbet*(3d0-txw)-(2d0*balp-1d0)*(5d0-txw)))*
18597  & (f1bet-f1alp))
18598  ENDIF
18599  1100 CONTINUE
18600  cigtot=cigtot/sngl(sh)
18601  ciztot=ciztot*sngl(xwc)/cmplx(sngl(sh-sqmz),sngl(gmmz))
18602 C...Loop over initial flavours
18603  DO 1110 i=mmina,mmaxa
18604  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1110
18605  ei=kchg(iabs(i),1)/3d0
18606  ai=sign(1d0,ei)
18607  vi=ai-4d0*ei*xwv
18608  fcoi=1d0
18609  IF(iabs(i).LE.10) fcoi=faca/3d0
18610  nchn=nchn+1
18611  isig(nchn,1)=i
18612  isig(nchn,2)=-i
18613  isig(nchn,3)=1
18614  sigh(nchn)=fachg*fcoi*(abs(sngl(ei)*cigtot+sngl(vi)*
18615  & ciztot)**2+ai**2*abs(ciztot)**2)
18616  1110 CONTINUE
18617 
18618  ENDIF
18619 
18620  ELSEIF(isub.LE.120) THEN
18621  IF(isub.EQ.111) THEN
18622 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
18623  a5stur=0d0
18624  a5stui=0d0
18625  DO 1120 i=1,2*mstp(1)
18626  sqmq=pmas(i,1)**2
18627  epss=4d0*sqmq/sh
18628  epsh=4d0*sqmq/sqmh
18629  CALL pywaux(1,epss,w1sr,w1si)
18630  CALL pywaux(1,epsh,w1hr,w1hi)
18631  CALL pywaux(2,epss,w2sr,w2si)
18632  CALL pywaux(2,epsh,w2hr,w2hi)
18633  a5stur=a5stur+epsh*(1d0+sh/(th+uh)*(w1sr-w1hr)+
18634  & (0.25d0-sqmq/(th+uh))*(w2sr-w2hr))
18635  a5stui=a5stui+epsh*(sh/(th+uh)*(w1si-w1hi)+
18636  & (0.25d0-sqmq/(th+uh))*(w2si-w2hi))
18637  1120 CONTINUE
18638  facgh=comfac*faca/(144d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
18639  & sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)
18640  facgh=facgh*wids(25,2)
18641  DO 1130 i=mmina,mmaxa
18642  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
18643  & kfac(1,i)*kfac(2,-i).EQ.0) goto 1130
18644  nchn=nchn+1
18645  isig(nchn,1)=i
18646  isig(nchn,2)=-i
18647  isig(nchn,3)=1
18648  sigh(nchn)=facgh
18649  1130 CONTINUE
18650 
18651  ELSEIF(isub.EQ.112) THEN
18652 C...f + g -> f + h0 (q + g -> q + h0 only)
18653  a5tsur=0d0
18654  a5tsui=0d0
18655  DO 1140 i=1,2*mstp(1)
18656  sqmq=pmas(i,1)**2
18657  epst=4d0*sqmq/th
18658  epsh=4d0*sqmq/sqmh
18659  CALL pywaux(1,epst,w1tr,w1ti)
18660  CALL pywaux(1,epsh,w1hr,w1hi)
18661  CALL pywaux(2,epst,w2tr,w2ti)
18662  CALL pywaux(2,epsh,w2hr,w2hi)
18663  a5tsur=a5tsur+epsh*(1d0+th/(sh+uh)*(w1tr-w1hr)+
18664  & (0.25d0-sqmq/(sh+uh))*(w2tr-w2hr))
18665  a5tsui=a5tsui+epsh*(th/(sh+uh)*(w1ti-w1hi)+
18666  & (0.25d0-sqmq/(sh+uh))*(w2ti-w2hi))
18667  1140 CONTINUE
18668  facqh=comfac*faca/(384d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
18669  & sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)
18670  facqh=facqh*wids(25,2)
18671  DO 1160 i=mmina,mmaxa
18672  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1160
18673  DO 1150 isde=1,2
18674  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1150
18675  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1150
18676  nchn=nchn+1
18677  isig(nchn,isde)=i
18678  isig(nchn,3-isde)=21
18679  isig(nchn,3)=1
18680  sigh(nchn)=facqh
18681  1150 CONTINUE
18682  1160 CONTINUE
18683 
18684  ELSEIF(isub.EQ.113) THEN
18685 C...g + g -> g + h0
18686  a2stur=0d0
18687  a2stui=0d0
18688  a2ustr=0d0
18689  a2usti=0d0
18690  a2tusr=0d0
18691  a2tusi=0d0
18692  a4stur=0d0
18693  a4stui=0d0
18694  DO 1170 i=1,2*mstp(1)
18695  sqmq=pmas(i,1)**2
18696  epss=4d0*sqmq/sh
18697  epst=4d0*sqmq/th
18698  epsu=4d0*sqmq/uh
18699  epsh=4d0*sqmq/sqmh
18700  IF(epsh.LT.1.d-6) goto 1170
18701  CALL pywaux(1,epss,w1sr,w1si)
18702  CALL pywaux(1,epst,w1tr,w1ti)
18703  CALL pywaux(1,epsu,w1ur,w1ui)
18704  CALL pywaux(1,epsh,w1hr,w1hi)
18705  CALL pywaux(2,epss,w2sr,w2si)
18706  CALL pywaux(2,epst,w2tr,w2ti)
18707  CALL pywaux(2,epsu,w2ur,w2ui)
18708  CALL pywaux(2,epsh,w2hr,w2hi)
18709  CALL pyi3au(epss,th/uh,y3stur,y3stui)
18710  CALL pyi3au(epss,uh/th,y3sutr,y3suti)
18711  CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
18712  CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
18713  CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
18714  CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
18715  CALL pyi3au(epsh,sqmh/sh*th/uh,yhstur,yhstui)
18716  CALL pyi3au(epsh,sqmh/sh*uh/th,yhsutr,yhsuti)
18717  CALL pyi3au(epsh,sqmh/th*sh/uh,yhtsur,yhtsui)
18718  CALL pyi3au(epsh,sqmh/th*uh/sh,yhtusr,yhtusi)
18719  CALL pyi3au(epsh,sqmh/uh*sh/th,yhustr,yhusti)
18720  CALL pyi3au(epsh,sqmh/uh*th/sh,yhutsr,yhutsi)
18721  w3stur=yhstur-y3stur-y3utsr
18722  w3stui=yhstui-y3stui-y3utsi
18723  w3sutr=yhsutr-y3sutr-y3tusr
18724  w3suti=yhsuti-y3suti-y3tusi
18725  w3tsur=yhtsur-y3tsur-y3ustr
18726  w3tsui=yhtsui-y3tsui-y3usti
18727  w3tusr=yhtusr-y3tusr-y3sutr
18728  w3tusi=yhtusi-y3tusi-y3suti
18729  w3ustr=yhustr-y3ustr-y3tsur
18730  w3usti=yhusti-y3usti-y3tsui
18731  w3utsr=yhutsr-y3utsr-y3stur
18732  w3utsi=yhutsi-y3utsi-y3stui
18733  b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2d0*th*uh*
18734  & (uh+2d0*sh)/(sh+uh)**2*(w1tr-w1hr)+(sqmq-sh/4d0)*
18735  & (0.5d0*w2sr+0.5d0*w2hr-w2tr+w3stur)+sh2*(2d0*sqmq/
18736  & (sh+uh)**2-0.5d0/(sh+uh))*(w2tr-w2hr)+0.5d0*th*uh/sh*
18737  & (w2hr-2d0*w2tr)+0.125d0*(sh-12d0*sqmq-4d0*th*uh/sh)*w3tsur)
18738  b2stui=sqmq/sqmh**2*(2d0*th*uh*(uh+2d0*sh)/(sh+uh)**2*
18739  & (w1ti-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ti+
18740  & w3stui)+sh2*(2d0*sqmq/(sh+uh)**2-0.5d0/(sh+uh))*
18741  & (w2ti-w2hi)+0.5d0*th*uh/sh*(w2hi-2d0*w2ti)+0.125d0*
18742  & (sh-12d0*sqmq-4d0*th*uh/sh)*w3tsui)
18743  b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2d0*uh*th*
18744  & (th+2d0*sh)/(sh+th)**2*(w1ur-w1hr)+(sqmq-sh/4d0)*
18745  & (0.5d0*w2sr+0.5d0*w2hr-w2ur+w3sutr)+sh2*(2d0*sqmq/
18746  & (sh+th)**2-0.5d0/(sh+th))*(w2ur-w2hr)+0.5d0*uh*th/sh*
18747  & (w2hr-2d0*w2ur)+0.125d0*(sh-12d0*sqmq-4d0*uh*th/sh)*w3ustr)
18748  b2suti=sqmq/sqmh**2*(2d0*uh*th*(th+2d0*sh)/(sh+th)**2*
18749  & (w1ui-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ui+
18750  & w3suti)+sh2*(2d0*sqmq/(sh+th)**2-0.5d0/(sh+th))*
18751  & (w2ui-w2hi)+0.5d0*uh*th/sh*(w2hi-2d0*w2ui)+0.125d0*
18752  & (sh-12d0*sqmq-4d0*uh*th/sh)*w3usti)
18753  b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2d0*sh*uh*
18754  & (uh+2d0*th)/(th+uh)**2*(w1sr-w1hr)+(sqmq-th/4d0)*
18755  & (0.5d0*w2tr+0.5d0*w2hr-w2sr+w3tsur)+th2*(2d0*sqmq/
18756  & (th+uh)**2-0.5d0/(th+uh))*(w2sr-w2hr)+0.5d0*sh*uh/th*
18757  & (w2hr-2d0*w2sr)+0.125d0*(th-12d0*sqmq-4d0*sh*uh/th)*w3stur)
18758  b2tsui=sqmq/sqmh**2*(2d0*sh*uh*(uh+2d0*th)/(th+uh)**2*
18759  & (w1si-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2si+
18760  & w3tsui)+th2*(2d0*sqmq/(th+uh)**2-0.5d0/(th+uh))*
18761  & (w2si-w2hi)+0.5d0*sh*uh/th*(w2hi-2d0*w2si)+0.125d0*
18762  & (th-12d0*sqmq-4d0*sh*uh/th)*w3stui)
18763  b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2d0*uh*sh*
18764  & (sh+2d0*th)/(th+sh)**2*(w1ur-w1hr)+(sqmq-th/4d0)*
18765  & (0.5d0*w2tr+0.5d0*w2hr-w2ur+w3tusr)+th2*(2d0*sqmq/
18766  & (th+sh)**2-0.5d0/(th+sh))*(w2ur-w2hr)+0.5d0*uh*sh/th*
18767  & (w2hr-2d0*w2ur)+0.125d0*(th-12d0*sqmq-4d0*uh*sh/th)*w3utsr)
18768  b2tusi=sqmq/sqmh**2*(2d0*uh*sh*(sh+2d0*th)/(th+sh)**2*
18769  & (w1ui-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2ui+
18770  & w3tusi)+th2*(2d0*sqmq/(th+sh)**2-0.5d0/(th+sh))*
18771  & (w2ui-w2hi)+0.5d0*uh*sh/th*(w2hi-2d0*w2ui)+0.125d0*
18772  & (th-12d0*sqmq-4d0*uh*sh/th)*w3utsi)
18773  b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2d0*sh*th*
18774  & (th+2d0*uh)/(uh+th)**2*(w1sr-w1hr)+(sqmq-uh/4d0)*
18775  & (0.5d0*w2ur+0.5d0*w2hr-w2sr+w3ustr)+uh2*(2d0*sqmq/
18776  & (uh+th)**2-0.5d0/(uh+th))*(w2sr-w2hr)+0.5d0*sh*th/uh*
18777  & (w2hr-2d0*w2sr)+0.125d0*(uh-12d0*sqmq-4d0*sh*th/uh)*w3sutr)
18778  b2usti=sqmq/sqmh**2*(2d0*sh*th*(th+2d0*uh)/(uh+th)**2*
18779  & (w1si-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2si+
18780  & w3usti)+uh2*(2d0*sqmq/(uh+th)**2-0.5d0/(uh+th))*
18781  & (w2si-w2hi)+0.5d0*sh*th/uh*(w2hi-2d0*w2si)+0.125d0*
18782  & (uh-12d0*sqmq-4d0*sh*th/uh)*w3suti)
18783  b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2d0*th*sh*
18784  & (sh+2d0*uh)/(uh+sh)**2*(w1tr-w1hr)+(sqmq-uh/4d0)*
18785  & (0.5d0*w2ur+0.5d0*w2hr-w2tr+w3utsr)+uh2*(2d0*sqmq/
18786  & (uh+sh)**2-0.5d0/(uh+sh))*(w2tr-w2hr)+0.5d0*th*sh/uh*
18787  & (w2hr-2d0*w2tr)+0.125d0*(uh-12d0*sqmq-4d0*th*sh/uh)*w3tusr)
18788  b2utsi=sqmq/sqmh**2*(2d0*th*sh*(sh+2d0*uh)/(uh+sh)**2*
18789  & (w1ti-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2ti+
18790  & w3utsi)+uh2*(2d0*sqmq/(uh+sh)**2-0.5d0/(uh+sh))*
18791  & (w2ti-w2hi)+0.5d0*th*sh/uh*(w2hi-2d0*w2ti)+0.125d0*
18792  & (uh-12d0*sqmq-4d0*th*sh/uh)*w3tusi)
18793  b4stur=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
18794  & (w2sr-w2hr+w3stur))
18795  b4stui=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2si-w2hi+w3stui)
18796  b4tusr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
18797  & (w2tr-w2hr+w3tusr))
18798  b4tusi=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ti-w2hi+w3tusi)
18799  b4ustr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
18800  & (w2ur-w2hr+w3ustr))
18801  b4usti=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ui-w2hi+w3usti)
18802  a2stur=a2stur+b2stur+b2sutr
18803  a2stui=a2stui+b2stui+b2suti
18804  a2ustr=a2ustr+b2ustr+b2utsr
18805  a2usti=a2usti+b2usti+b2utsi
18806  a2tusr=a2tusr+b2tusr+b2tsur
18807  a2tusi=a2tusi+b2tusi+b2tsui
18808  a4stur=a4stur+b4stur+b4ustr+b4tusr
18809  a4stui=a4stui+b4stui+b4usti+b4tusi
18810  1170 CONTINUE
18811  facgh=comfac*faca*3d0/(128d0*paru(1)**2)*aem/xw*as**3*
18812  & sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+
18813  & a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)
18814  facgh=facgh*wids(25,2)
18815  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1180
18816  nchn=nchn+1
18817  isig(nchn,1)=21
18818  isig(nchn,2)=21
18819  isig(nchn,3)=1
18820  sigh(nchn)=facgh
18821  1180 CONTINUE
18822 
18823  ELSEIF(isub.EQ.114.OR.isub.EQ.115) THEN
18824 C...g + g -> gamma + gamma or g + g -> g + gamma
18825  a0stur=0d0
18826  a0stui=0d0
18827  a0tsur=0d0
18828  a0tsui=0d0
18829  a0utsr=0d0
18830  a0utsi=0d0
18831  a1stur=0d0
18832  a1stui=0d0
18833  a2stur=0d0
18834  a2stui=0d0
18835  alst=log(-sh/th)
18836  alsu=log(-sh/uh)
18837  altu=log(th/uh)
18838  imax=2*mstp(1)
18839  IF(mstp(38).GE.1.AND.mstp(38).LE.8) imax=mstp(38)
18840  DO 1190 i=1,imax
18841  ei=kchg(iabs(i),1)/3d0
18842  eiwt=ei**2
18843  IF(isub.EQ.115) eiwt=ei
18844  sqmq=pmas(i,1)**2
18845  epss=4d0*sqmq/sh
18846  epst=4d0*sqmq/th
18847  epsu=4d0*sqmq/uh
18848  IF((mstp(38).GE.1.AND.mstp(38).LE.8).OR.epss.LT.1.d-4) THEN
18849  b0stur=1d0+(th-uh)/sh*altu+0.5d0*(th2+uh2)/sh2*(altu**2+
18850  & paru(1)**2)
18851  b0stui=0d0
18852  b0tsur=1d0+(sh-uh)/th*alsu+0.5d0*(sh2+uh2)/th2*alsu**2
18853  b0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*alsu)
18854  b0utsr=1d0+(sh-th)/uh*alst+0.5d0*(sh2+th2)/uh2*alst**2
18855  b0utsi=-paru(1)*((sh-th)/uh+(sh2+th2)/uh2*alst)
18856  b1stur=-1d0
18857  b1stui=0d0
18858  b2stur=-1d0
18859  b2stui=0d0
18860  ELSE
18861  CALL pywaux(1,epss,w1sr,w1si)
18862  CALL pywaux(1,epst,w1tr,w1ti)
18863  CALL pywaux(1,epsu,w1ur,w1ui)
18864  CALL pywaux(2,epss,w2sr,w2si)
18865  CALL pywaux(2,epst,w2tr,w2ti)
18866  CALL pywaux(2,epsu,w2ur,w2ui)
18867  CALL pyi3au(epss,th/uh,y3stur,y3stui)
18868  CALL pyi3au(epss,uh/th,y3sutr,y3suti)
18869  CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
18870  CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
18871  CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
18872  CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
18873  b0stur=1d0+(1d0+2d0*th/sh)*w1tr+(1d0+2d0*uh/sh)*w1ur+
18874  & 0.5d0*((th2+uh2)/sh2-epss)*(w2tr+w2ur)-
18875  & 0.25d0*epst*(1d0-0.5d0*epss)*(y3sutr+y3tusr)-
18876  & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stur+y3utsr)+
18877  & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
18878  & 0.5d0*epst*epsu)*(y3tsur+y3ustr)
18879  b0stui=(1d0+2d0*th/sh)*w1ti+(1d0+2d0*uh/sh)*w1ui+
18880  & 0.5d0*((th2+uh2)/sh2-epss)*(w2ti+w2ui)-
18881  & 0.25d0*epst*(1d0-0.5d0*epss)*(y3suti+y3tusi)-
18882  & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stui+y3utsi)+
18883  & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
18884  & 0.5d0*epst*epsu)*(y3tsui+y3usti)
18885  b0tsur=1d0+(1d0+2d0*sh/th)*w1sr+(1d0+2d0*uh/th)*w1ur+
18886  & 0.5d0*((sh2+uh2)/th2-epst)*(w2sr+w2ur)-
18887  & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusr+y3sutr)-
18888  & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsur+y3ustr)+
18889  & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
18890  & 0.5d0*epss*epsu)*(y3stur+y3utsr)
18891  b0tsui=(1d0+2d0*sh/th)*w1si+(1d0+2d0*uh/th)*w1ui+
18892  & 0.5d0*((sh2+uh2)/th2-epst)*(w2si+w2ui)-
18893  & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusi+y3suti)-
18894  & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsui+y3usti)+
18895  & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
18896  & 0.5d0*epss*epsu)*(y3stui+y3utsi)
18897  b0utsr=1d0+(1d0+2d0*th/uh)*w1tr+(1d0+2d0*sh/uh)*w1sr+
18898  & 0.5d0*((th2+sh2)/uh2-epsu)*(w2tr+w2sr)-
18899  & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3ustr+y3tsur)-
18900  & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsr+y3stur)+
18901  & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
18902  & 0.5d0*epst*epss)*(y3tusr+y3sutr)
18903  b0utsi=(1d0+2d0*th/uh)*w1ti+(1d0+2d0*sh/uh)*w1si+
18904  & 0.5d0*((th2+sh2)/uh2-epsu)*(w2ti+w2si)-
18905  & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3usti+y3tsui)-
18906  & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsi+y3stui)+
18907  & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
18908  & 0.5d0*epst*epss)*(y3tusi+y3suti)
18909  b1stur=-1d0-0.25d0*(epss+epst+epsu)*(w2sr+w2tr+w2ur)+
18910  & 0.25d0*(epsu+0.5d0*epss*epst)*(y3sutr+y3tusr)+
18911  & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stur+y3utsr)+
18912  & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsur+y3ustr)
18913  b1stui=-0.25d0*(epss+epst+epsu)*(w2si+w2ti+w2ui)+
18914  & 0.25d0*(epsu+0.5d0*epss*epst)*(y3suti+y3tusi)+
18915  & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stui+y3utsi)+
18916  & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsui+y3usti)
18917  b2stur=-1d0+0.125d0*epss*epst*(y3sutr+y3tusr)+
18918  & 0.125d0*epss*epsu*(y3stur+y3utsr)+
18919  & 0.125d0*epst*epsu*(y3tsur+y3ustr)
18920  b2stui=0.125d0*epss*epst*(y3suti+y3tusi)+
18921  & 0.125d0*epss*epsu*(y3stui+y3utsi)+
18922  & 0.125d0*epst*epsu*(y3tsui+y3usti)
18923  ENDIF
18924  a0stur=a0stur+eiwt*b0stur
18925  a0stui=a0stui+eiwt*b0stui
18926  a0tsur=a0tsur+eiwt*b0tsur
18927  a0tsui=a0tsui+eiwt*b0tsui
18928  a0utsr=a0utsr+eiwt*b0utsr
18929  a0utsi=a0utsi+eiwt*b0utsi
18930  a1stur=a1stur+eiwt*b1stur
18931  a1stui=a1stui+eiwt*b1stui
18932  a2stur=a2stur+eiwt*b2stur
18933  a2stui=a2stui+eiwt*b2stui
18934  1190 CONTINUE
18935  asqsum=a0stur**2+a0stui**2+a0tsur**2+a0tsui**2+a0utsr**2+
18936  & a0utsi**2+4d0*a1stur**2+4d0*a1stui**2+a2stur**2+a2stui**2
18937  facgg=comfac*faca/(16d0*paru(1)**2)*as**2*aem**2*asqsum
18938  facgp=comfac*faca*5d0/(192d0*paru(1)**2)*as**3*aem*asqsum
18939  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1200
18940  nchn=nchn+1
18941  isig(nchn,1)=21
18942  isig(nchn,2)=21
18943  isig(nchn,3)=1
18944  IF(isub.EQ.114) sigh(nchn)=0.5d0*facgg
18945  IF(isub.EQ.115) sigh(nchn)=facgp
18946  1200 CONTINUE
18947 
18948  ELSEIF(isub.EQ.116) THEN
18949 C...g + g -> gamma + Z0
18950 
18951  ELSEIF(isub.EQ.117) THEN
18952 C...g + g -> Z0 + Z0
18953 
18954  ELSEIF(isub.EQ.118) THEN
18955 C...g + g -> W+ + W-
18956 
18957  ENDIF
18958 
18959 C...G: 2 -> 3, tree diagrams
18960 
18961  ELSEIF(isub.LE.140) THEN
18962  IF(isub.EQ.121) THEN
18963 C...g + g -> Q + Qbar + h0
18964  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1210
18965  ia=kfpr(isubsv,2)
18966  pmf=pmas(ia,1)
18967  facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
18968  & (0.5d0*pmf/pmas(24,1))**2
18969  IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) facqqh=
18970  & facqqh*(log(max(4d0,parp(37)**2*pmf**2/paru(117)**2))/
18971  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
18972  wid2=1d0
18973  IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
18974  facqqh=facqqh*wid2
18975  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
18976  ikfi=1
18977  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
18978  IF(ia.GT.10) ikfi=3
18979  facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
18980  ENDIF
18981  CALL pyqqbh(wtqqbh)
18982  CALL pywidt(kfhigg,sh,wdtp,wdte)
18983  hs=shr*wdtp(0)
18984  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
18985  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
18986  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
18987  & facbw=0d0
18988  nchn=nchn+1
18989  isig(nchn,1)=21
18990  isig(nchn,2)=21
18991  isig(nchn,3)=1
18992  sigh(nchn)=facqqh*wtqqbh*facbw
18993  1210 CONTINUE
18994 
18995  ELSEIF(isub.EQ.122) THEN
18996 C...q + qbar -> Q + Qbar + h0
18997  ia=kfpr(isubsv,2)
18998  pmf=pmas(ia,1)
18999  facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
19000  & (0.5d0*pmf/pmas(24,1))**2
19001  IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) facqqh=
19002  & facqqh*(log(max(4d0,parp(37)**2*pmf**2/paru(117)**2))/
19003  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
19004  wid2=1d0
19005  IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
19006  facqqh=facqqh*wid2
19007  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
19008  ikfi=1
19009  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
19010  IF(ia.GT.10) ikfi=3
19011  facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
19012  ENDIF
19013  CALL pyqqbh(wtqqbh)
19014  CALL pywidt(kfhigg,sh,wdtp,wdte)
19015  hs=shr*wdtp(0)
19016  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19017  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
19018  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
19019  & facbw=0d0
19020  DO 1220 i=mmina,mmaxa
19021  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
19022  & kfac(1,i)*kfac(2,-i).EQ.0) goto 1220
19023  nchn=nchn+1
19024  isig(nchn,1)=i
19025  isig(nchn,2)=-i
19026  isig(nchn,3)=1
19027  sigh(nchn)=facqqh*wtqqbh*facbw
19028  1220 CONTINUE
19029 
19030  ELSEIF(isub.EQ.123) THEN
19031 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
19032 C...inner process)
19033  facnor=comfac*(4d0*paru(1)*aem/(xw*xw1))**3*sqmz/32d0
19034  IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
19035  & paru(154+10*ihigg)**2
19036  facprp=1d0/((vint(215)-vint(204)**2)*
19037  & (vint(216)-vint(209)**2))**2
19038  faczz1=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
19039  faczz2=facnor*facprp*vint(217)*vint(218)
19040  CALL pywidt(kfhigg,sh,wdtp,wdte)
19041  hs=shr*wdtp(0)
19042  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19043  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
19044  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
19045  & facbw=0d0
19046  DO 1240 i=mmin1,mmax1
19047  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1240
19048  ia=iabs(i)
19049  DO 1230 j=mmin2,mmax2
19050  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1230
19051  ja=iabs(j)
19052  ei=kchg(ia,1)*isign(1,i)/3d0
19053  ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
19054  vi=ai-4d0*ei*xwv
19055  ej=kchg(ja,1)*isign(1,j)/3d0
19056  aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
19057  vj=aj-4d0*ej*xwv
19058  faclr1=(vi**2+ai**2)*(vj**2+aj**2)+4d0*vi*ai*vj*aj
19059  faclr2=(vi**2+ai**2)*(vj**2+aj**2)-4d0*vi*ai*vj*aj
19060  nchn=nchn+1
19061  isig(nchn,1)=i
19062  isig(nchn,2)=j
19063  isig(nchn,3)=1
19064  sigh(nchn)=(faclr1*faczz1+faclr2*faczz2)*facbw
19065  1230 CONTINUE
19066  1240 CONTINUE
19067 
19068  ELSEIF(isub.EQ.124) THEN
19069 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
19070 C...inner process)
19071  facnor=comfac*(4d0*paru(1)*aem/xw)**3*sqmw
19072  IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
19073  & paru(155+10*ihigg)**2
19074  facprp=1d0/((vint(215)-vint(204)**2)*
19075  & (vint(216)-vint(209)**2))**2
19076  facww=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
19077  CALL pywidt(kfhigg,sh,wdtp,wdte)
19078  hs=shr*wdtp(0)
19079  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19080  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
19081  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
19082  & facbw=0d0
19083  DO 1260 i=mmin1,mmax1
19084  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1260
19085  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
19086  DO 1250 j=mmin2,mmax2
19087  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1250
19088  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
19089  IF(ei*ej.GT.0d0) goto 1250
19090  faclr=vint(180+i)*vint(180+j)
19091  nchn=nchn+1
19092  isig(nchn,1)=i
19093  isig(nchn,2)=j
19094  isig(nchn,3)=1
19095  sigh(nchn)=faclr*facww*facbw
19096  1250 CONTINUE
19097  1260 CONTINUE
19098 
19099  ELSEIF(isub.EQ.131) THEN
19100 C...g + g -> Z0 + q + qbar
19101 
19102  ENDIF
19103 
19104 C...H: 2 -> 1, tree diagrams, non-standard model processes
19105 
19106  ELSEIF(isub.LE.160) THEN
19107  IF(isub.EQ.141) THEN
19108 C...f + fbar -> gamma*/Z0/Z'0
19109  sqmzp=pmas(32,1)**2
19110  mint(61)=2
19111  CALL pywidt(32,sh,wdtp,wdte)
19112  hp0=aem/3d0*sh
19113  hp1=aem/3d0*xwc*sh
19114  hp2=hp1
19115  hs=shr*vint(117)
19116  hsp=shr*wdtp(0)
19117  faczp=4d0*comfac*3d0
19118  DO 1270 i=mmina,mmaxa
19119  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1270
19120  ei=kchg(iabs(i),1)/3d0
19121  ai=sign(1d0,ei)
19122  vi=ai-4d0*ei*xwv
19123  IF(iabs(i).LT.10) THEN
19124  vpi=paru(123-2*mod(iabs(i),2))
19125  api=paru(124-2*mod(iabs(i),2))
19126  ELSE
19127  vpi=paru(127-2*mod(iabs(i),2))
19128  api=paru(128-2*mod(iabs(i),2))
19129  ENDIF
19130  hi0=hp0
19131  IF(iabs(i).LE.10) hi0=hi0*faca/3d0
19132  hi1=hp1
19133  IF(iabs(i).LE.10) hi1=hi1*faca/3d0
19134  hi2=hp2
19135  IF(iabs(i).LE.10) hi2=hi2*faca/3d0
19136  nchn=nchn+1
19137  isig(nchn,1)=i
19138  isig(nchn,2)=-i
19139  isig(nchn,3)=1
19140  sigh(nchn)=faczp*(ei**2/sh2*hi0*hp0*vint(111)+ei*vi*
19141  & (1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*(hi0*hp1+hi1*hp0)*
19142  & vint(112)+ei*vpi*(1d0-sqmzp/sh)/((sh-sqmzp)**2+hsp**2)*
19143  & (hi0*hp2+hi2*hp0)*vint(113)+(vi**2+ai**2)/
19144  & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114)+(vi*vpi+ai*api)*
19145  & ((sh-sqmz)*(sh-sqmzp)+hs*hsp)/(((sh-sqmz)**2+hs**2)*
19146  & ((sh-sqmzp)**2+hsp**2))*(hi1*hp2+hi2*hp1)*vint(115)+
19147  & (vpi**2+api**2)/((sh-sqmzp)**2+hsp**2)*hi2*hp2*vint(116))
19148  1270 CONTINUE
19149 
19150  ELSEIF(isub.EQ.142) THEN
19151 C...f + fbar' -> W'+/-
19152  sqmwp=pmas(34,1)**2
19153  CALL pywidt(34,sh,wdtp,wdte)
19154  hs=shr*wdtp(0)
19155  facbw=4d0*comfac/((sh-sqmwp)**2+hs**2)*3d0
19156  hp=aem/(24d0*xw)*sh
19157  DO 1290 i=mmin1,mmax1
19158  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1290
19159  ia=iabs(i)
19160  DO 1280 j=mmin2,mmax2
19161  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1280
19162  ja=iabs(j)
19163  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1280
19164  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19165  & goto 1280
19166  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19167  hi=hp*(paru(133)**2+paru(134)**2)
19168  IF(ia.LE.10) hi=hp*(paru(131)**2+paru(132)**2)*
19169  & vckm((ia+1)/2,(ja+1)/2)*faca/3d0
19170  nchn=nchn+1
19171  isig(nchn,1)=i
19172  isig(nchn,2)=j
19173  isig(nchn,3)=1
19174  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
19175  sigh(nchn)=hi*facbw*hf
19176  1280 CONTINUE
19177  1290 CONTINUE
19178 
19179  ELSEIF(isub.EQ.143) THEN
19180 C...f + fbar' -> H+/-
19181  sqmhc=pmas(37,1)**2
19182  CALL pywidt(37,sh,wdtp,wdte)
19183  hs=shr*wdtp(0)
19184  facbw=4d0*comfac/((sh-sqmhc)**2+hs**2)
19185  hp=aem/(8d0*xw)*sh/sqmw*sh
19186  DO 1310 i=mmin1,mmax1
19187  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1310
19188  ia=iabs(i)
19189  im=(mod(ia,10)+1)/2
19190  DO 1300 j=mmin2,mmax2
19191  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1300
19192  ja=iabs(j)
19193  jm=(mod(ja,10)+1)/2
19194  IF(i*j.GT.0.OR.ia.EQ.ja.OR.im.NE.jm) goto 1300
19195  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19196  & goto 1300
19197  IF(mod(ia,2).EQ.0) THEN
19198  iu=ia
19199  il=ja
19200  ELSE
19201  iu=ja
19202  il=ia
19203  ENDIF
19204  rml=pmas(il,1)**2/sh
19205  rmu=pmas(iu,1)**2/sh
19206  IF(il.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) rml=
19207  & rml*(log(max(4d0,parp(37)**2*rml*sh/paru(117)**2))/
19208  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-
19209  & 2d0*mstu(118)))
19210  hi=hp*(rml*paru(141)**2+rmu/paru(141)**2)
19211  IF(ia.LE.10) hi=hi*faca/3d0
19212  kchhc=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19213  hf=shr*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
19214  nchn=nchn+1
19215  isig(nchn,1)=i
19216  isig(nchn,2)=j
19217  isig(nchn,3)=1
19218  sigh(nchn)=hi*facbw*hf
19219  1300 CONTINUE
19220  1310 CONTINUE
19221 
19222  ELSEIF(isub.EQ.144) THEN
19223 C...f + fbar' -> R
19224  sqmr=pmas(40,1)**2
19225  CALL pywidt(40,sh,wdtp,wdte)
19226  hs=shr*wdtp(0)
19227  facbw=4d0*comfac/((sh-sqmr)**2+hs**2)*3d0
19228  hp=aem/(12d0*xw)*sh
19229  DO 1330 i=mmin1,mmax1
19230  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1330
19231  ia=iabs(i)
19232  DO 1320 j=mmin2,mmax2
19233  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1320
19234  ja=iabs(j)
19235  IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) goto 1320
19236  hi=hp
19237  IF(ia.LE.10) hi=hi*faca/3d0
19238  hf=shr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))
19239  nchn=nchn+1
19240  isig(nchn,1)=i
19241  isig(nchn,2)=j
19242  isig(nchn,3)=1
19243  sigh(nchn)=hi*facbw*hf
19244  1320 CONTINUE
19245  1330 CONTINUE
19246 
19247  ELSEIF(isub.EQ.145) THEN
19248 C...q + l -> LQ (leptoquark)
19249  sqmlq=pmas(39,1)**2
19250  CALL pywidt(39,sh,wdtp,wdte)
19251  hs=shr*wdtp(0)
19252  facbw=4d0*comfac/((sh-sqmlq)**2+hs**2)
19253  IF(abs(shr-pmas(39,1)).GT.parp(48)*pmas(39,2)) facbw=0d0
19254  hp=aem/4d0*sh
19255  kflqq=kfdp(mdcy(39,2),1)
19256  kflql=kfdp(mdcy(39,2),2)
19257  DO 1350 i=mmin1,mmax1
19258  IF(kfac(1,i).EQ.0) goto 1350
19259  ia=iabs(i)
19260  IF(ia.NE.kflqq.AND.ia.NE.iabs(kflql)) goto 1350
19261  DO 1340 j=mmin2,mmax2
19262  IF(kfac(2,j).EQ.0) goto 1340
19263  ja=iabs(j)
19264  IF(ja.NE.kflqq.AND.ja.NE.iabs(kflql)) goto 1340
19265  IF(ja.EQ.ia) goto 1340
19266  IF(i*j.NE.kflqq*kflql) goto 1340
19267  IF(ia.EQ.kflqq) kchlq=isign(1,i)
19268  IF(ja.EQ.kflqq) kchlq=isign(1,j)
19269  hi=hp*paru(151)
19270  hf=shr*(wdte(0,1)+wdte(0,(5-kchlq)/2)+wdte(0,4))
19271  nchn=nchn+1
19272  isig(nchn,1)=i
19273  isig(nchn,2)=j
19274  isig(nchn,3)=1
19275  sigh(nchn)=hi*facbw*hf
19276  1340 CONTINUE
19277  1350 CONTINUE
19278 
19279  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
19280 C...d + g -> d* and u + g -> u* (excited quarks)
19281  kfqstr=kfpr(isub,1)
19282  kcqstr=pycomp(kfqstr)
19283  kfqexc=mod(kfqstr,kexcit)
19284  CALL pywidt(kfqstr,sh,wdtp,wdte)
19285  hs=shr*wdtp(0)
19286  facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
19287  facbw=facbw*as*paru(159)**2*sh/(3d0*paru(155)**2)
19288  IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
19289  & facbw=0d0
19290  hp=sh
19291  DO 1370 i=-kfqexc,kfqexc,2*kfqexc
19292  DO 1360 isde=1,2
19293  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1360
19294  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1360
19295  hi=hp
19296  IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19297  IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
19298  nchn=nchn+1
19299  isig(nchn,isde)=i
19300  isig(nchn,3-isde)=21
19301  isig(nchn,3)=1
19302  sigh(nchn)=hi*facbw*hf
19303  1360 CONTINUE
19304  1370 CONTINUE
19305 
19306  ELSEIF(isub.EQ.149) THEN
19307 C...g + g -> eta_techni
19308  CALL pywidt(38,sh,wdtp,wdte)
19309  hs=shr*wdtp(0)
19310  facbw=comfac*0.5d0/((sh-pmas(38,1)**2)**2+hs**2)
19311  IF(abs(shr-pmas(38,1)).GT.parp(48)*pmas(38,2)) facbw=0d0
19312  hp=sh
19313  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1380
19314  hi=hp*wdtp(3)
19315  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19316  nchn=nchn+1
19317  isig(nchn,1)=21
19318  isig(nchn,2)=21
19319  isig(nchn,3)=1
19320  sigh(nchn)=hi*facbw*hf
19321  1380 CONTINUE
19322 
19323  ENDIF
19324 
19325 C...I: 2 -> 2, tree diagrams, non-standard model processes
19326 
19327  ELSEIF(isub.LE.200) THEN
19328  IF(isub.EQ.161) THEN
19329 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
19330 C...(choice of only b and t to avoid kinematics problems)
19331  sqmhc=pmas(37,1)**2
19332  fhcq=comfac*faca*as*aem/xw*1d0/24
19333  DO 1400 i=mmina,mmaxa
19334  ia=iabs(i)
19335  IF(ia.NE.5) goto 1400
19336  sqml=pmas(ia,1)**2
19337  IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) sqml=sqml*
19338  & (log(max(4d0,parp(37)**2*sqml/paru(117)**2))/
19339  & log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))
19340  iua=ia+mod(ia,2)
19341  sqmq=pmas(iua,1)**2
19342  fachcq=fhcq*(sqml*paru(141)**2+sqmq/paru(141)**2)/sqmw*
19343  & (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+
19344  & 2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*
19345  & (sqmhc-sqmq-sh)/sh)
19346  kchhc=isign(1,kchg(ia,1)*isign(1,i))
19347  DO 1390 isde=1,2
19348  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1390
19349  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,1).EQ.0) goto 1390
19350  nchn=nchn+1
19351  isig(nchn,isde)=i
19352  isig(nchn,3-isde)=21
19353  isig(nchn,3)=1
19354  sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)
19355  1390 CONTINUE
19356  1400 CONTINUE
19357 
19358  ELSEIF(isub.EQ.162) THEN
19359 C...q + g -> LQ + lbar; LQ=leptoquark
19360  sqmlq=pmas(39,1)**2
19361  faclq=comfac*faca*paru(151)*(as*aem/6d0)*(-th/sh)*
19362  & (uh2+sqmlq**2)/(uh-sqmlq)**2
19363  kflqq=kfdp(mdcy(39,2),1)
19364  DO 1420 i=mmina,mmaxa
19365  IF(iabs(i).NE.kflqq) goto 1420
19366  kchlq=isign(1,i)
19367  DO 1410 isde=1,2
19368  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1410
19369  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1410
19370  nchn=nchn+1
19371  isig(nchn,isde)=i
19372  isig(nchn,3-isde)=21
19373  isig(nchn,3)=1
19374  sigh(nchn)=faclq*wids(39,(5-kchlq)/2)
19375  1410 CONTINUE
19376  1420 CONTINUE
19377 
19378  ELSEIF(isub.EQ.163) THEN
19379 C...g + g -> LQ + LQbar; LQ=leptoquark
19380  sqmlq=pmas(39,1)**2
19381  faclq=comfac*faca*wids(39,1)*(as**2/2d0)*
19382  & (7d0/48d0+3d0*(uh-th)**2/(16d0*sh2))*(1d0+2d0*sqmlq*th/
19383  & (th-sqmlq)**2+2d0*sqmlq*uh/(uh-sqmlq)**2+4d0*sqmlq**2/
19384  & ((th-sqmlq)*(uh-sqmlq)))
19385  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1430
19386  nchn=nchn+1
19387  isig(nchn,1)=21
19388  isig(nchn,2)=21
19389 C...Since don't know proper colour flow, randomize between alternatives
19390  isig(nchn,3)=int(1.5d0+pyr(0))
19391  sigh(nchn)=faclq
19392  1430 CONTINUE
19393 
19394  ELSEIF(isub.EQ.164) THEN
19395 C...q + qbar -> LQ + LQbar; LQ=leptoquark
19396  sqmlq=pmas(39,1)**2
19397  faclqa=comfac*wids(39,1)*(as**2/9d0)*
19398  & (sh*(sh-4d0*sqmlq)-(uh-th)**2)/sh2
19399  faclqs=comfac*wids(39,1)*((paru(151)**2*aem**2/8d0)*
19400  & (-sh*th-(sqmlq-th)**2)/th2+(paru(151)*aem*as/18d0)*
19401  & ((sqmlq-th)*(uh-th)+sh*(sqmlq+th))/(sh*th))
19402  kflqq=kfdp(mdcy(39,2),1)
19403  DO 1440 i=mmina,mmaxa
19404  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
19405  & kfac(1,i)*kfac(2,-i).EQ.0) goto 1440
19406  nchn=nchn+1
19407  isig(nchn,1)=i
19408  isig(nchn,2)=-i
19409  isig(nchn,3)=1
19410  sigh(nchn)=faclqa
19411  IF(iabs(i).EQ.kflqq) sigh(nchn)=faclqa+faclqs
19412  1440 CONTINUE
19413 
19414  ELSEIF(isub.EQ.165) THEN
19415 C...q + qbar -> l+ + l- (including contact term for compositeness)
19416  zratr=xwc*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
19417  zrati=xwc*sh*gmmz/((sh-sqmz)**2+gmmz**2)
19418  kff=iabs(kfpr(isub,1))
19419  ef=kchg(kff,1)/3d0
19420  af=sign(1d0,ef+0.1d0)
19421  vf=af-4d0*ef*xwv
19422  valf=vf+af
19423  varf=vf-af
19424  fcof=1d0
19425  IF(kff.LE.10) fcof=3d0
19426  wid2=1d0
19427  IF(kff.EQ.6) wid2=wids(6,1)
19428  IF(kff.EQ.7.OR.kff.EQ.8) wid2=wids(kff,1)
19429  IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
19430  DO 1450 i=mmina,mmaxa
19431  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1450
19432  ei=kchg(iabs(i),1)/3d0
19433  ai=sign(1d0,ei+0.1d0)
19434  vi=ai-4d0*ei*xwv
19435  vali=vi+ai
19436  vari=vi-ai
19437  fcoi=1d0
19438  IF(iabs(i).LE.10) fcoi=faca/3d0
19439  IF((mstp(5).EQ.1.AND.iabs(i).LE.2).OR.mstp(5).EQ.2) THEN
19440  fgza=(ei*ef+vali*valf*zratr+paru(156)*sh/
19441  & (aem*paru(155)**2))**2+(vali*valf*zrati)**2+
19442  & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
19443  ELSE
19444  fgza=(ei*ef+vali*valf*zratr)**2+(vali*valf*zrati)**2+
19445  & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
19446  ENDIF
19447  fgzb=(ei*ef+vali*varf*zratr)**2+(vali*varf*zrati)**2+
19448  & (ei*ef+vari*valf*zratr)**2+(vari*valf*zrati)**2
19449  fgzab=aem**2*(fgza*uh2/sh2+fgzb*th2/sh2)
19450  IF((mstp(5).EQ.3.AND.iabs(i).EQ.2).OR.(mstp(5).EQ.4.AND.
19451  & mod(iabs(i),2).EQ.0)) fgzab=fgzab+sh2/(2d0*paru(155)**4)
19452  nchn=nchn+1
19453  isig(nchn,1)=i
19454  isig(nchn,2)=-i
19455  isig(nchn,3)=1
19456  sigh(nchn)=comfac*fcoi*fcof*fgzab*wid2
19457  1450 CONTINUE
19458 
19459  ELSEIF(isub.EQ.166) THEN
19460 C...q + q'bar -> l + nu_l (including contact term for compositeness)
19461  wfac=(1d0/4d0)*(aem/xw)**2*uh2/((sh-sqmw)**2+gmmw**2)
19462  wcifac=wfac+sh2/(4d0*paru(155)**4)
19463  kff=iabs(kfpr(isub,1))
19464  fcof=1d0
19465  IF(kff.LE.10) fcof=3d0
19466  DO 1470 i=mmin1,mmax1
19467  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1470
19468  ia=iabs(i)
19469  DO 1460 j=mmin2,mmax2
19470  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1460
19471  ja=iabs(j)
19472  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1460
19473  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19474  & goto 1460
19475  fcoi=1d0
19476  IF(ia.LE.10) fcoi=vckm((ia+1)/2,(ja+1)/2)*faca/3d0
19477  wid2=1d0
19478  IF((i.GT.0.AND.mod(i,2).EQ.0).OR.(j.GT.0.AND.
19479  & mod(j,2).EQ.0)) THEN
19480  IF(kff.EQ.5) wid2=wids(6,2)
19481  IF(kff.EQ.7) wid2=wids(8,2)*wids(7,3)
19482  IF(kff.EQ.17) wid2=wids(18,2)*wids(17,3)
19483  ELSE
19484  IF(kff.EQ.5) wid2=wids(6,3)
19485  IF(kff.EQ.7) wid2=wids(8,3)*wids(7,2)
19486  IF(kff.EQ.17) wid2=wids(18,3)*wids(17,2)
19487  ENDIF
19488  nchn=nchn+1
19489  isig(nchn,1)=i
19490  isig(nchn,2)=j
19491  isig(nchn,3)=1
19492  sigh(nchn)=comfac*fcoi*fcof*wfac*wid2
19493  IF((mstp(5).EQ.3.AND.ia.LE.2.AND.ja.LE.2).OR.mstp(5).EQ.4)
19494  & sigh(nchn)=comfac*fcoi*fcof*wcifac*wid2
19495  1460 CONTINUE
19496  1470 CONTINUE
19497 
19498  ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
19499 C...d + g -> d* and u + g -> u* (excited quarks)
19500  kfqstr=kfpr(isub,2)
19501  kcqstr=pycomp(kfqstr)
19502  kfqexc=mod(kfqstr,kexcit)
19503  facqsa=comfac*(sh/paru(155)**2)**2*(1d0-sqm4/sh)
19504  facqsb=comfac*0.25d0*(sh/paru(155)**2)**2*(1d0-sqm4/sh)*
19505  & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
19506 C...Propagators: as simulated in PYOFSH and as desired
19507  gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
19508  hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
19509  CALL pywidt(kfqstr,sqm4,wdtp,wdte)
19510  gmmqc=sqrt(sqm4)*wdtp(0)
19511  hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
19512  facqsa=facqsa*hbw4c/hbw4
19513  facqsb=facqsb*hbw4c/hbw4
19514  DO 1490 i=mmin1,mmax1
19515  ia=iabs(i)
19516  IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) goto 1490
19517  DO 1480 j=mmin2,mmax2
19518  ja=iabs(j)
19519  IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) goto 1480
19520  IF(ia.EQ.kfqexc.AND.i.EQ.j) THEN
19521  nchn=nchn+1
19522  isig(nchn,1)=i
19523  isig(nchn,2)=j
19524  isig(nchn,3)=1
19525  sigh(nchn)=(4d0/3d0)*facqsa
19526  nchn=nchn+1
19527  isig(nchn,1)=i
19528  isig(nchn,2)=j
19529  isig(nchn,3)=2
19530  sigh(nchn)=(4d0/3d0)*facqsa
19531  ELSEIF((ia.EQ.kfqexc.OR.ja.EQ.kfqexc).AND.i*j.GT.0) THEN
19532  nchn=nchn+1
19533  isig(nchn,1)=i
19534  isig(nchn,2)=j
19535  isig(nchn,3)=1
19536  IF(ja.EQ.kfqexc) isig(nchn,3)=2
19537  sigh(nchn)=facqsa
19538  ELSEIF(ia.EQ.kfqexc.AND.i.EQ.-j) THEN
19539  nchn=nchn+1
19540  isig(nchn,1)=i
19541  isig(nchn,2)=j
19542  isig(nchn,3)=1
19543  sigh(nchn)=(8d0/3d0)*facqsb
19544  nchn=nchn+1
19545  isig(nchn,1)=i
19546  isig(nchn,2)=j
19547  isig(nchn,3)=2
19548  sigh(nchn)=(8d0/3d0)*facqsb
19549  ELSEIF(i.EQ.-j) THEN
19550  nchn=nchn+1
19551  isig(nchn,1)=i
19552  isig(nchn,2)=j
19553  isig(nchn,3)=1
19554  sigh(nchn)=facqsb
19555  nchn=nchn+1
19556  isig(nchn,1)=i
19557  isig(nchn,2)=j
19558  isig(nchn,3)=2
19559  sigh(nchn)=facqsb
19560  ELSEIF(ia.EQ.kfqexc.OR.ja.EQ.kfqexc) THEN
19561  nchn=nchn+1
19562  isig(nchn,1)=i
19563  isig(nchn,2)=j
19564  isig(nchn,3)=1
19565  IF(ja.EQ.kfqexc) isig(nchn,3)=2
19566  sigh(nchn)=facqsb
19567  ENDIF
19568  1480 CONTINUE
19569  1490 CONTINUE
19570 
19571  ELSEIF(isub.EQ.191) THEN
19572 C...q + qbar -> rho_tech0.
19573  sqmrht=pmas(54,1)**2
19574  CALL pywidt(54,sh,wdtp,wdte)
19575  hs=shr*wdtp(0)
19576  facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
19577  IF(abs(shr-pmas(54,1)).GT.parp(48)*pmas(54,2)) facbw=0d0
19578  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19579  alprht=2.91d0*(3d0/parp(144))
19580  hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)
19581  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
19582  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
19583  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
19584  DO 1500 i=mmina,mmaxa
19585  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1500
19586  ia=iabs(i)
19587  ei=kchg(iabs(i),1)/3d0
19588  ai=sign(1d0,ei+0.1d0)
19589  vi=ai-4d0*ei*xwv
19590  vali=0.5d0*(vi+ai)
19591  vari=0.5d0*(vi-ai)
19592  hi=hp*((ei+vali*bwzr)**2+(vali*bwzi)**2+
19593  & (ei+vari*bwzr)**2+(vari*bwzi)**2)
19594  IF(ia.LE.10) hi=hi*faca/3d0
19595  nchn=nchn+1
19596  isig(nchn,1)=i
19597  isig(nchn,2)=-i
19598  isig(nchn,3)=1
19599  sigh(nchn)=hi*facbw*hf
19600  1500 CONTINUE
19601 
19602  ELSEIF(isub.EQ.192) THEN
19603 C...q + qbar' -> rho_tech+/-.
19604  sqmrht=pmas(55,1)**2
19605  CALL pywidt(55,sh,wdtp,wdte)
19606  hs=shr*wdtp(0)
19607  facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
19608  IF(abs(shr-pmas(55,1)).GT.parp(48)*pmas(55,2)) facbw=0d0
19609  alprht=2.91d0*(3d0/parp(144))
19610  hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)*
19611  & (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
19612  DO 1520 i=mmin1,mmax1
19613  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1520
19614  ia=iabs(i)
19615  DO 1510 j=mmin2,mmax2
19616  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1510
19617  ja=iabs(j)
19618  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1510
19619  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
19620  & goto 1510
19621  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
19622  hf=shr*(wdte(0,1)+wdte(0,(5-kchr)/2)+wdte(0,4))
19623  hi=hp
19624  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
19625  nchn=nchn+1
19626  isig(nchn,1)=i
19627  isig(nchn,2)=j
19628  isig(nchn,3)=1
19629  sigh(nchn)=hi*facbw*hf
19630  1510 CONTINUE
19631  1520 CONTINUE
19632 
19633  ELSEIF(isub.EQ.193) THEN
19634 C...q + qbar -> omega_tech0.
19635  sqmomt=pmas(56,1)**2
19636  CALL pywidt(56,sh,wdtp,wdte)
19637  hs=shr*wdtp(0)
19638  facbw=12d0*comfac/((sh-sqmomt)**2+hs**2)
19639  IF(abs(shr-pmas(56,1)).GT.parp(48)*pmas(56,2)) facbw=0d0
19640  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
19641  alprht=2.91d0*(3d0/parp(144))
19642  hp=(1d0/6d0)*(aem**2/alprht)*(sqmomt**2/sh)*
19643  & (2d0*parp(143)-1d0)**2
19644  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
19645  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
19646  DO 1530 i=mmina,mmaxa
19647  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1530
19648  ia=iabs(i)
19649  ei=kchg(iabs(i),1)/3d0
19650  ai=sign(1d0,ei+0.1d0)
19651  vi=ai-4d0*ei*xwv
19652  vali=0.5d0*(vi+ai)
19653  vari=0.5d0*(vi-ai)
19654  hi=hp*((ei-vali*bwzr)**2+(vali*bwzi)**2+
19655  & (ei-vari*bwzr)**2+(vari*bwzi)**2)
19656  IF(ia.LE.10) hi=hi*faca/3d0
19657  nchn=nchn+1
19658  isig(nchn,1)=i
19659  isig(nchn,2)=-i
19660  isig(nchn,3)=1
19661  sigh(nchn)=hi*facbw*hf
19662  1530 CONTINUE
19663 
19664  ELSEIF(isub.EQ.194) THEN
19665 C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
19666  sqmrht=pmas(54,1)**2
19667  CALL pywidt(54,sh,wdtp,wdte)
19668  hsrht=shr*wdtp(0)
19669  bwrhtr=sqmrht**2*(sh-sqmrht)/((sh-sqmrht)**2+hsrht**2)
19670  bwrhti=sqmrht**2*hsrht/((sh-sqmrht)**2+hsrht**2)
19671  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
19672  sqmomt=pmas(56,1)**2
19673  CALL pywidt(56,sh,wdtp,wdte)
19674  hsomt=shr*wdtp(0)
19675  bwomtr=sqmomt**2*(sh-sqmomt)/((sh-sqmomt)**2+hsomt**2)
19676  bwomti=sqmomt**2*hsomt/((sh-sqmomt)**2+hsomt**2)
19677  xwomt=0.5d0/(1d0-xw)
19678  kff=iabs(kfpr(isub,1))
19679  ef=kchg(kff,1)/3d0
19680  af=sign(1d0,ef+0.1d0)
19681  vf=af-4d0*ef*xwv
19682  valf=0.5d0*(vf+af)
19683  varf=0.5d0*(vf-af)
19684  fcof=1d0
19685  IF(kff.LE.10) fcof=3d0
19686  wid2=1d0
19687  IF(kff.GE.6.AND.kff.LE.8) wid2=wids(kff,1)
19688  IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
19689  alprht=2.91d0*(3d0/parp(144))
19690  factc=comfac*(aem**2/(alprht*sh2))**2*fcof*wid2
19691  bwz=sh/(sh-sqmz)
19692  aleftf=ef+valf*xwrht*bwz
19693  arighf=ef+varf*xwrht*bwz
19694  bleftf=(ef-valf*xwomt*bwz)*(2d0*parp(143)-1d0)
19695  brighf=(ef-varf*xwomt*bwz)*(2d0*parp(143)-1d0)
19696  DO 1540 i=mmina,mmaxa
19697  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1540
19698  ei=kchg(iabs(i),1)/3d0
19699  ai=sign(1d0,ei+0.1d0)
19700  vi=ai-4d0*ei*xwv
19701  vali=0.5d0*(vi+ai)
19702  vari=0.5d0*(vi-ai)
19703  fcoi=1d0
19704  IF(iabs(i).LE.10) fcoi=faca/3d0
19705  alefti=ei+vali*xwrht*bwz
19706  arighi=ei+vari*xwrht*bwz
19707  blefti=(ei-vali*xwomt*bwz)*(2d0*parp(143)-1d0)
19708  brighi=(ei-vari*xwomt*bwz)*(2d0*parp(143)-1d0)
19709  difll=(alefti*aleftf*bwrhtr+blefti*bleftf*bwomtr)**2+
19710  & (alefti*aleftf*bwrhti+blefti*bleftf*bwomti)**2
19711  difrr=(arighi*arighf*bwrhtr+brighi*brighf*bwomtr)**2+
19712  & (arighi*arighf*bwrhti+brighi*brighf*bwomti)**2
19713  diflr=(alefti*arighf*bwrhtr+blefti*brighf*bwomtr)**2+
19714  & (alefti*arighf*bwrhti+blefti*brighf*bwomti)**2
19715  difrl=(arighi*aleftf*bwrhtr+brighi*bleftf*bwomtr)**2+
19716  & (arighi*aleftf*bwrhti+brighi*bleftf*bwomti)**2
19717  facsig=(difll+difrr)*uh2+(diflr+difrl)*th2
19718  nchn=nchn+1
19719  isig(nchn,1)=i
19720  isig(nchn,2)=-i
19721  isig(nchn,3)=1
19722  sigh(nchn)=factc*fcoi*facsig
19723  1540 CONTINUE
19724 
19725  ENDIF
19726 
19727 CMRENNA++
19728 C...J: 2 -> 2, tree diagrams, SUSY processes
19729 
19730  ELSEIF(isub.LE.210) THEN
19731  IF(isub.EQ.201) THEN
19732 C...f + fbar -> e_L + e_Lbar
19733  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
19734  DO 1570 i=mmin1,mmax1
19735  ia=iabs(i)
19736  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1570
19737  ei=kchg(iabs(i),1)/3d0
19738  tt3i=sign(1d0,ei+1d-6)/2d0
19739  ej=-1d0
19740  tt3j=-1d0/2d0
19741  fcol=1d0
19742 C...Color factor for e+ e-
19743  IF(ia.GE.11) fcol=3d0
19744  IF(ilr.EQ.1) THEN
19745  xlq=2d0*(tt3j-ej*xw)*sfmix(kfid,3)**2
19746  xrq=2d0*(-ej*xw)*sfmix(kfid,4)**2
19747  ELSEIF(ilr.EQ.0) THEN
19748  xlq=2d0*(tt3j-ej*xw)*sfmix(kfid,1)**2
19749  xrq=2d0*(-ej*xw)*sfmix(kfid,2)**2
19750  ENDIF
19751  xlf=2d0*(tt3i-ei*xw)
19752  xrf=2d0*(-ei*xw)
19753  taa=0.5d0*(ei*ej)**2
19754  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/(1d0-xw)**2
19755  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*zwid/sh**2)
19756  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/(1d0-xw)
19757  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
19758  tnn=0.0d0
19759  tan=0.0d0
19760  tzn=0.0d0
19761  IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
19762  IF(ilr.EQ.0) THEN
19763  a1=sfmix(kfid,1)
19764  a2=sfmix(kfid,2)
19765  ELSE
19766  a1=sfmix(kfid,3)
19767  a2=sfmix(kfid,4)
19768  ENDIF
19769  fac2=sqrt(2d0)
19770  tnn1=0d0
19771  tnn2=0d0
19772  tnn3=0d0
19773  DO 1560 ii=1,4
19774  dk=1d0/(th-smz(ii)**2)
19775  flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-2d0*ei)*
19776  & zmix(ii,1))/2d0
19777  frek=fac2*tanw*ei*zmix(ii,1)
19778  tnn1=tnn1+flek**2*dk
19779  tnn2=tnn2+frek**2*dk
19780  DO 1550 jj=1,4
19781  dl=1d0/(th-smz(jj)**2)
19782  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-2d0*ej)*
19783  & zmix(jj,1))/2d0
19784  frel=fac2*tanw*ej*zmix(jj,1)
19785  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
19786  1550 CONTINUE
19787  1560 CONTINUE
19788  tnn=(uh*th - sqm3*sqm4)*(a1**4*tnn1**2+a2**4*tnn2**2)
19789  tnn=(tnn+2d0*sh*a1**2*a2**2*tnn3)/4d0
19790  tzn=(uh*th-sqm3*sqm4)*(xlq+xrq)/2d0*
19791  & (tnn1*xlq+tnn2*xrq)/2d0
19792  tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
19793  & (1d0-sqmz/sh)/sh
19794  tzn=tzn/xw**2/(1d0-xw)
19795  tan=(uh*th-sqm3*sqm4)/sh*(a1**2*tnn1+a2**2*tnn2)/xw
19796  ENDIF
19797  facqq1=comfac*aem**2*(taa+tzz+taz)*fcol*4d0/3d0
19798  facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh**2
19799  facqq2=comfac*aem**2*(tnn+tzn+tan)
19800  nchn=nchn+1
19801  isig(nchn,1)=i
19802  isig(nchn,2)=-i
19803  isig(nchn,3)=1
19804  sigh(nchn)=facqq1+facqq2
19805  1570 CONTINUE
19806 
19807  ELSEIF(isub.EQ.203) THEN
19808 C...f + fbar -> e_L + e_Rbar
19809  DO 1600 i=mmin1,mmax1
19810  ia=iabs(i)
19811  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1600
19812  ei=kchg(iabs(i),1)/3d0
19813  tt3i=sign(1d0,ei)/2d0
19814  ej=-1
19815  tt3j=-1d0/2d0
19816  fcol=1d0
19817 C...Asymmetry factor for e1+ e2- vs. e2+ e1-
19818  pasy=0d0
19819  IF(ia.GE.11.AND.kfid.EQ.ia) THEN
19820  IF(abs(mint(21)).EQ.kfpr(isub,1)) THEN
19821  pasy=-isign(1,mint(21))
19822  ELSE
19823  pasy=-isign(1,mint(22))
19824  ENDIF
19825  ENDIF
19826 C...Color factor for e+ e-
19827  IF(ia.GE.11) fcol=3d0
19828  a1=sfmix(kfid,1)**2
19829  a2=sfmix(kfid,2)**2
19830  xlq=2d0*(tt3j-ej*xw)
19831  xrq=2d0*(-ej*xw)
19832  xlf=2d0*(tt3i-ei*xw)
19833  xrf=2d0*(-ei*xw)
19834  tzz=(xlf**2-xrf**2)*(xlq-xrq)**2/64d0/xw**2/(1d0-
19835  & xw)**2*a1*a2
19836  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
19837  tnn=0.0d0
19838  tzn=0.0d0
19839  IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
19840  fac2=sqrt(2d0)
19841  tnn1=0d0
19842  tnn2=0d0
19843  tnn3=0d0
19844  DO 1590 ii=1,4
19845  dk=1d0/(th-smz(ii)**2)
19846  flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
19847  & zmix(ii,1))
19848  frek=fac2*tanw*ei*zmix(ii,1)
19849  tnn1=tnn1+flek**2*dk
19850  tnn2=tnn2+frek**2*dk
19851  DO 1580 jj=1,4
19852  dl=1d0/(th-smz(jj)**2)
19853  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
19854  & zmix(jj,1))
19855  frel=fac2*tanw*ej*zmix(jj,1)
19856  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
19857  1580 CONTINUE
19858  1590 CONTINUE
19859  tnn=(uh*th-sqm3*sqm4)*a1*a2*(tnn2**2-tnn1**2)
19860  tnn=(tnn+sh*(a2-a1)*pasy*tnn3)/4d0
19861  tzn=(uh*th-sqm3*sqm4)*a1*a2
19862  tzn=tzn*(xlf-xrf)*(xlq*tnn1+xrq*tnn2)/4d0/(1d0-xw)
19863  tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
19864  & (1d0-sqmz/sh)/sh
19865  ENDIF
19866  facqq1=comfac*aem**2*tzz*fcol*4d0/3d0*(uh*th-sqm3*sqm4)/sh2
19867  facqq2=comfac*aem**2/xw**2*(tnn+tzn)
19868  facqq=2d0*(facqq1+facqq2)
19869  nchn=nchn+1
19870  isig(nchn,1)=i
19871  isig(nchn,2)=-i
19872  isig(nchn,3)=1
19873  sigh(nchn)=facqq*wids(pycomp(kfpr(isubsv,1)),2)*
19874  & wids(pycomp(kfpr(isubsv,2)),3)
19875  nchn=nchn+1
19876  isig(nchn,1)=i
19877  isig(nchn,2)=-i
19878  isig(nchn,3)=2
19879  sigh(nchn)=facqq*wids(pycomp(kfpr(isubsv,1)),3)*
19880  & wids(pycomp(kfpr(isubsv,2)),2)
19881  1600 CONTINUE
19882 
19883  ELSEIF(isub.EQ.210) THEN
19884 C...q + qbar' -> W*- > ~l_L + ~nu_L
19885  fac0=rkf*comfac*aem**2/xw**2/12d0
19886  fac1=(th*uh-sqm3*sqm4)/((sh-sqmw)**2+wwid**2*sqmw)
19887  DO 1620 i=mmin1,mmax1
19888  ia=iabs(i)
19889  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 1620
19890  DO 1610 j=mmin2,mmax2
19891  ja=iabs(j)
19892  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 1610
19893  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1610
19894  fckm=3d0
19895  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
19896  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
19897  kchw=2
19898  IF(kchsum.LT.0) kchw=3
19899  nchn=nchn+1
19900  isig(nchn,1)=i
19901  isig(nchn,2)=j
19902  isig(nchn,3)=1
19903  sigh(nchn)=fac0*fac1*fckm*wids(pycomp(kfpr(isubsv,1)),
19904  & 5-kchw)*wids(pycomp(kfpr(isubsv,2)),kchw)
19905  1610 CONTINUE
19906  1620 CONTINUE
19907  ENDIF
19908 
19909  ELSEIF(isub.LE.220) THEN
19910  IF(isub.EQ.213) THEN
19911 C...f + fbar -> ~nu_L + ~nu_Lbar
19912  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
19913  fac0=rkf*comfac/3d0*aem**2
19914  fac1=xw*(1d0-xw)
19915  propz=(sh-sqmz)**2+zwid**2*sqmz
19916  xll=0.5d0
19917  xlr=0.0d0
19918  DO 1630 i=mmin1,mmax1
19919  ia=iabs(i)
19920  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1630
19921  ei=kchg(iabs(i),1)/3d0
19922  fcol=1d0
19923 C...Color factor for e+ e-
19924  IF(ia.GE.11) fcol=3d0
19925  xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
19926  xrq=-ei*xw
19927  facqq1=(xlq**2+xrq**2)*(xll+xlr)**2/fac1**2/propz
19928  & *(uh*th-sqm3*sqm4)
19929  tzc=0.0d0
19930  IF(ia.GE.11.AND.kfid.EQ.ia+1) THEN
19931  tzc=vmix(1,1)**2/(th-smw(1)**2)+vmix(2,1)**2/
19932  & (th-smw(2)**2)
19933  tcc=tzc**2
19934  tzc=tzc/(1d0-xw)*(sh-sqmz)/propz+tcc
19935  ENDIF
19936  facqq2=rkf*(uh*th-sqm3*sqm4)/4d0*tzc*comfac*aem**2/xw**2
19937  nchn=nchn+1
19938  isig(nchn,1)=i
19939  isig(nchn,2)=-i
19940  isig(nchn,3)=1
19941  sigh(nchn)=facqq1*fcol*fac0+facqq2
19942  1630 CONTINUE
19943 
19944  ELSEIF(isub.EQ.216) THEN
19945 C...q + qbar -> ~chi0_1 + ~chi0_1
19946  IF(izid1.EQ.izid2) THEN
19947  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
19948  ELSE
19949  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
19950  & wids(pycomp(kfpr(isubsv,2)),2)
19951  ENDIF
19952  facgg1=comfac*aem**2/3d0/xw**2
19953  IF(izid1.EQ.izid2) facgg1=facgg1/2d0
19954  zm12=sqm3
19955  zm22=sqm4
19956  sr2=sqrt(2d0)
19957  tanw=sqrt(xw/(1d0-xw))
19958  wu2 = (uh-zm12)*(uh-zm22)/sh2
19959  wt2 = (th-zm12)*(th-zm22)/sh2
19960  xs2 = smz(izid1)*smz(izid2)/sh
19961  propz2 = (sh-sqmz)**2 + sqmz*zwid**2
19962  reprpz = (sh-sqmz)/propz2
19963  olpp=(-zmix(izid1,3)*zmix(izid2,3)+
19964  & zmix(izid1,4)*zmix(izid2,4))/2d0
19965  DO 1640 i=mmina,mmaxa
19966  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1640
19967  ei=kchg(iabs(i),1)/3d0
19968  fcol=1d0
19969  IF(abs(i).GE.11) fcol=3d0
19970  xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
19971  xrq=-ei*xw
19972  xlq=xlq/(1d0-xw)
19973  xrq=xrq/(1d0-xw)
19974 C...Factored out sqrt(2)
19975  fr1=tanw*ei*zmix(izid1,1)
19976  fr2=tanw*ei*zmix(izid2,1)
19977  fl1=-(sign(1d0,ei)*zmix(izid1,2)-tanw*
19978  & (sign(1d0,ei)-2d0*ei)*zmix(izid1,1))/2d0
19979  fl2=-(sign(1d0,ei)*zmix(izid2,2)-tanw*
19980  & (sign(1d0,ei)-2d0*ei)*zmix(izid2,1))/2d0
19981  fr12=fr1**2
19982  fr22=fr2**2
19983  fl12=fl1**2
19984  fl22=fl2**2
19985  xml2=pmas(pycomp(ksusy1+iabs(i)),1)**2
19986  xmr2=pmas(pycomp(ksusy2+iabs(i)),1)**2
19987  facs=olpp**2*(xlq**2+xrq**2)*(wu2+wt2-2d0*xs2)*(sh2/propz2)
19988  fact=fl12*fl22*(wt2*sh2/(th-xml2)**2+wu2*sh2/(uh-xml2)**2-
19989  & 2d0*xs2*sh2/(th-xml2)/(uh-xml2))
19990  facu=fr12*fr22*(wt2*sh2/(th-xmr2)**2+wu2*sh2/(uh-xmr2)**2-
19991  & 2d0*xs2*sh2/(th-xmr2)/(uh-xmr2))
19992  facst=2d0*reprpz*olpp*xlq*fl1*fl2*( (wt2-xs2)*sh2/
19993  & (th-xml2) + (wu2-xs2)*sh2/(uh-xml2) )
19994  facsu=-2d0*reprpz*olpp*xrq*fr1*fr2*( (wt2-xs2)*sh2/
19995  & (th-xmr2) + (wu2-xs2)*sh2/(uh-xmr2) )
19996  nchn=nchn+1
19997  isig(nchn,1)=i
19998  isig(nchn,2)=-i
19999  isig(nchn,3)=1
20000  sigh(nchn)=facgg1*fcol*(facs+fact+facu+facst+facsu)
20001  1640 CONTINUE
20002  ENDIF
20003 
20004  ELSEIF(isub.LE.230) THEN
20005  IF(isub.EQ.226) THEN
20006 C...f + fbar -> ~chi+_1 + ~chi-_1
20007  facgg1=comfac*aem**2/3d0/xw**2
20008  zm12=sqm3
20009  zm22=sqm4
20010  wu2 = (uh-zm12)*(uh-zm22)/sh2
20011  wt2 = (th-zm12)*(th-zm22)/sh2
20012  ws2 = smw(izid1)*smw(izid2)/sh
20013  propz2 = (sh-sqmz)**2 + sqmz*zwid**2
20014  reprpz = (sh-sqmz)/propz2
20015  diff=0d0
20016  IF(izid1.EQ.izid2) diff=1d0
20017  DO 1650 i=mmina,mmaxa
20018  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1650
20019  ei=kchg(iabs(i),1)/3d0
20020  fcol=1d0
20021  IF(iabs(i).GE.11) fcol=3d0
20022  xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
20023  xrq=-ei*xw
20024  xlq=xlq/(1d0-xw)
20025  xrq=xrq/(1d0-xw)
20026  xlq2=xlq**2
20027  xrq2=xrq**2
20028  olp=-vmix(izid1,1)*vmix(izid2,1)-
20029  & vmix(izid1,2)*vmix(izid2,2)/2d0+xw*diff
20030  orp=-umix(izid1,1)*umix(izid2,1)-
20031  & umix(izid1,2)*umix(izid2,2)/2d0+xw*diff
20032  orp2=orp**2
20033  olp2=olp**2
20034 C...u-type quark - d-type squark
20035  IF(mod(i,2).EQ.0) THEN
20036  fact0 = umix(izid1,1)*umix(izid2,1)
20037  xml2=pmas(pycomp(ksusy1+iabs(i)-1),1)**2
20038 C...d-type quark - u-type squark
20039  ELSE
20040  fact0 = vmix(izid1,1)*vmix(izid2,1)
20041  xml2=pmas(pycomp(ksusy1+iabs(i)+1),1)**2
20042  ENDIF
20043  faca=2d0*xw**2*diff*(wt2+wu2+2d0*abs(ws2))*ei**2
20044  facz=0.5d0*((xlq2+xrq2)*(olp2+orp2)*(wt2+wu2)+
20045  & 4d0*(xlq2+xrq2)*olp*orp*ws2-(xlq2-xrq2)*(olp2-orp2)*
20046  & (wu2-wt2))*sh2/propz2
20047  fact=fact0**2/4d0*wt2*sh2/(th-xml2)**2
20048  facaz=xw*reprpz*diff*( (xlq+xrq)*(olp+orp)*(wu2+
20049  & wt2+2d0*abs(ws2))-(xlq-xrq)*(olp-orp)*(wu2-wt2) )*sh*(-ei)
20050  facta=xw*diff/(th-xml2)*(wt2+abs(ws2))*sh*fact0*(-ei)
20051  factz=reprpz/(th-xml2)*xlq*fact0*(olp*wt2+orp*ws2)*sh2
20052  facsum=facgg1*(faca+facaz+facz+fact+facta+factz)*fcol
20053  nchn=nchn+1
20054  isig(nchn,1)=i
20055  isig(nchn,2)=-i
20056  isig(nchn,3)=1
20057  IF(izid1.EQ.izid2) THEN
20058  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),1)
20059  ELSE
20060  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),3)*
20061  & wids(pycomp(kfpr(isubsv,1)),2)
20062  nchn=nchn+1
20063  isig(nchn,1)=i
20064  isig(nchn,2)=-i
20065  isig(nchn,3)=2
20066  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),2)*
20067  & wids(pycomp(kfpr(isubsv,1)),3)
20068  ENDIF
20069  1650 CONTINUE
20070 
20071  ELSEIF(isub.EQ.229) THEN
20072 C...q + qbar' -> ~chi0_1 + ~chi+-_1
20073  facgg1=comfac*aem**2/6d0/xw**2
20074  tanw = sqrt(xw/(1d0-xw))
20075  zm12=sqm3
20076  zm22=sqm4
20077  zmu2 = pmas(pycomp(ksusy1+2),1)**2
20078  zmd2 = pmas(pycomp(ksusy1+1),1)**2
20079  wu2 = (uh-zm12)*(uh-zm22)/sh2
20080  wt2 = (th-zm12)*(th-zm22)/sh2
20081  ws2 = smw(izid1)*smz(izid2)/sh
20082  rt2i = 1d0/sqrt(2d0)
20083  propw = ((sh-sqmw)**2+wwid**2*sqmw)
20084  ol=-rt2i*zmix(izid2,4)*vmix(izid1,2)+
20085  & zmix(izid2,2)*vmix(izid1,1)
20086  or= rt2i*zmix(izid2,3)*umix(izid1,2)+
20087  & zmix(izid2,2)*umix(izid1,1)
20088  ol2=ol**2
20089  or2=or**2
20090  cross=2d0*ol*or
20091  facst0=umix(izid1,1)
20092  facsu0=vmix(izid1,1)
20093  facsu0=facsu0*(0.5d0*zmix(izid2,2)+tanw*zmix(izid2,1)/6d0)
20094  facst0=facst0*(-0.5d0*zmix(izid2,2)+tanw*zmix(izid2,1)/6d0)
20095  fact0=facst0**2
20096  facu0=facsu0**2
20097  factu0=facsu0*facst0
20098  facst = -2d0*(sh-sqmw)/propw/(th-zmd2)*(wt2*sh2*or
20099  & + sh2*ws2*ol)*facst0
20100  facsu = 2d0*(sh-sqmw)/propw/(uh-zmu2)*(wu2*sh2*ol
20101  & + sh2*ws2*or)*facsu0
20102  fact = wt2*sh2/(th-zmd2)**2*fact0
20103  facu = wu2*sh2/(uh-zmu2)**2*facu0
20104  factu = -2d0*ws2*sh2/(th-zmd2)/(uh-zmu2)*factu0
20105  facw = (or2*wt2+ol2*wu2+cross*ws2)/propw*sh2
20106  facgg1=facgg1*(facw+fact+factu+facu+facsu+facst)
20107  DO 1670 i=mmin1,mmax1
20108  ia=iabs(i)
20109  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 1670
20110  DO 1660 j=mmin2,mmax2
20111  ja=iabs(j)
20112  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 1660
20113  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1660
20114  fckm=3d0
20115  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
20116  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
20117  kchw=2
20118  IF(kchsum.LT.0) kchw=3
20119  nchn=nchn+1
20120  isig(nchn,1)=i
20121  isig(nchn,2)=j
20122  isig(nchn,3)=1
20123  sigh(nchn)=facgg1*fckm*wids(pycomp(kfpr(isubsv,1)),2)*
20124  & wids(pycomp(kfpr(isubsv,2)),kchw)
20125  1660 CONTINUE
20126  1670 CONTINUE
20127  ENDIF
20128 
20129  ELSEIF(isub.LE.240) THEN
20130  IF(isub.EQ.237) THEN
20131 C...q + qbar -> gluino + ~chi0_1
20132  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
20133  & wids(pycomp(kfpr(isubsv,2)),2)
20134  fac0=comfac*as*aem*4d0/9d0/xw
20135  gm2=sqm3
20136  zm2=sqm4
20137  tanw=sqrt(xw/(1d0-xw))
20138  DO 1680 i=mmina,mmaxa
20139  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1680
20140  ei=kchg(iabs(i),1)/3d0
20141  ia=iabs(i)
20142  xlqc = -tanw*ei*zmix(izid,1)
20143  xrqc =(sign(1d0,ei)*zmix(izid,2)-tanw*
20144  & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
20145  xlq2=xlqc**2
20146  xrq2=xrqc**2
20147  xml2=pmas(pycomp(ksusy1+ia),1)**2
20148  xmr2=pmas(pycomp(ksusy2+ia),1)**2
20149  atkin=(th-gm2)*(th-zm2)/(th-xml2)**2
20150  aukin=(uh-gm2)*(uh-zm2)/(uh-xml2)**2
20151  atukin=smz(izid)*sqrt(gm2)*sh/(th-xml2)/(uh-xml2)
20152  sgchil=xlq2*(atkin+aukin-2d0*atukin)
20153  atkin=(th-gm2)*(th-zm2)/(th-xmr2)**2
20154  aukin=(uh-gm2)*(uh-zm2)/(uh-xmr2)**2
20155  atukin=smz(izid)*sqrt(gm2)*sh/(th-xmr2)/(uh-xmr2)
20156  sgchir=xrq2*(atkin+aukin-2d0*atukin)
20157  nchn=nchn+1
20158  isig(nchn,1)=i
20159  isig(nchn,2)=-i
20160  isig(nchn,3)=1
20161  sigh(nchn)=fac0*(sgchil+sgchir)
20162  1680 CONTINUE
20163  ENDIF
20164 
20165  ELSEIF(isub.LE.250) THEN
20166  IF(isub.EQ.241) THEN
20167 C...q + qbar' -> ~chi+-_1 + gluino
20168  facwg=comfac*as*aem/xw*2d0/9d0
20169  gm2=sqm3
20170  zm2=sqm4
20171  fac01=2d0*umix(izid,1)*vmix(izid,1)
20172  fac0=umix(izid,1)**2
20173  fac1=vmix(izid,1)**2
20174  DO 1700 i=mmin1,mmax1
20175  ia=iabs(i)
20176  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 1700
20177  DO 1690 j=mmin2,mmax2
20178  ja=iabs(j)
20179  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 1690
20180  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1690
20181  fckm=1d0
20182  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
20183  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
20184  kchw=2
20185  IF(kchsum.LT.0) kchw=3
20186  xmu2=pmas(pycomp(ksusy1+2),1)**2
20187  xmd2=pmas(pycomp(ksusy1+1),1)**2
20188  atkin=(th-gm2)*(th-zm2)/(th-xmu2)**2
20189  aukin=(uh-gm2)*(uh-zm2)/(uh-xmd2)**2
20190  atukin=smw(izid)*sqrt(gm2)*sh/(th-xmu2)/(uh-xmd2)
20191  xmu2=pmas(pycomp(ksusy2+2),1)**2
20192  xmd2=pmas(pycomp(ksusy2+1),1)**2
20193  atkin=(atkin+(th-gm2)*(th-zm2)/(th-xmu2)**2)/2d0
20194  aukin=(aukin+(uh-gm2)*(uh-zm2)/(uh-xmd2)**2)/2d0
20195  atukin=(atukin+smw(izid)*sqrt(gm2)*
20196  & sh/(th-xmu2)/(uh-xmd2))/2d0
20197  nchn=nchn+1
20198  isig(nchn,1)=i
20199  isig(nchn,2)=j
20200  isig(nchn,3)=1
20201  sigh(nchn)=facwg*fckm*(fac0*atkin+fac1*aukin-
20202  & fac01*atukin)*wids(pycomp(kfpr(isubsv,1)),2)*
20203  & wids(pycomp(kfpr(isubsv,2)),kchw)
20204  1690 CONTINUE
20205  1700 CONTINUE
20206 
20207  ELSEIF(isub.EQ.243) THEN
20208 C...q + qbar -> gluino + gluino
20209  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
20210  xmt=sqm3-th
20211  xmu=sqm3-uh
20212  DO 1710 i=mmina,mmaxa
20213  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
20214  & kfac(1,i)*kfac(2,-i).EQ.0) goto 1710
20215  nchn=nchn+1
20216  xsu=pmas(pycomp(ksusy1+iabs(i)),1)**2-uh
20217  xst=pmas(pycomp(ksusy1+iabs(i)),1)**2-th
20218  facgg1=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
20219  & 2d0*sqm3*sh)/sh2 +4d0/9d0*(xmt**2/xst**2+
20220  & xmu**2/xsu**2) - (xmt**2+sh*sqm3)/sh/xst +
20221  & sqm3*sh/xst/xsu/9d0- (xmu**2+sh*sqm3)/sh/xsu )
20222  xsu=pmas(pycomp(ksusy2+iabs(i)),1)**2-uh
20223  xst=pmas(pycomp(ksusy2+iabs(i)),1)**2-th
20224  facgg2=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
20225  & 2d0*sqm3*sh)/sh2 +4d0/9d0*(xmt**2/xst**2+
20226  & xmu**2/xsu**2) - (xmt**2+sh*sqm3)/sh/xst +
20227  & sqm3*sh/xst/xsu/9d0- (xmu**2+sh*sqm3)/sh/xsu )
20228  isig(nchn,1)=i
20229  isig(nchn,2)=-i
20230  isig(nchn,3)=1
20231 C...1/2 for identical particles
20232  sigh(nchn)=0.25d0*(facgg1+facgg2)
20233  1710 CONTINUE
20234 
20235  ELSEIF(isub.EQ.244) THEN
20236 C...g + g -> gluino + gluino
20237  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
20238  xmt=sqm3-th
20239  xmu=sqm3-uh
20240  facqq1=comfac*as**2*9d0/4d0*(
20241  & (xmt*xmu-2d0*sqm3*(th+sqm3))/xmt**2 -
20242  & (xmt*xmu+sqm3*(uh-th))/sh/xmt )
20243  facqq2=comfac*as**2*9d0/4d0*(
20244  & (xmu*xmt-2d0*sqm3*(uh+sqm3))/xmu**2 -
20245  & (xmu*xmt+sqm3*(th-uh))/sh/xmu )
20246  facqq3=comfac*as**2*9d0/4d0*(2d0*xmt*xmu/sh2 +
20247  & sqm3*(sh-4d0*sqm3)/xmt/xmu)
20248  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1720
20249  nchn=nchn+1
20250  isig(nchn,1)=21
20251  isig(nchn,2)=21
20252  isig(nchn,3)=1
20253  sigh(nchn)=facqq1/2d0
20254  nchn=nchn+1
20255  isig(nchn,1)=21
20256  isig(nchn,2)=21
20257  isig(nchn,3)=2
20258  sigh(nchn)=facqq2/2d0
20259  nchn=nchn+1
20260  isig(nchn,1)=21
20261  isig(nchn,2)=21
20262  isig(nchn,3)=3
20263  sigh(nchn)=facqq3/2d0
20264  1720 CONTINUE
20265 
20266  ELSEIF(isub.EQ.246) THEN
20267 C...g + q_j -> ~chi0_1 + ~q_j
20268  fac0=comfac*as*aem/6d0/xw
20269  zm2=sqm4
20270  qm2=sqm3
20271  tanw=sqrt(xw/(1d0-xw))
20272  faczq0=fac0*( (zm2-th)/sh +
20273  & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
20274  & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
20275  kfnsq=mod(kfpr(isubsv,1),ksusy1)
20276  DO 1740 i=-kfnsq,kfnsq,2*kfnsq
20277  IF(i.LT.mmina.OR.i.GT.mmaxa) goto 1740
20278  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1740
20279  ei=kchg(iabs(i),1)/3d0
20280  ia=iabs(i)
20281  xrqz = -tanw*ei*zmix(izid,1)
20282  xlqz =(sign(1d0,ei)*zmix(izid,2)-tanw*
20283  & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
20284  IF(ilr.EQ.0) THEN
20285  bs=xlqz**2*sfmix(ia,1)**2+xrqz**2*sfmix(ia,2)**2
20286  ELSE
20287  bs=xlqz**2*sfmix(ia,3)**2+xrqz**2*sfmix(ia,4)**2
20288  ENDIF
20289  faczq=faczq0*bs
20290  kchq=2
20291  IF(i.LT.0) kchq=3
20292  DO 1730 isde=1,2
20293  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1730
20294  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1730
20295  nchn=nchn+1
20296  isig(nchn,isde)=i
20297  isig(nchn,3-isde)=21
20298  isig(nchn,3)=1
20299  sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
20300  & wids(pycomp(kfpr(isubsv,2)),2)
20301  1730 CONTINUE
20302  1740 CONTINUE
20303  ENDIF
20304 
20305  ELSEIF(isub.LE.260) THEN
20306  IF(isub.EQ.254) THEN
20307 C...g + q_j -> ~chi1_1 + ~q_i
20308  fac0=comfac*as*aem/12d0/xw
20309  zm2=sqm4
20310  qm2=sqm3
20311  au=umix(izid,1)**2
20312  ad=vmix(izid,1)**2
20313  faczq0=fac0*( (zm2-th)/sh +
20314  & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
20315  & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
20316  kfnsq1=mod(kfpr(isubsv,1),ksusy1)
20317  IF(mod(kfnsq1,2).EQ.0) THEN
20318  kfnsq=kfnsq1-1
20319  kchw=2
20320  ELSE
20321  kfnsq=kfnsq1+1
20322  kchw=3
20323  ENDIF
20324  DO 1760 i=-kfnsq,kfnsq,2*kfnsq
20325  IF(i.LT.mmina.OR.i.GT.mmaxa) goto 1760
20326  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1760
20327  ia=iabs(i)
20328  IF(mod(ia,2).EQ.0) THEN
20329  faczq=faczq0*au
20330  ELSE
20331  faczq=faczq0*ad
20332  ENDIF
20333  faczq=faczq*sfmix(kfnsq1,1+2*ilr)**2
20334  kchq=2
20335  IF(i.LT.0) kchq=3
20336  kchwq=kchw
20337  IF(i.LT.0) kchwq=5-kchw
20338  DO 1750 isde=1,2
20339  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1750
20340  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1750
20341  nchn=nchn+1
20342  isig(nchn,isde)=i
20343  isig(nchn,3-isde)=21
20344  isig(nchn,3)=1
20345  sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
20346  & wids(pycomp(kfpr(isubsv,2)),kchwq)
20347  1750 CONTINUE
20348  1760 CONTINUE
20349 
20350  ELSEIF(isub.EQ.258) THEN
20351 C...g + q_j -> gluino + ~q_i
20352  xg2=sqm4
20353  xq2=sqm3
20354  xmt=xg2-th
20355  xmu=xg2-uh
20356  xst=xq2-th
20357  xsu=xq2-uh
20358  facqg1=0.5d0*4d0/9d0*xmt/sh + (xmt*sh+2d0*xg2*xst)/xmt**2 -
20359  & ( (sh-xq2+xg2)*(-xst)-sh*xg2 )/sh/(-xmt) +
20360  & 0.5d0*1d0/2d0*( xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst) +
20361  & (-xmu)*(th+xg2+2d0*xq2) )/2d0/xmt/xsu
20362  facqg2= 4d0/9d0*(-xmu)*(uh+xq2)/xsu**2 + 1d0/18d0*
20363  & (sh*(uh+xg2)
20364  & +2d0*(xq2-xg2)*xmu)/sh/(-xsu) + 0.5d0*4d0/9d0*xmt/sh +
20365  & 0.5d0*1d0/2d0*(xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst)+
20366  & (-xmu)*(th+xg2+2d0*xq2))/2d0/xmt/xsu
20367  facqg1=comfac*as**2*facqg1/2d0
20368  facqg2=comfac*as**2*facqg2/2d0
20369  kfnsq=mod(kfpr(isubsv,1),ksusy1)
20370  DO 1780 i=-kfnsq,kfnsq,2*kfnsq
20371  IF(i.LT.mmina.OR.i.GT.mmaxa) goto 1780
20372  IF(i.EQ.0.OR.iabs(i).GT.10) goto 1780
20373  kchq=2
20374  IF(i.LT.0) kchq=3
20375  facsel=rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
20376  & wids(pycomp(kfpr(isubsv,2)),2)
20377  DO 1770 isde=1,2
20378  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1770
20379  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1770
20380  nchn=nchn+1
20381  isig(nchn,isde)=i
20382  isig(nchn,3-isde)=21
20383  isig(nchn,3)=1
20384  sigh(nchn)=facqg1*facsel
20385  nchn=nchn+1
20386  isig(nchn,isde)=i
20387  isig(nchn,3-isde)=21
20388  isig(nchn,3)=2
20389  sigh(nchn)=facqg2*facsel
20390  1770 CONTINUE
20391  1780 CONTINUE
20392  ENDIF
20393 
20394  ELSEIF(isub.LE.270) THEN
20395  IF(isub.EQ.261) THEN
20396 C...q_i + q_ibar -> ~t_1 + ~t_1bar
20397  facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )*
20398  & wids(pycomp(kfpr(isubsv,1)),1)
20399  kfnsq=mod(kfpr(isubsv,1),ksusy1)
20400  fac0=as**2*4d0/9d0
20401  DO 1790 i=mmin1,mmax1
20402  ia=iabs(i)
20403  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1790
20404  IF(ia.GE.11.AND.ia.LE.18) THEN
20405  ei=kchg(ia,1)/3d0
20406  ej=kchg(kfnsq,1)/3d0
20407  t3i=sign(1d0,ei)/2d0
20408  t3j=sign(1d0,ej)/2d0
20409  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,2*ilr+1)**2
20410  xrq=2d0*(-ej*xw)*sfmix(kfnsq,2*ilr+2)**2
20411  xlf=2d0*(t3i-ei*xw)
20412  xrf=2d0*(-ei*xw)
20413  taa=0.5d0*(ei*ej)**2
20414  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/(1d0-xw)**2
20415  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
20416  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/(1d0-xw)
20417  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
20418  fac0=aem**2*12d0*(taa+tzz+taz)
20419  ENDIF
20420  nchn=nchn+1
20421  isig(nchn,1)=i
20422  isig(nchn,2)=-i
20423  isig(nchn,3)=1
20424  sigh(nchn)=facqq1*fac0
20425  1790 CONTINUE
20426 
20427  ELSEIF(isub.EQ.263) THEN
20428 C...f + fbar -> ~t1 + ~t2bar
20429  DO 1800 i=mmin1,mmax1
20430  ia=iabs(i)
20431  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1800
20432  ei=kchg(iabs(i),1)/3d0
20433  tt3i=sign(1d0,ei)/2d0
20434  ej=2d0/3d0
20435  tt3j=1d0/2d0
20436  fcol=1d0
20437 C...Color factor for e+ e-
20438  IF(ia.GE.11) fcol=3d0
20439  xlq=2d0*(tt3j-ej*xw)
20440  xrq=2d0*(-ej*xw)
20441  xlf=2d0*(tt3i-ei*xw)
20442  xrf=2d0*(-ei*xw)
20443  tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/64d0/xw**2/(1d0-xw)**2
20444  tzz=tzz*(sfmix(6,1)*sfmix(6,2))**2
20445  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
20446 C...Factor of 2 for t1 t2bar + t2 t1bar
20447  facqq1=2d0*comfac*aem**2*tzz*fcol*4d0
20448  facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh2
20449  nchn=nchn+1
20450  isig(nchn,1)=i
20451  isig(nchn,2)=-i
20452  isig(nchn,3)=1
20453  sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),2)*
20454  & wids(pycomp(kfpr(isubsv,2)),3)
20455  nchn=nchn+1
20456  isig(nchn,1)=i
20457  isig(nchn,2)=-i
20458  isig(nchn,3)=2
20459  sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),3)*
20460  & wids(pycomp(kfpr(isubsv,2)),2)
20461  1800 CONTINUE
20462 
20463  ELSEIF(isub.EQ.264) THEN
20464 C...g + g -> ~t_1 + ~t_1bar
20465  xsu=sqm3-uh
20466  xst=sqm3-th
20467  fac0=comfac*as**2*(7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )*0.5d0*
20468  & wids(pycomp(kfpr(isubsv,1)),1)
20469  facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
20470  facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
20471  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1810
20472  nchn=nchn+1
20473  isig(nchn,1)=21
20474  isig(nchn,2)=21
20475  isig(nchn,3)=1
20476  sigh(nchn)=facqq1
20477  nchn=nchn+1
20478  isig(nchn,1)=21
20479  isig(nchn,2)=21
20480  isig(nchn,3)=2
20481  sigh(nchn)=facqq2
20482  1810 CONTINUE
20483  ENDIF
20484 
20485  ELSEIF(isub.LE.280) THEN
20486  IF(isub.EQ.271) THEN
20487 C...q + q' -> ~q + ~q' (~g exchange)
20488  xmg2=pmas(pycomp(ksusy1+21),1)**2
20489  xmt=xmg2-th
20490  xmu=xmg2-uh
20491  xsu1=sqm3-uh
20492  xsu2=sqm4-uh
20493  xst1=sqm3-th
20494  xst2=sqm4-th
20495  IF(ilr.EQ.1) THEN
20496  facqq1=comfac*as**2*4d0/9d0*( -(xst1*xst2+sh*th)/xmt**2 )
20497  facqq2=comfac*as**2*4d0/9d0*( -(xsu1*xsu2+sh*uh)/xmu**2 )
20498  facqqb=0.0d0
20499  ELSE
20500  facqq1=0.5d0*comfac*as**2*4d0/9d0*( sh*xmg2/xmt**2 )
20501  facqq2=0.5d0*comfac*as**2*4d0/9d0*( sh*xmg2/xmu**2 )
20502  facqqb=0.5d0*comfac*as**2*4d0/9d0*( -2d0*sh*xmg2/3d0/
20503  & xmt/xmu )
20504  ENDIF
20505  kfnsqi=mod(kfpr(isubsv,1),ksusy1)
20506  kfnsqj=mod(kfpr(isubsv,2),ksusy1)
20507  DO 1830 i=-kfnsqi,kfnsqi,2*kfnsqi
20508  IF(i.LT.mmin1.OR.i.GT.mmax1) goto 1830
20509  ia=iabs(i)
20510  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 1830
20511  kchq=2
20512  IF(i.LT.0) kchq=3
20513  DO 1820 j=-kfnsqj,kfnsqj,2*kfnsqj
20514  IF(j.LT.mmin2.OR.j.GT.mmax2) goto 1820
20515  ja=iabs(j)
20516  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 1820
20517  IF(i*j.LT.0) goto 1820
20518  nchn=nchn+1
20519  isig(nchn,1)=i
20520  isig(nchn,2)=j
20521  isig(nchn,3)=1
20522  sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
20523  & wids(pycomp(kfpr(isubsv,2)),kchq)
20524  IF(i.EQ.j) THEN
20525  IF(isubsv.LE.272) THEN
20526  sigh(nchn)=(facqq1+0.5d0*facqqb)*rkf*
20527  & wids(pycomp(kfpr(isubsv,1)),kchq+2)
20528  ELSE
20529  sigh(nchn)=(facqq1+0.5d0*facqqb)*rkf*
20530  & wids(pycomp(kfpr(isubsv,1)),kchq)*
20531  & wids(pycomp(kfpr(isubsv,2)),kchq)
20532  ENDIF
20533  nchn=nchn+1
20534  isig(nchn,1)=i
20535  isig(nchn,2)=j
20536  isig(nchn,3)=2
20537  IF(isubsv.LE.272) THEN
20538  sigh(nchn)=(facqq2+0.5d0*facqqb)*rkf*
20539  & wids(pycomp(kfpr(isubsv,1)),kchq+2)
20540  ELSE
20541  sigh(nchn)=(facqq2+0.5d0*facqqb)*rkf*
20542  & wids(pycomp(kfpr(isubsv,1)),kchq)*
20543  & wids(pycomp(kfpr(isubsv,2)),kchq)
20544  ENDIF
20545  ENDIF
20546  1820 CONTINUE
20547  1830 CONTINUE
20548 
20549  ELSEIF(isub.EQ.274) THEN
20550 C...q + qbar -> ~q' + ~qbar'
20551  xmg2=pmas(pycomp(ksusy1+21),1)**2
20552  xmt=xmg2-th
20553  xmu=xmg2-uh
20554  IF(ilr.EQ.0) THEN
20555  facqq1=comfac*as**2*4d0/9d0*(
20556  & (uh*th-sqm3*sqm4)/xmt**2 )
20557  facqqb=comfac*as**2*4d0/9d0*(
20558  & (uh*th-sqm3*sqm4)/sh2*(2d0-2d0/3d0*sh/xmt**2))
20559  facqqb=facqqb+facqq1
20560  ELSE
20561  facqq1=comfac*as**2*4d0/9d0*( xmg2*sh/xmt**2 )
20562  facqqb=facqq1
20563  ENDIF
20564  kfnsqi=mod(kfpr(isubsv,1),ksusy1)
20565  kfnsqj=mod(kfpr(isubsv,2),ksusy1)
20566  DO 1850 i=-kfnsqi,kfnsqi,2*kfnsqi
20567  IF(i.LT.mmin1.OR.i.GT.mmax1) goto 1850
20568  ia=iabs(i)
20569  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 1850
20570  kchq=2
20571  IF(i.LT.0) kchq=3
20572  DO 1840 j=-kfnsqj,kfnsqj,2*kfnsqj
20573  IF(j.LT.mmin2.OR.j.GT.mmax2) goto 1840
20574  ja=iabs(j)
20575  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 1840
20576  IF(i*j.GT.0) goto 1840
20577  nchn=nchn+1
20578  isig(nchn,1)=i
20579  isig(nchn,2)=j
20580  isig(nchn,3)=1
20581  sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
20582  & wids(pycomp(kfpr(isubsv,2)),5-kchq)
20583  IF(i.EQ.-j) sigh(nchn)=facqqb*rkf*
20584  & wids(pycomp(kfpr(isubsv,1)),1)
20585  1840 CONTINUE
20586  1850 CONTINUE
20587 
20588  ELSEIF(isub.EQ.277) THEN
20589 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
20590 C...if i .eq. j covered in 274
20591  facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )
20592  kfnsq=mod(kfpr(isubsv,1),ksusy1)
20593  fac0=0d0
20594  DO 1860 i=mmin1,mmax1
20595  ia=iabs(i)
20596  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.
20597  & kfac(1,i)*kfac(2,-i).EQ.0) goto 1860
20598  IF(ia.EQ.kfnsq) goto 1860
20599  IF(ia.EQ.11.OR.ia.EQ.13.OR.ia.EQ.15) THEN
20600  ei=kchg(ia,1)/3d0
20601  ej=kchg(kfnsq,1)/3d0
20602  t3j=sign(0.5d0,ej)
20603  t3i=sign(1d0,ei)/2d0
20604  IF(ilr.EQ.0) THEN
20605  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,1)
20606  xrq=2d0*(-ej*xw)*sfmix(kfnsq,2)
20607  ELSE
20608  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,3)
20609  xrq=2d0*(-ej*xw)*sfmix(kfnsq,4)
20610  ENDIF
20611  xlf=2d0*(t3i-ei*xw)
20612  xrf=2d0*(-ei*xw)
20613  IF(ilr.EQ.0) THEN
20614  xrq=0d0
20615  ELSE
20616  xlq=0d0
20617  ENDIF
20618  taa=0.5d0*(ei*ej)**2
20619  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/(1d0-xw)**2
20620  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
20621  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/(1d0-xw)
20622  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
20623  fac0=aem**2*12d0*(taa+tzz+taz)
20624  ELSEIF(ia.LE.6) THEN
20625  fac0=as**2*8d0/9d0/2d0
20626  ENDIF
20627  nchn=nchn+1
20628  isig(nchn,1)=i
20629  isig(nchn,2)=-i
20630  isig(nchn,3)=1
20631  sigh(nchn)=facqq1*fac0*rkf*wids(pycomp(kfpr(isubsv,1)),1)
20632  1860 CONTINUE
20633 
20634  ELSEIF(isub.EQ.279) THEN
20635 C...g + g -> ~q_j + ~q_jbar
20636  xsu=sqm3-uh
20637  xst=sqm3-th
20638 C...5=RKF because ~t ~tbar treated separately
20639  fac0=rkf*comfac*as**2*( 7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )
20640  facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
20641  facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
20642  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1870
20643  nchn=nchn+1
20644  isig(nchn,1)=21
20645  isig(nchn,2)=21
20646  isig(nchn,3)=1
20647  sigh(nchn)=facqq1/2d0*wids(pycomp(kfpr(isubsv,1)),1)
20648  nchn=nchn+1
20649  isig(nchn,1)=21
20650  isig(nchn,2)=21
20651  isig(nchn,3)=2
20652  sigh(nchn)=facqq2/2d0*wids(pycomp(kfpr(isubsv,1)),1)
20653  1870 CONTINUE
20654 
20655  ENDIF
20656 CMRENNA--
20657  ENDIF
20658 
20659 C...Multiply with parton distributions
20660  IF(isub.LE.90.OR.isub.GE.96) THEN
20661  DO 1880 ichn=1,nchn
20662  IF(mint(45).GE.2) THEN
20663  kfl1=isig(ichn,1)
20664  sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)
20665  ENDIF
20666  IF(mint(46).GE.2) THEN
20667  kfl2=isig(ichn,2)
20668  sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)
20669  ENDIF
20670  sigs=sigs+sigh(ichn)
20671  1880 CONTINUE
20672  ENDIF
20673 
20674  RETURN
20675  END
20676 
20677 C*********************************************************************
20678 
20679 C...PYPDFU
20680 C...Gives electron, photon, pi+, neutron, proton and hyperon
20681 C...parton distributions according to a few different parametrizations.
20682 C...Note that what is coded is x times the probability distribution,
20683 C...i.e. xq(x,Q2) etc.
20684 
20685  SUBROUTINE pypdfu(KF,X,Q2,XPQ)
20686 
20687 C...Double precision and integer declarations.
20688  IMPLICIT DOUBLE PRECISION(a-h, o-z)
20689  INTEGER pyk,pychge,pycomp
20690 C...Commonblocks.
20691  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
20692  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
20693  common/pypars/mstp(200),parp(200),msti(200),pari(200)
20694  common/pyint1/mint(400),vint(400)
20695  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
20696  &xpdir(-6:6)
20697  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint8/
20698 C...Local arrays.
20699  dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),
20700  &xppi(-6:6),xppr(-6:6)
20701 
20702 C...Interface to PDFLIB.
20703  common/w50513/xmin,xmax,q2min,q2max
20704  SAVE /w50513/
20705  DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu,
20706  &value(20),xmin,xmax,q2min,q2max
20707  CHARACTER*20 parm(20)
20708  DATA value/20*0d0/,parm/20*' '/
20709 
20710 C...Data related to Schuler-Sjostrand photon distributions.
20711  DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/
20712 
20713 C...Reset parton distributions.
20714  mint(92)=0
20715  DO 100 kfl=-25,25
20716  xpq(kfl)=0d0
20717  100 CONTINUE
20718 
20719 C...Check x and particle species.
20720  IF(x.LE.0d0.OR.x.GE.1d0) THEN
20721  WRITE(mstu(11),5000) x
20722  RETURN
20723  ENDIF
20724  kfa=iabs(kf)
20725  IF(kfa.NE.11.AND.kfa.NE.22.AND.kfa.NE.211.AND.kfa.NE.2112.AND.
20726  &kfa.NE.2212.AND.kfa.NE.3122.AND.kfa.NE.3112.AND.kfa.NE.3212
20727  &.AND.kfa.NE.3222.AND.kfa.NE.3312.AND.kfa.NE.3322.AND.
20728  &kfa.NE.3334.AND.kfa.NE.111) THEN
20729  WRITE(mstu(11),5100) kf
20730  RETURN
20731  ENDIF
20732 
20733 C...Electron parton distribution call.
20734  IF(kfa.EQ.11) THEN
20735  CALL pypdel(x,q2,xpel)
20736  DO 110 kfl=-25,25
20737  xpq(kfl)=xpel(kfl)
20738  110 CONTINUE
20739 
20740 C...Photon parton distribution call (VDM+anomalous).
20741  ELSEIF(kfa.EQ.22.AND.mint(109).LE.1) THEN
20742  IF(mstp(56).EQ.1.AND.mstp(55).EQ.1) THEN
20743  CALL pypdga(x,q2,xpga)
20744  DO 120 kfl=-6,6
20745  xpq(kfl)=xpga(kfl)
20746  120 CONTINUE
20747  ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.5.AND.mstp(55).LE.8) THEN
20748  q2mx=q2
20749  p2mx=0.36d0
20750  IF(mstp(55).GE.7) p2mx=4.0d0
20751  IF(mstp(57).EQ.0) q2mx=p2mx
20752  CALL pyggam(mstp(55)-4,x,q2mx,0d0,mstp(60),f2gam,xpga)
20753  DO 130 kfl=-6,6
20754  xpq(kfl)=xpga(kfl)
20755  130 CONTINUE
20756  vint(231)=p2mx
20757  ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.9.AND.mstp(55).LE.12) THEN
20758  q2mx=q2
20759  p2mx=0.36d0
20760  IF(mstp(55).GE.11) p2mx=4.0d0
20761  IF(mstp(57).EQ.0) q2mx=p2mx
20762  CALL pyggam(mstp(55)-8,x,q2mx,0d0,mstp(60),f2gam,xpga)
20763  DO 140 kfl=-6,6
20764  xpq(kfl)=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
20765  140 CONTINUE
20766  vint(231)=p2mx
20767  ELSEIF(mstp(56).EQ.2) THEN
20768 C...Call PDFLIB parton distributions.
20769  parm(1)='NPTYPE'
20770  value(1)=3
20771  parm(2)='NGROUP'
20772  value(2)=mstp(55)/1000
20773  parm(3)='NSET'
20774  value(3)=mod(mstp(55),1000)
20775  IF(mint(93).NE.3000000+mstp(55)) THEN
20776  CALL pdfset(parm,value)
20777  mint(93)=3000000+mstp(55)
20778  ENDIF
20779  xx=x
20780  qq=sqrt(max(0d0,q2min,q2))
20781  IF(mstp(57).EQ.0) qq=sqrt(q2min)
20782  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
20783  vint(231)=q2min
20784  xpq(0)=glu
20785  xpq(1)=dnv
20786  xpq(-1)=dnv
20787  xpq(2)=upv
20788  xpq(-2)=upv
20789  xpq(3)=str
20790  xpq(-3)=str
20791  xpq(4)=chm
20792  xpq(-4)=chm
20793  xpq(5)=bot
20794  xpq(-5)=bot
20795  xpq(6)=top
20796  xpq(-6)=top
20797  ELSE
20798  WRITE(mstu(11),5200) kf,mstp(56),mstp(55)
20799  ENDIF
20800 
20801 C...Pion/gammaVDM parton distribution call.
20802  ELSEIF(kfa.EQ.211.OR.kfa.EQ.111.OR.(kfa.EQ.22.AND.
20803  & mint(109).EQ.2)) THEN
20804  IF(kfa.EQ.22.AND.mstp(56).EQ.1.AND.mstp(55).GE.5.AND.
20805  & mstp(55).LE.12) THEN
20806  iset=1+mod(mstp(55)-1,4)
20807  q2mx=q2
20808  p2mx=0.36d0
20809  IF(iset.GE.3) p2mx=4.0d0
20810  IF(mstp(57).EQ.0) q2mx=p2mx
20811  CALL pygvmd(iset,2,x,q2mx,p2mx,alamga,xpga,vxpga)
20812  DO 150 kfl=-6,6
20813  xpq(kfl)=xpga(kfl)
20814  150 CONTINUE
20815  vint(231)=p2mx
20816  ELSEIF(mstp(54).EQ.1.AND.mstp(53).GE.1.AND.mstp(53).LE.3) THEN
20817  CALL pypdpi(x,q2,xppi)
20818  DO 160 kfl=-6,6
20819  xpq(kfl)=xppi(kfl)
20820  160 CONTINUE
20821  ELSEIF(mstp(54).EQ.2) THEN
20822 C...Call PDFLIB parton distributions.
20823  parm(1)='NPTYPE'
20824  value(1)=2
20825  parm(2)='NGROUP'
20826  value(2)=mstp(53)/1000
20827  parm(3)='NSET'
20828  value(3)=mod(mstp(53),1000)
20829  IF(mint(93).NE.2000000+mstp(53)) THEN
20830  CALL pdfset(parm,value)
20831  mint(93)=2000000+mstp(53)
20832  ENDIF
20833  xx=x
20834  qq=sqrt(max(0d0,q2min,q2))
20835  IF(mstp(57).EQ.0) qq=sqrt(q2min)
20836  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
20837  vint(231)=q2min
20838  xpq(0)=glu
20839  xpq(1)=dsea
20840  xpq(-1)=upv+dsea
20841  xpq(2)=upv+usea
20842  xpq(-2)=usea
20843  xpq(3)=str
20844  xpq(-3)=str
20845  xpq(4)=chm
20846  xpq(-4)=chm
20847  xpq(5)=bot
20848  xpq(-5)=bot
20849  xpq(6)=top
20850  xpq(-6)=top
20851  ELSE
20852  WRITE(mstu(11),5200) kf,mstp(54),mstp(53)
20853  ENDIF
20854 
20855 C...Anomalous photon parton distribution call.
20856  ELSEIF(kfa.EQ.22.AND.mint(109).EQ.3) THEN
20857  q2mx=q2
20858  p2mx=parp(15)**2
20859  IF(mstp(56).EQ.1.AND.mstp(55).LE.8) THEN
20860  IF(mstp(55).EQ.5.OR.mstp(55).EQ.6) p2mx=0.36d0
20861  IF(mstp(55).EQ.7.OR.mstp(55).EQ.8) p2mx=4.0d0
20862  IF(mstp(57).EQ.0) q2mx=p2mx
20863  CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)
20864  DO 170 kfl=-6,6
20865  xpq(kfl)=xpga(kfl)
20866  170 CONTINUE
20867  vint(231)=p2mx
20868  ELSEIF(mstp(56).EQ.1) THEN
20869  IF(mstp(55).EQ.9.OR.mstp(55).EQ.10) p2mx=0.36d0
20870  IF(mstp(55).EQ.11.OR.mstp(55).EQ.12) p2mx=4.0d0
20871  IF(mstp(57).EQ.0) q2mx=p2mx
20872  CALL pyggam(mstp(55)-8,x,q2mx,0d0,mstp(60),f2gm,xpga)
20873  DO 180 kfl=-6,6
20874  xpq(kfl)=max(0d0,xpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
20875  180 CONTINUE
20876  vint(231)=p2mx
20877  ELSEIF(mstp(56).EQ.2) THEN
20878  IF(mstp(57).EQ.0) q2mx=p2mx
20879  CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)
20880  DO 190 kfl=-6,6
20881  xpq(kfl)=xpga(kfl)
20882  190 CONTINUE
20883  vint(231)=p2mx
20884  ELSEIF(mstp(55).GE.1.AND.mstp(55).LE.5) THEN
20885  IF(mstp(57).EQ.0) q2mx=p2mx
20886  CALL pygvmd(0,mstp(55),x,q2mx,p2mx,parp(1),xpga,vxpga)
20887  DO 200 kfl=-6,6
20888  xpq(kfl)=xpga(kfl)
20889  200 CONTINUE
20890  vint(231)=p2mx
20891  ELSE
20892  210 rkf=11d0*pyr(0)
20893  kfr=1
20894  IF(rkf.GT.1d0) kfr=2
20895  IF(rkf.GT.5d0) kfr=3
20896  IF(rkf.GT.6d0) kfr=4
20897  IF(rkf.GT.10d0) kfr=5
20898  IF(kfr.EQ.4.AND.q2.LT.pmcga**2) goto 210
20899  IF(kfr.EQ.5.AND.q2.LT.pmbga**2) goto 210
20900  IF(mstp(57).EQ.0) q2mx=p2mx
20901  CALL pygvmd(0,kfr,x,q2mx,p2mx,parp(1),xpga,vxpga)
20902  DO 220 kfl=-6,6
20903  xpq(kfl)=xpga(kfl)
20904  220 CONTINUE
20905  vint(231)=p2mx
20906  ENDIF
20907 
20908 C...Proton parton distribution call.
20909  ELSE
20910  IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.11) THEN
20911  CALL pypdpr(x,q2,xppr)
20912  DO 230 kfl=-6,6
20913  xpq(kfl)=xppr(kfl)
20914  230 CONTINUE
20915  ELSEIF(mstp(52).EQ.2) THEN
20916 C...Call PDFLIB parton distributions.
20917  parm(1)='NPTYPE'
20918  value(1)=1
20919  parm(2)='NGROUP'
20920  value(2)=mstp(51)/1000
20921  parm(3)='NSET'
20922  value(3)=mod(mstp(51),1000)
20923  IF(mint(93).NE.1000000+mstp(51)) THEN
20924  CALL pdfset(parm,value)
20925  mint(93)=1000000+mstp(51)
20926  ENDIF
20927  xx=x
20928  qq=sqrt(max(0d0,q2min,q2))
20929  IF(mstp(57).EQ.0) qq=sqrt(q2min)
20930  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
20931  vint(231)=q2min
20932  xpq(0)=glu
20933  xpq(1)=dnv+dsea
20934  xpq(-1)=dsea
20935  xpq(2)=upv+usea
20936  xpq(-2)=usea
20937  xpq(3)=str
20938  xpq(-3)=str
20939  xpq(4)=chm
20940  xpq(-4)=chm
20941  xpq(5)=bot
20942  xpq(-5)=bot
20943  xpq(6)=top
20944  xpq(-6)=top
20945  ELSE
20946  WRITE(mstu(11),5200) kf,mstp(52),mstp(51)
20947  ENDIF
20948  ENDIF
20949 
20950 C...Isospin average for pi0/gammaVDM.
20951  IF(kfa.EQ.111.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
20952  IF(kfa.EQ.22.AND.mstp(55).GE.5.AND.mstp(55).LE.12) THEN
20953  xpv=xpq(2)-xpq(1)
20954  xpq(2)=xpq(1)
20955  xpq(-2)=xpq(-1)
20956  ELSE
20957  xps=0.5d0*(xpq(1)+xpq(-2))
20958  xpv=0.5d0*(xpq(2)+xpq(-1))-xps
20959  xpq(2)=xps
20960  xpq(-1)=xps
20961  ENDIF
20962  IF(kfa.EQ.22.AND.mint(105).LE.223) THEN
20963  xpq(1)=xpq(1)+0.2d0*xpv
20964  xpq(-1)=xpq(-1)+0.2d0*xpv
20965  xpq(2)=xpq(2)+0.8d0*xpv
20966  xpq(-2)=xpq(-2)+0.8d0*xpv
20967  ELSEIF(kfa.EQ.22.AND.mint(105).EQ.333) THEN
20968  xpq(3)=xpq(3)+xpv
20969  xpq(-3)=xpq(-3)+xpv
20970  ELSEIF(kfa.EQ.22.AND.mint(105).EQ.443) THEN
20971  xpq(4)=xpq(4)+xpv
20972  xpq(-4)=xpq(-4)+xpv
20973  IF(mstp(55).GE.9) THEN
20974  DO 240 kfl=-6,6
20975  xpq(kfl)=0d0
20976  240 CONTINUE
20977  ENDIF
20978  ELSE
20979  xpq(1)=xpq(1)+0.5d0*xpv
20980  xpq(-1)=xpq(-1)+0.5d0*xpv
20981  xpq(2)=xpq(2)+0.5d0*xpv
20982  xpq(-2)=xpq(-2)+0.5d0*xpv
20983  ENDIF
20984 
20985 C...Rescale for gammaVDM by effective gamma -> rho coupling.
20986  IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN
20987  DO 250 kfl=-6,6
20988  xpq(kfl)=vint(281)*xpq(kfl)
20989  250 CONTINUE
20990  vint(232)=vint(281)*xpv
20991  ENDIF
20992 
20993 C...Isospin conjugation for neutron.
20994  ELSEIF(kfa.EQ.2112) THEN
20995  xps=xpq(1)
20996  xpq(1)=xpq(2)
20997  xpq(2)=xps
20998  xps=xpq(-1)
20999  xpq(-1)=xpq(-2)
21000  xpq(-2)=xps
21001 
21002 C...Simple recipes for hyperon (average valence parton distribution).
21003  ELSEIF(kfa.EQ.3122.OR.kfa.EQ.3112.OR.kfa.EQ.3212.OR.kfa.EQ.3222
21004  & .OR.kfa.EQ.3312.OR.kfa.EQ.3322.OR.kfa.EQ.3334) THEN
21005  xpval=(xpq(1)+xpq(2)-xpq(-1)-xpq(-2))/3d0
21006  xpsea=0.5d0*(xpq(-1)+xpq(-2))
21007  xpq(1)=xpsea
21008  xpq(2)=xpsea
21009  xpq(-1)=xpsea
21010  xpq(-2)=xpsea
21011  xpq(kfa/1000)=xpq(kfa/1000)+xpval
21012  xpq(mod(kfa/100,10))=xpq(mod(kfa/100,10))+xpval
21013  xpq(mod(kfa/10,10))=xpq(mod(kfa/10,10))+xpval
21014  ENDIF
21015 
21016 C...Charge conjugation for antiparticle.
21017  IF(kf.LT.0) THEN
21018  DO 260 kfl=1,25
21019  IF(kfl.EQ.21.OR.kfl.EQ.22.OR.kfl.EQ.23.OR.kfl.EQ.25) goto 260
21020  xps=xpq(kfl)
21021  xpq(kfl)=xpq(-kfl)
21022  xpq(-kfl)=xps
21023  260 CONTINUE
21024  ENDIF
21025 
21026 C...Allow gluon also in position 21.
21027  xpq(21)=xpq(0)
21028 
21029 C...Check positivity and reset above maximum allowed flavour.
21030  DO 270 kfl=-25,25
21031  xpq(kfl)=max(0d0,xpq(kfl))
21032  IF(iabs(kfl).GT.mstp(58).AND.iabs(kfl).LE.8) xpq(kfl)=0d0
21033  270 CONTINUE
21034 
21035 C...Formats for error printouts.
21036  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
21037  5100 FORMAT(' Error: illegal particle code for parton distribution;',
21038  &' KF =',i5)
21039  5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
21040  &3i5)
21041 
21042  RETURN
21043  END
21044 
21045 C*********************************************************************
21046 
21047 C...PYPDFL
21048 C...Gives proton parton distribution at small x and/or Q^2 according to
21049 C...correct limiting behaviour.
21050 
21051  SUBROUTINE pypdfl(KF,X,Q2,XPQ)
21052 
21053 C...Double precision and integer declarations.
21054  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21055  INTEGER pyk,pychge,pycomp
21056 C...Commonblocks.
21057  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
21058  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
21059  common/pypars/mstp(200),parp(200),msti(200),pari(200)
21060  common/pyint1/mint(400),vint(400)
21061  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
21062 C...Local arrays.
21063  dimension xpq(-25:25),xpa(-25:25),xpb(-25:25),wtsb(-3:3)
21064  DATA rmr/0.92d0/,rmp/0.38d0/,wtsb/0.5d0,1d0,1d0,5d0,1d0,1d0,0.5d0/
21065 
21066 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
21067  mint(92)=0
21068  kfa=iabs(kf)
21069  iacc=0
21070  IF((kfa.EQ.2212.OR.kfa.EQ.2112).AND.mstp(57).GE.2) iacc=1
21071  IF(kfa.EQ.211.AND.mstp(57).GE.3) iacc=1
21072  IF(kfa.EQ.22.AND.mint(109).EQ.2.AND.mstp(57).GE.3) iacc=1
21073  IF(iacc.EQ.0) THEN
21074  CALL pypdfu(kf,x,q2,xpq)
21075  RETURN
21076  ENDIF
21077 
21078 C...Reset. Check x.
21079  DO 100 kfl=-25,25
21080  xpq(kfl)=0d0
21081  100 CONTINUE
21082  IF(x.LE.0d0.OR.x.GE.1d0) THEN
21083  WRITE(mstu(11),5000) x
21084  RETURN
21085  ENDIF
21086 
21087 C...Define valence content.
21088  kfc=kf
21089  nv1=2
21090  nv2=1
21091  IF(kf.EQ.2212) THEN
21092  kfv1=2
21093  kfv2=1
21094  ELSEIF(kf.EQ.-2212) THEN
21095  kfv1=-2
21096  kfv2=-1
21097  ELSEIF(kf.EQ.2112) THEN
21098  kfv1=1
21099  kfv2=2
21100  ELSEIF(kf.EQ.-2112) THEN
21101  kfv1=-1
21102  kfv2=-2
21103  ELSEIF(kf.EQ.211) THEN
21104  nv1=1
21105  kfv1=2
21106  kfv2=-1
21107  ELSEIF(kf.EQ.-211) THEN
21108  nv1=1
21109  kfv1=-2
21110  kfv2=1
21111  ELSEIF(mint(105).LE.223) THEN
21112  kfv1=1
21113  wtv1=0.2d0
21114  kfv2=2
21115  wtv2=0.8d0
21116  ELSEIF(mint(105).EQ.333) THEN
21117  kfv1=3
21118  wtv1=1.0d0
21119  kfv2=1
21120  wtv2=0.0d0
21121  ELSEIF(mint(105).EQ.443) THEN
21122  kfv1=4
21123  wtv1=1.0d0
21124  kfv2=1
21125  wtv2=0.0d0
21126  ENDIF
21127 
21128 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
21129  CALL pypdfu(kfc,x,q2,xpa)
21130  q2mn=max(3d0,vint(231))
21131  q2b=2d0+0.052d0**2*exp(3.56d0*sqrt(max(0d0,-log(3d0*x))))
21132  xmn=exp(-(log((q2mn-2d0)/0.052d0**2)/3.56d0)**2)/3d0
21133 
21134 C...Large Q2 and large x: naive call is enough.
21135  IF(q2.GT.q2mn.AND.q2.GT.q2b) THEN
21136  DO 110 kfl=-25,25
21137  xpq(kfl)=xpa(kfl)
21138  110 CONTINUE
21139  mint(92)=1
21140 
21141 C...Small Q2 and large x: dampen boundary value.
21142  ELSEIF(x.GT.xmn) THEN
21143 
21144 C...Evaluate at boundary and define dampening factors.
21145  CALL pypdfu(kfc,x,q2mn,xpa)
21146  fv=(q2*(q2mn+rmr)/(q2mn*(q2+rmr)))**(0.55d0*(1d0-x)/(1d0-xmn))
21147  fs=(q2*(q2mn+rmp)/(q2mn*(q2+rmp)))**1.08d0
21148 
21149 C...Separate valence and sea parts of parton distribution.
21150  IF(kfa.NE.22) THEN
21151  xfv1=xpa(kfv1)-xpa(-kfv1)
21152  xpa(kfv1)=xpa(-kfv1)
21153  xfv2=xpa(kfv2)-xpa(-kfv2)
21154  xpa(kfv2)=xpa(-kfv2)
21155  ELSE
21156  xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
21157  xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
21158  xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
21159  xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
21160  ENDIF
21161 
21162 C...Dampen valence and sea separately. Put back together.
21163  DO 120 kfl=-25,25
21164  xpq(kfl)=fs*xpa(kfl)
21165  120 CONTINUE
21166  IF(kfa.NE.22) THEN
21167  xpq(kfv1)=xpq(kfv1)+fv*xfv1
21168  xpq(kfv2)=xpq(kfv2)+fv*xfv2
21169  ELSE
21170  xpq(kfv1)=xpq(kfv1)+fv*wtv1*vint(232)
21171  xpq(-kfv1)=xpq(-kfv1)+fv*wtv1*vint(232)
21172  xpq(kfv2)=xpq(kfv2)+fv*wtv2*vint(232)
21173  xpq(-kfv2)=xpq(-kfv2)+fv*wtv2*vint(232)
21174  ENDIF
21175  mint(92)=2
21176 
21177 C...Large Q2 and small x: interpolate behaviour.
21178  ELSEIF(q2.GT.q2mn) THEN
21179 
21180 C...Evaluate at extremes and define coefficients for interpolation.
21181  CALL pypdfu(kfc,xmn,q2mn,xpa)
21182  vi232a=vint(232)
21183  CALL pypdfu(kfc,x,q2b,xpb)
21184  vi232b=vint(232)
21185  fla=log(q2b/q2)/log(q2b/q2mn)
21186  fva=(x/xmn)**0.45d0*fla
21187  fsa=(x/xmn)**(-0.08d0)*fla
21188  fb=1d0-fla
21189 
21190 C...Separate valence and sea parts of parton distribution.
21191  IF(kfa.NE.22) THEN
21192  xfva1=xpa(kfv1)-xpa(-kfv1)
21193  xpa(kfv1)=xpa(-kfv1)
21194  xfva2=xpa(kfv2)-xpa(-kfv2)
21195  xpa(kfv2)=xpa(-kfv2)
21196  xfvb1=xpb(kfv1)-xpb(-kfv1)
21197  xpb(kfv1)=xpb(-kfv1)
21198  xfvb2=xpb(kfv2)-xpb(-kfv2)
21199  xpb(kfv2)=xpb(-kfv2)
21200  ELSE
21201  xpa(kfv1)=xpa(kfv1)-wtv1*vi232a
21202  xpa(-kfv1)=xpa(-kfv1)-wtv1*vi232a
21203  xpa(kfv2)=xpa(kfv2)-wtv2*vi232a
21204  xpa(-kfv2)=xpa(-kfv2)-wtv2*vi232a
21205  xpb(kfv1)=xpb(kfv1)-wtv1*vi232b
21206  xpb(-kfv1)=xpb(-kfv1)-wtv1*vi232b
21207  xpb(kfv2)=xpb(kfv2)-wtv2*vi232b
21208  xpb(-kfv2)=xpb(-kfv2)-wtv2*vi232b
21209  ENDIF
21210 
21211 C...Interpolate for valence and sea. Put back together.
21212  DO 130 kfl=-25,25
21213  xpq(kfl)=fsa*xpa(kfl)+fb*xpb(kfl)
21214  130 CONTINUE
21215  IF(kfa.NE.22) THEN
21216  xpq(kfv1)=xpq(kfv1)+(fva*xfva1+fb*xfvb1)
21217  xpq(kfv2)=xpq(kfv2)+(fva*xfva2+fb*xfvb2)
21218  ELSE
21219  xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vi232a+fb*vi232b)
21220  xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vi232a+fb*vi232b)
21221  xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vi232a+fb*vi232b)
21222  xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vi232a+fb*vi232b)
21223  ENDIF
21224  mint(92)=3
21225 
21226 C...Small Q2 and small x: dampen boundary value and add term.
21227  ELSE
21228 
21229 C...Evaluate at boundary and define dampening factors.
21230  CALL pypdfu(kfc,xmn,q2mn,xpa)
21231  fb=(xmn-x)*(q2mn-q2)/(xmn*q2mn)
21232  fa=1d0-fb
21233  fvc=(x/xmn)**0.45d0*(q2/(q2+rmr))**0.55d0
21234  fva=fvc*fa*((q2mn+rmr)/q2mn)**0.55d0
21235  fvb=fvc*fb*1.10d0*xmn**0.45d0*0.11d0
21236  fsc=(x/xmn)**(-0.08d0)*(q2/(q2+rmp))**1.08d0
21237  fsa=fsc*fa*((q2mn+rmp)/q2mn)**1.08d0
21238  fsb=fsc*fb*0.21d0*xmn**(-0.08d0)*0.21d0
21239 
21240 C...Separate valence and sea parts of parton distribution.
21241  IF(kfa.NE.22) THEN
21242  xfv1=xpa(kfv1)-xpa(-kfv1)
21243  xpa(kfv1)=xpa(-kfv1)
21244  xfv2=xpa(kfv2)-xpa(-kfv2)
21245  xpa(kfv2)=xpa(-kfv2)
21246  ELSE
21247  xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
21248  xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
21249  xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
21250  xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
21251  ENDIF
21252 
21253 C...Dampen valence and sea separately. Add constant terms.
21254 C...Put back together.
21255  DO 140 kfl=-25,25
21256  xpq(kfl)=fsa*xpa(kfl)
21257  140 CONTINUE
21258  IF(kfa.NE.22) THEN
21259  DO 150 kfl=-3,3
21260  xpq(kfl)=xpq(kfl)+fsb*wtsb(kfl)
21261  150 CONTINUE
21262  xpq(kfv1)=xpq(kfv1)+(fva*xfv1+fvb*nv1)
21263  xpq(kfv2)=xpq(kfv2)+(fva*xfv2+fvb*nv2)
21264  ELSE
21265  DO 160 kfl=-3,3
21266  xpq(kfl)=xpq(kfl)+vint(281)*fsb*wtsb(kfl)
21267  160 CONTINUE
21268  xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
21269  xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
21270  xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
21271  xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
21272  ENDIF
21273  xpq(21)=xpq(0)
21274  mint(92)=4
21275  ENDIF
21276 
21277 C...Format for error printout.
21278  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
21279 
21280  RETURN
21281  END
21282 
21283 C*********************************************************************
21284 
21285 C...PYPDEL
21286 C...Gives electron parton distribution.
21287 
21288  SUBROUTINE pypdel(X,Q2,XPEL)
21289 
21290 C...Double precision and integer declarations.
21291  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21292  INTEGER pyk,pychge,pycomp
21293 C...Commonblocks.
21294  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
21295  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
21296  common/pypars/mstp(200),parp(200),msti(200),pari(200)
21297  common/pyint1/mint(400),vint(400)
21298  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
21299 C...Local arrays.
21300  dimension xpel(-25:25),xpga(-6:6),sxp(0:6)
21301 
21302 C...Interface to PDFLIB.
21303  common/w50513/xmin,xmax,q2min,q2max
21304  SAVE /w50513/
21305  DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu,
21306  &value(20),xmin,xmax,q2min,q2max
21307  CHARACTER*20 parm(20)
21308  DATA value/20*0d0/,parm/20*' '/
21309 
21310 C...Some common constants.
21311  DO 100 kfl=-25,25
21312  xpel(kfl)=0d0
21313  100 CONTINUE
21314  aem=paru(101)
21315  pme=pmas(11,1)
21316  xl=log(max(1d-10,x))
21317  x1l=log(max(1d-10,1d0-x))
21318  hle=log(max(3d0,q2/pme**2))
21319  hbe2=(aem/paru(1))*(hle-1d0)
21320 
21321 C...Electron inside electron, see R. Kleiss et al., in Z physics at
21322 C...LEP 1, CERN 89-08, p. 34
21323  IF(mstp(59).LE.1) THEN
21324  hde=1d0+(aem/paru(1))*(1.5d0*hle+1.289868d0)+(aem/paru(1))**2*
21325  & (-2.164868d0*hle**2+9.840808d0*hle-10.130464d0)
21326  hee=hbe2*(1d0-x)**(hbe2-1d0)*sqrt(max(0d0,hde))-
21327  & 0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*(-4d0*x1l+3d0*xl)-
21328  & 4d0*xl/(1d0-x)-5d0-x)
21329  ELSE
21330  hee=hbe2*(1d0-x)**(hbe2-1d0)*exp(0.172784d0*hbe2)/
21331  & pygamm(1d0+hbe2)-0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*
21332  & (-4d0*x1l+3d0*xl)-4d0*xl/(1d0-x)-5d0-x)
21333  ENDIF
21334  IF(x.GT.0.9999d0.AND.x.LE.0.999999d0) THEN
21335  hee=hee*100d0**hbe2/(100d0**hbe2-1d0)
21336  ELSEIF(x.GT.0.999999d0) THEN
21337  hee=0d0
21338  ENDIF
21339  xpel(11)=x*hee
21340 
21341 C...Photon and (transverse) W- inside electron.
21342  aemp=pyalem(pme*sqrt(max(0d0,q2)))/paru(2)
21343  IF(mstp(13).LE.1) THEN
21344  hlg=hle
21345  ELSE
21346  hlg=log(max(1d0,(parp(13)/pme**2)*(1d0-x)/x**2))
21347  ENDIF
21348  xpel(22)=aemp*hlg*(1d0+(1d0-x)**2)
21349  hlw=log(1d0+q2/pmas(24,1)**2)/(4d0*paru(102))
21350  xpel(-24)=aemp*hlw*(1d0+(1d0-x)**2)
21351 
21352 C...Electron or positron inside photon inside electron.
21353  IF(mstp(12).EQ.1) THEN
21354  xfsea=0.5d0*(aemp*(hle-1d0))**2*(4d0/3d0+x-x**2-4d0*x**3/3d0+
21355  & 2d0*x*(1d0+x)*xl)
21356  xpel(11)=xpel(11)+xfsea
21357  xpel(-11)=xfsea
21358 
21359 C...Initialize PDFLIB photon parton distributions.
21360  IF(mstp(56).EQ.2) THEN
21361  parm(1)='NPTYPE'
21362  value(1)=3
21363  parm(2)='NGROUP'
21364  value(2)=mstp(55)/1000
21365  parm(3)='NSET'
21366  value(3)=mod(mstp(55),1000)
21367  IF(mint(93).NE.3000000+mstp(55)) THEN
21368  CALL pdfset(parm,value)
21369  mint(93)=3000000+mstp(55)
21370  ENDIF
21371  ENDIF
21372 
21373 C...Quarks and gluons inside photon inside electron:
21374 C...numerical convolution required.
21375  DO 110 kfl=0,6
21376  sxp(kfl)=0d0
21377  110 CONTINUE
21378  sumxpp=0d0
21379  iter=-1
21380  120 iter=iter+1
21381  sumxp=sumxpp
21382  nstp=2**(iter-1)
21383  IF(iter.EQ.0) nstp=2
21384  DO 130 kfl=0,6
21385  sxp(kfl)=0.5d0*sxp(kfl)
21386  130 CONTINUE
21387  wtstp=0.5d0/nstp
21388  IF(iter.EQ.0) wtstp=0.5d0
21389 C...Pick grid of x_{gamma} values logarithmically even.
21390  DO 150 istp=1,nstp
21391  IF(iter.EQ.0) THEN
21392  xle=xl*(istp-1)
21393  ELSE
21394  xle=xl*(istp-0.5d0)/nstp
21395  ENDIF
21396  xe=min(0.999999d0,exp(xle))
21397  xg=min(0.999999d0,x/xe)
21398 C...Evaluate photon inside electron parton distribution for convolution.
21399  xpgp=1d0+(1d0-xe)**2
21400  IF(mstp(13).LE.1) THEN
21401  xpgp=xpgp*hle
21402  ELSE
21403  xpgp=xpgp*log(max(1d0,(parp(13)/pme**2)*(1d0-xe)/xe**2))
21404  ENDIF
21405 C...Evaluate photon parton distributions for convolution.
21406  IF(mstp(56).EQ.1) THEN
21407  CALL pypdga(xg,q2,xpga)
21408  DO 140 kfl=0,5
21409  sxp(kfl)=sxp(kfl)+wtstp*xpgp*xpga(kfl)
21410  140 CONTINUE
21411  ELSEIF(mstp(56).EQ.2) THEN
21412 C...Call PDFLIB parton distributions.
21413  xx=xg
21414  qq=sqrt(max(0d0,q2min,q2))
21415  IF(mstp(57).EQ.0) qq=sqrt(q2min)
21416  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
21417  sxp(0)=sxp(0)+wtstp*xpgp*glu
21418  sxp(1)=sxp(1)+wtstp*xpgp*dnv
21419  sxp(2)=sxp(2)+wtstp*xpgp*upv
21420  sxp(3)=sxp(3)+wtstp*xpgp*str
21421  sxp(4)=sxp(4)+wtstp*xpgp*chm
21422  sxp(5)=sxp(5)+wtstp*xpgp*bot
21423  sxp(6)=sxp(6)+wtstp*xpgp*top
21424  ENDIF
21425  150 CONTINUE
21426  sumxpp=sxp(0)+2d0*sxp(1)+2d0*sxp(2)
21427  IF(iter.LE.2.OR.(iter.LE.7.AND.abs(sumxpp-sumxp).GT.
21428  & parp(14)*(sumxpp+sumxp))) goto 120
21429 
21430 C...Put convolution into output arrays.
21431  fconv=aemp*(-xl)
21432  xpel(0)=fconv*sxp(0)
21433  DO 160 kfl=1,6
21434  xpel(kfl)=fconv*sxp(kfl)
21435  xpel(-kfl)=xpel(kfl)
21436  160 CONTINUE
21437  ENDIF
21438 
21439  RETURN
21440  END
21441 
21442 C*********************************************************************
21443 
21444 C...PYPDGA
21445 C...Gives photon parton distribution.
21446 
21447  SUBROUTINE pypdga(X,Q2,XPGA)
21448 
21449 C...Double precision and integer declarations.
21450  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21451  INTEGER pyk,pychge,pycomp
21452 C...Commonblocks.
21453  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
21454  common/pypars/mstp(200),parp(200),msti(200),pari(200)
21455  common/pyint1/mint(400),vint(400)
21456  SAVE /pydat1/,/pypars/,/pyint1/
21457 C...Local arrays.
21458  dimension xpga(-6:6),dgag(4,3),dgbg(4,3),dgcg(4,3),dgan(4,3),
21459  &dgbn(4,3),dgcn(4,3),dgdn(4,3),dgen(4,3),dgas(4,3),dgbs(4,3),
21460  &dgcs(4,3),dgds(4,3),dges(4,3)
21461 
21462 C...The following data lines are coefficients needed in the
21463 C...Drees and Grassie photon parton distribution parametrization.
21464  DATA dgag/-.207d0,.6158d0,1.074d0,0.d0,.8926d-2,.6594d0,
21465  &.4766d0,.1975d-1,.03197d0,1.018d0,.2461d0,.2707d-1/
21466  DATA dgbg/-.1987d0,.6257d0,8.352d0,5.024d0,.5085d-1,.2774d0,
21467  &-.3906d0,-.3212d0,-.618d-2,.9476d0,-.6094d0,-.1067d-1/
21468  DATA dgcg/5.119d0,-.2752d0,-6.993d0,2.298d0,-.2313d0,.1382d0,
21469  &6.542d0,.5162d0,-.1216d0,.9047d0,2.653d0,.2003d-2/
21470  DATA dgan/2.285d0,-.1526d-1,1330.d0,4.219d0,-.3711d0,1.061d0,
21471  &4.758d0,-.1503d-1,15.8d0,-.9464d0,-.5d0,-.2118d0/
21472  DATA dgbn/6.073d0,-.8132d0,-41.31d0,3.165d0,-.1717d0,.7815d0,
21473  &1.535d0,.7067d-2,2.742d0,-.7332d0,.7148d0,3.287d0/
21474  DATA dgcn/-.4202d0,.1778d-1,.9216d0,.18d0,.8766d-1,.2197d-1,
21475  &.1096d0,.204d0,.2917d-1,.4657d-1,.1785d0,.4811d-1/
21476  DATA dgdn/-.8083d-1,.6346d0,1.208d0,.203d0,-.8915d0,.2857d0,
21477  &2.973d0,.1185d0,-.342d-1,.7196d0,.7338d0,.8139d-1/
21478  DATA dgen/.5526d-1,1.136d0,.9512d0,.1163d-1,-.1816d0,.5866d0,
21479  &2.421d0,.4059d0,-.2302d-1,.9229d0,.5873d0,-.79d-4/
21480  DATA dgas/16.69d0,-.7916d0,1099.d0,4.428d0,-.1207d0,1.071d0,
21481  &1.977d0,-.8625d-2,6.734d0,-1.008d0,-.8594d-1,.7625d-1/
21482  DATA dgbs/.176d0,.4794d-1,1.047d0,.25d-1,25.d0,-1.648d0,
21483  &-.1563d-1,6.438d0,59.88d0,-2.983d0,4.48d0,.9686d0/
21484  DATA dgcs/-.208d-1,.3386d-2,4.853d0,.8404d0,-.123d-1,1.162d0,
21485  &.4824d0,-.11d-1,-.3226d-2,.8432d0,.3616d0,.1383d-2/
21486  DATA dgds/-.1685d-1,1.353d0,1.426d0,1.239d0,-.9194d-1,.7912d0,
21487  &.6397d0,2.327d0,-.3321d-1,.9475d0,-.3198d0,.2132d-1/
21488  DATA dges/-.1986d0,1.1d0,1.136d0,-.2779d0,.2015d-1,.9869d0,
21489  &-.7036d-1,.1694d-1,.1059d0,.6954d0,-.6663d0,.3683d0/
21490 
21491 C...Photon parton distribution from Drees and Grassie.
21492 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
21493  DO 100 kfl=-6,6
21494  xpga(kfl)=0d0
21495  100 CONTINUE
21496  vint(231)=1d0
21497  IF(mstp(57).LE.0) THEN
21498  t=log(1d0/0.16d0)
21499  ELSE
21500  t=log(min(1d4,max(1d0,q2))/0.16d0)
21501  ENDIF
21502  x1=1d0-x
21503  nf=3
21504  IF(q2.GT.25d0) nf=4
21505  IF(q2.GT.300d0) nf=5
21506  nfe=nf-2
21507  aem=paru(101)
21508 
21509 C...Evaluate gluon content.
21510  dga=dgag(1,nfe)*t**dgag(2,nfe)+dgag(3,nfe)*t**(-dgag(4,nfe))
21511  dgb=dgbg(1,nfe)*t**dgbg(2,nfe)+dgbg(3,nfe)*t**(-dgbg(4,nfe))
21512  dgc=dgcg(1,nfe)*t**dgcg(2,nfe)+dgcg(3,nfe)*t**(-dgcg(4,nfe))
21513  xpgl=dga*x**dgb*x1**dgc
21514 
21515 C...Evaluate up- and down-type quark content.
21516  dga=dgan(1,nfe)*t**dgan(2,nfe)+dgan(3,nfe)*t**(-dgan(4,nfe))
21517  dgb=dgbn(1,nfe)*t**dgbn(2,nfe)+dgbn(3,nfe)*t**(-dgbn(4,nfe))
21518  dgc=dgcn(1,nfe)*t**dgcn(2,nfe)+dgcn(3,nfe)*t**(-dgcn(4,nfe))
21519  dgd=dgdn(1,nfe)*t**dgdn(2,nfe)+dgdn(3,nfe)*t**(-dgdn(4,nfe))
21520  dge=dgen(1,nfe)*t**dgen(2,nfe)+dgen(3,nfe)*t**(-dgen(4,nfe))
21521  xpqn=x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
21522  dga=dgas(1,nfe)*t**dgas(2,nfe)+dgas(3,nfe)*t**(-dgas(4,nfe))
21523  dgb=dgbs(1,nfe)*t**dgbs(2,nfe)+dgbs(3,nfe)*t**(-dgbs(4,nfe))
21524  dgc=dgcs(1,nfe)*t**dgcs(2,nfe)+dgcs(3,nfe)*t**(-dgcs(4,nfe))
21525  dgd=dgds(1,nfe)*t**dgds(2,nfe)+dgds(3,nfe)*t**(-dgds(4,nfe))
21526  dge=dges(1,nfe)*t**dges(2,nfe)+dges(3,nfe)*t**(-dges(4,nfe))
21527  dgf=9d0
21528  IF(nf.EQ.4) dgf=10d0
21529  IF(nf.EQ.5) dgf=55d0/6d0
21530  xpqs=dgf*x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
21531  IF(nf.LE.3) THEN
21532  xpqu=(xpqs+9d0*xpqn)/6d0
21533  xpqd=(xpqs-4.5d0*xpqn)/6d0
21534  ELSEIF(nf.EQ.4) THEN
21535  xpqu=(xpqs+6d0*xpqn)/8d0
21536  xpqd=(xpqs-6d0*xpqn)/8d0
21537  ELSE
21538  xpqu=(xpqs+7.5d0*xpqn)/10d0
21539  xpqd=(xpqs-5d0*xpqn)/10d0
21540  ENDIF
21541 
21542 C...Put into output arrays.
21543  xpga(0)=aem*xpgl
21544  xpga(1)=aem*xpqd
21545  xpga(2)=aem*xpqu
21546  xpga(3)=aem*xpqd
21547  IF(nf.GE.4) xpga(4)=aem*xpqu
21548  IF(nf.GE.5) xpga(5)=aem*xpqd
21549  DO 110 kfl=1,6
21550  xpga(-kfl)=xpga(kfl)
21551  110 CONTINUE
21552 
21553  RETURN
21554  END
21555 
21556 C*********************************************************************
21557 
21558 C...PYGGAM
21559 C...Constructs the F2 and parton distributions of the photon
21560 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
21561 C...For F2, c and b are included by the Bethe-Heitler formula;
21562 C...in the 'MSbar' scheme additionally a Cgamma term is added.
21563 C...Contains the SaS sets 1D, 1M, 2D and 2M.
21564 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21565 
21566  SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
21567 
21568 C...Double precision and integer declarations.
21569  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21570  INTEGER pyk,pychge,pycomp
21571 C...Commonblocks.
21572  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
21573  &xpdir(-6:6)
21574  common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
21575  SAVE /pyint8/,/pyint9/
21576 C...Local arrays.
21577  dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)
21578 C...Charm and bottom masses (low to compensate for J/psi etc.).
21579  DATA pmc/1.3d0/, pmb/4.6d0/
21580 C...alpha_em and alpha_em/(2*pi).
21581  DATA aem/0.007297d0/, aem2pi/0.0011614d0/
21582 C...Lambda value for 4 flavours.
21583  DATA alam/0.20d0/
21584 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
21585  DATA fracu/0.8d0/
21586 C...VMD couplings f_V**2/(4*pi).
21587  DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/
21588 C...Masses for rho (=omega) and phi.
21589  DATA pmrho/0.770d0/, pmphi/1.020d0/
21590 C...Number of points in integration for IP2=1.
21591  DATA nstep/100/
21592 
21593 C...Reset output.
21594  f2gm=0d0
21595  DO 100 kfl=-6,6
21596  xpdfgm(kfl)=0d0
21597  xpvmd(kfl)=0d0
21598  xpanl(kfl)=0d0
21599  xpanh(kfl)=0d0
21600  xpbeh(kfl)=0d0
21601  xpdir(kfl)=0d0
21602  vxpvmd(kfl)=0d0
21603  vxpanl(kfl)=0d0
21604  vxpanh(kfl)=0d0
21605  vxpdgm(kfl)=0d0
21606  100 CONTINUE
21607 
21608 C...Set Q0 cut-off parameter as function of set used.
21609  IF(iset.LE.2) THEN
21610  q0=0.6d0
21611  ELSE
21612  q0=2d0
21613  ENDIF
21614  q02=q0**2
21615 
21616 C...Scale choice for off-shell photon; common factors.
21617  q2a=q2
21618  facnor=1d0
21619  IF(ip2.EQ.1) THEN
21620  p2mx=p2+q02
21621  q2a=q2+p2*q02/max(q02,q2)
21622  facnor=log(q2/q02)/nstep
21623  ELSEIF(ip2.EQ.2) THEN
21624  p2mx=max(p2,q02)
21625  ELSEIF(ip2.EQ.3) THEN
21626  p2mx=p2+q02
21627  q2a=q2+p2*q02/max(q02,q2)
21628  ELSEIF(ip2.EQ.4) THEN
21629  p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
21630  & ((q2+p2)*(q02+p2)))
21631  ELSEIF(ip2.EQ.5) THEN
21632  p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
21633  & ((q2+p2)*(q02+p2)))
21634  p2mx=q0*sqrt(p2mxa)
21635  facnor=log(q2/p2mxa)/log(q2/p2mx)
21636  ELSEIF(ip2.EQ.6) THEN
21637  p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
21638  & ((q2+p2)*(q02+p2)))
21639  p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
21640  ELSE
21641  p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
21642  & ((q2+p2)*(q02+p2)))
21643  p2mx=q0*sqrt(p2mxa)
21644  p2mxb=p2mx
21645  p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
21646  p2mxb=max(0d0,1d0-p2/q2)*p2mxb+min(1d0,p2/q2)*p2mxa
21647  facnor=log(q2/p2mxa)/log(q2/p2mxb)
21648  ENDIF
21649 
21650 C...Call VMD parametrization for d quark and use to give rho, omega,
21651 C...phi. Note dipole dampening for off-shell photon.
21652  CALL pygvmd(iset,1,x,q2a,p2mx,alam,xpga,vxpga)
21653  xfval=vxpga(1)
21654  xpga(1)=xpga(2)
21655  xpga(-1)=xpga(-2)
21656  facud=aem*(1d0/frho+1d0/fomega)*(pmrho**2/(pmrho**2+p2))**2
21657  facs=aem*(1d0/fphi)*(pmphi**2/(pmphi**2+p2))**2
21658  DO 110 kfl=-5,5
21659  xpvmd(kfl)=(facud+facs)*xpga(kfl)
21660  110 CONTINUE
21661  xpvmd(1)=xpvmd(1)+(1d0-fracu)*facud*xfval
21662  xpvmd(2)=xpvmd(2)+fracu*facud*xfval
21663  xpvmd(3)=xpvmd(3)+facs*xfval
21664  xpvmd(-1)=xpvmd(-1)+(1d0-fracu)*facud*xfval
21665  xpvmd(-2)=xpvmd(-2)+fracu*facud*xfval
21666  xpvmd(-3)=xpvmd(-3)+facs*xfval
21667  vxpvmd(1)=(1d0-fracu)*facud*xfval
21668  vxpvmd(2)=fracu*facud*xfval
21669  vxpvmd(3)=facs*xfval
21670  vxpvmd(-1)=(1d0-fracu)*facud*xfval
21671  vxpvmd(-2)=fracu*facud*xfval
21672  vxpvmd(-3)=facs*xfval
21673 
21674  IF(ip2.NE.1) THEN
21675 C...Anomalous parametrizations for different strategies
21676 C...for off-shell photons; except full integration.
21677 
21678 C...Call anomalous parametrization for d + u + s.
21679  CALL pygano(-3,x,q2a,p2mx,alam,xpga,vxpga)
21680  DO 120 kfl=-5,5
21681  xpanl(kfl)=facnor*xpga(kfl)
21682  vxpanl(kfl)=facnor*vxpga(kfl)
21683  120 CONTINUE
21684 
21685 C...Call anomalous parametrization for c and b.
21686  CALL pygano(4,x,q2a,p2mx,alam,xpga,vxpga)
21687  DO 130 kfl=-5,5
21688  xpanh(kfl)=facnor*xpga(kfl)
21689  vxpanh(kfl)=facnor*vxpga(kfl)
21690  130 CONTINUE
21691  CALL pygano(5,x,q2a,p2mx,alam,xpga,vxpga)
21692  DO 140 kfl=-5,5
21693  xpanh(kfl)=xpanh(kfl)+facnor*xpga(kfl)
21694  vxpanh(kfl)=vxpanh(kfl)+facnor*vxpga(kfl)
21695  140 CONTINUE
21696 
21697  ELSE
21698 C...Special option: loop over flavours and integrate over k2.
21699  DO 170 kf=1,5
21700  DO 160 istep=1,nstep
21701  q2step=q02*(q2/q02)**((istep-0.5d0)/nstep)
21702  IF((kf.EQ.4.AND.q2step.LT.pmc**2).OR.
21703  & (kf.EQ.5.AND.q2step.LT.pmb**2)) goto 160
21704  CALL pygvmd(0,kf,x,q2,q2step,alam,xpga,vxpga)
21705  facq=aem2pi*(q2step/(q2step+p2))**2*facnor
21706  IF(mod(kf,2).EQ.0) facq=facq*(8d0/9d0)
21707  IF(mod(kf,2).EQ.1) facq=facq*(2d0/9d0)
21708  DO 150 kfl=-5,5
21709  IF(kf.LE.3) xpanl(kfl)=xpanl(kfl)+facq*xpga(kfl)
21710  IF(kf.GE.4) xpanh(kfl)=xpanh(kfl)+facq*xpga(kfl)
21711  IF(kf.LE.3) vxpanl(kfl)=vxpanl(kfl)+facq*vxpga(kfl)
21712  IF(kf.GE.4) vxpanh(kfl)=vxpanh(kfl)+facq*vxpga(kfl)
21713  150 CONTINUE
21714  160 CONTINUE
21715  170 CONTINUE
21716  ENDIF
21717 
21718 C...Call Bethe-Heitler term expression for charm and bottom.
21719  CALL pygbeh(4,x,q2,p2,pmc**2,xpbh)
21720  xpbeh(4)=xpbh
21721  xpbeh(-4)=xpbh
21722  CALL pygbeh(5,x,q2,p2,pmb**2,xpbh)
21723  xpbeh(5)=xpbh
21724  xpbeh(-5)=xpbh
21725 
21726 C...For MSbar subtraction call C^gamma term expression for d, u, s.
21727  IF(iset.EQ.2.OR.iset.EQ.4) THEN
21728  CALL pygdir(x,q2,p2,q02,xpga)
21729  DO 180 kfl=-5,5
21730  xpdir(kfl)=xpga(kfl)
21731  180 CONTINUE
21732  ENDIF
21733 
21734 C...Store result in output array.
21735  DO 190 kfl=-5,5
21736  chsq=1d0/9d0
21737  IF(iabs(kfl).EQ.2.OR.iabs(kfl).EQ.4) chsq=4d0/9d0
21738  xpf2=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
21739  IF(kfl.NE.0) f2gm=f2gm+chsq*xpf2
21740  xpdfgm(kfl)=xpvmd(kfl)+xpanl(kfl)+xpanh(kfl)
21741  vxpdgm(kfl)=vxpvmd(kfl)+vxpanl(kfl)+vxpanh(kfl)
21742  190 CONTINUE
21743 
21744  RETURN
21745  END
21746 
21747 C*********************************************************************
21748 
21749 C...PYGVMD
21750 C...Evaluates the VMD parton distributions of a photon,
21751 C...evolved homogeneously from an initial scale P2 to Q2.
21752 C...Does not include dipole suppression factor.
21753 C...ISET is parton distribution set, see above;
21754 C...additionally ISET=0 is used for the evolution of an anomalous photon
21755 C...which branched at a scale P2 and then evolved homogeneously to Q2.
21756 C...ALAM is the 4-flavour Lambda, which is automatically converted
21757 C...to 3- and 5-flavour equivalents as needed.
21758 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21759 
21760  SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21761 
21762 C...Double precision and integer declarations.
21763  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21764  INTEGER pyk,pychge,pycomp
21765 C...Local arrays and data.
21766  dimension xpga(-6:6), vxpga(-6:6)
21767  DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
21768 
21769 C...Reset output.
21770  DO 100 kfl=-6,6
21771  xpga(kfl)=0d0
21772  vxpga(kfl)=0d0
21773  100 CONTINUE
21774  kfa=iabs(kf)
21775 
21776 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21777  alam3=alam*(pmc/alam)**(2d0/27d0)
21778  alam5=alam*(alam/pmb)**(2d0/23d0)
21779  p2eff=max(p2,1.2d0*alam3**2)
21780  IF(kfa.EQ.4) p2eff=max(p2eff,pmc**2)
21781  IF(kfa.EQ.5) p2eff=max(p2eff,pmb**2)
21782  q2eff=max(q2,p2eff)
21783 
21784 C...Find number of flavours at lower and upper scale.
21785  nfp=4
21786  IF(p2eff.LT.pmc**2) nfp=3
21787  IF(p2eff.GT.pmb**2) nfp=5
21788  nfq=4
21789  IF(q2eff.LT.pmc**2) nfq=3
21790  IF(q2eff.GT.pmb**2) nfq=5
21791 
21792 C...Find s as sum of 3-, 4- and 5-flavour parts.
21793  s=0d0
21794  IF(nfp.EQ.3) THEN
21795  q2div=pmc**2
21796  IF(nfq.EQ.3) q2div=q2eff
21797  s=s+(6d0/27d0)*log(log(q2div/alam3**2)/log(p2eff/alam3**2))
21798  ENDIF
21799  IF(nfp.LE.4.AND.nfq.GE.4) THEN
21800  p2div=p2eff
21801  IF(nfp.EQ.3) p2div=pmc**2
21802  q2div=q2eff
21803  IF(nfq.EQ.5) q2div=pmb**2
21804  s=s+(6d0/25d0)*log(log(q2div/alam**2)/log(p2div/alam**2))
21805  ENDIF
21806  IF(nfq.EQ.5) THEN
21807  p2div=pmb**2
21808  IF(nfp.EQ.5) p2div=p2eff
21809  s=s+(6d0/23d0)*log(log(q2eff/alam5**2)/log(p2div/alam5**2))
21810  ENDIF
21811 
21812 C...Calculate frequent combinations of x and s.
21813  x1=1d0-x
21814  xl=-log(x)
21815  s2=s**2
21816  s3=s**3
21817  s4=s**4
21818 
21819 C...Evaluate homogeneous anomalous parton distributions below or
21820 C...above threshold.
21821  IF(iset.EQ.0) THEN
21822  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
21823  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
21824  xval = x * 1.5d0 * (x**2+x1**2)
21825  xglu = 0d0
21826  xsea = 0d0
21827  ELSE
21828  xval = (1.5d0/(1d0-0.197d0*s+4.33d0*s2)*x**2 +
21829  & (1.5d0+2.10d0*s)/(1d0+3.29d0*s)*x1**2 +
21830  & 5.23d0*s/(1d0+1.17d0*s+19.9d0*s3)*x*x1) *
21831  & x**(1d0/(1d0+1.5d0*s)) * (1d0-x**2)**(2.667d0*s)
21832  xglu = 4d0*s/(1d0+4.76d0*s+15.2d0*s2+29.3d0*s4) *
21833  & x**(-2.03d0*s/(1d0+2.44d0*s)) * (x1*xl)**(1.333d0*s) *
21834  & ((4d0*x**2+7d0*x+4d0)*x1/3d0 - 2d0*x*(1d0+x)*xl)
21835  xsea = s2/(1d0+4.54d0*s+8.19d0*s2+8.05d0*s3) *
21836  & x**(-1.54d0*s/(1d0+1.29d0*s)) * x1**(2.667d0*s) *
21837  & ((8d0-73d0*x+62d0*x**2)*x1/9d0 + (3d0-8d0*x**2/3d0)*x*xl +
21838  & (2d0*x-1d0)*x*xl**2)
21839  ENDIF
21840 
21841 C...Evaluate set 1D parton distributions below or above threshold.
21842  ELSEIF(iset.EQ.1) THEN
21843  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
21844  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
21845  xval = 1.294d0 * x**0.80d0 * x1**0.76d0
21846  xglu = 1.273d0 * x**0.40d0 * x1**1.76d0
21847  xsea = 0.100d0 * x1**3.76d0
21848  ELSE
21849  xval = 1.294d0/(1d0+0.252d0*s+3.079d0*s2) *
21850  & x**(0.80d0-0.13d0*s) * x1**(0.76d0+0.667d0*s) * xl**(2d0*s)
21851  xglu = 7.90d0*s/(1d0+5.50d0*s) * exp(-5.16d0*s) *
21852  & x**(-1.90d0*s/(1d0+3.60d0*s)) * x1**1.30d0 *
21853  & xl**(0.50d0+3d0*s) + 1.273d0 * exp(-10d0*s) *
21854  & x**0.40d0 * x1**(1.76d0+3d0*s)
21855  xsea = (0.1d0-0.397d0*s2+1.121d0*s3)/
21856  & (1d0+5.61d0*s2+5.26d0*s3) * x**(-7.32d0*s2/(1d0+10.3d0*s2)) *
21857  & x1**((3.76d0+15d0*s+12d0*s2)/(1d0+4d0*s))
21858  xsea0 = 0.100d0 * x1**3.76d0
21859  ENDIF
21860 
21861 C...Evaluate set 1M parton distributions below or above threshold.
21862  ELSEIF(iset.EQ.2) THEN
21863  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
21864  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
21865  xval = 0.8477d0 * x**0.51d0 * x1**1.37d0
21866  xglu = 3.42d0 * x**0.255d0 * x1**2.37d0
21867  xsea = 0d0
21868  ELSE
21869  xval = 0.8477d0/(1d0+1.37d0*s+2.18d0*s2+3.73d0*s3) *
21870  & x**(0.51d0+0.21d0*s) * x1**1.37d0 * xl**(2.667d0*s)
21871  xglu = 24d0*s/(1d0+9.6d0*s+0.92d0*s2+14.34d0*s3) *
21872  & exp(-5.94d0*s) * x**((-0.013d0-1.80d0*s)/(1d0+3.14d0*s)) *
21873  & x1**(2.37d0+0.4d0*s) * xl**(0.32d0+3.6d0*s) + 3.42d0 *
21874  & exp(-12d0*s) * x**0.255d0 * x1**(2.37d0+3d0*s)
21875  xsea = 0.842d0*s/(1d0+21.3d0*s-33.2d0*s2+229d0*s3) *
21876  & x**((0.13d0-2.90d0*s)/(1d0+5.44d0*s)) * x1**(3.45d0+0.5d0*s) *
21877  & xl**(2.8d0*s)
21878  xsea0 = 0d0
21879  ENDIF
21880 
21881 C...Evaluate set 2D parton distributions below or above threshold.
21882  ELSEIF(iset.EQ.3) THEN
21883  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
21884  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
21885  xval = x**0.46d0 * x1**0.64d0 + 0.76d0 * x
21886  xglu = 1.925d0 * x1**2
21887  xsea = 0.242d0 * x1**4
21888  ELSE
21889  xval = (1d0+0.186d0*s)/(1d0-0.209d0*s+1.495d0*s2) *
21890  & x**(0.46d0+0.25d0*s) *
21891  & x1**((0.64d0+0.14d0*s+5d0*s2)/(1d0+s)) * xl**(1.9d0*s) +
21892  & (0.76d0+0.4d0*s) * x * x1**(2.667d0*s)
21893  xglu = (1.925d0+5.55d0*s+147d0*s2)/(1d0-3.59d0*s+3.32d0*s2) *
21894  & exp(-18.67d0*s) *
21895  & x**((-5.81d0*s-5.34d0*s2)/(1d0+29d0*s-4.26d0*s2))
21896  & * x1**((2d0-5.9d0*s)/(1d0+1.7d0*s)) *
21897  & xl**(9.3d0*s/(1d0+1.7d0*s))
21898  xsea = (0.242d0-0.252d0*s+1.19d0*s2)/
21899  & (1d0-0.607d0*s+21.95d0*s2) *
21900  & x**(-12.1d0*s2/(1d0+2.62d0*s+16.7d0*s2)) * x1**4 * xl**s
21901  xsea0 = 0.242d0 * x1**4
21902  ENDIF
21903 
21904 C...Evaluate set 2M parton distributions below or above threshold.
21905  ELSEIF(iset.EQ.4) THEN
21906  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
21907  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
21908  xval = 1.168d0 * x**0.50d0 * x1**2.60d0 + 0.965d0 * x
21909  xglu = 1.808d0 * x1**2
21910  xsea = 0.209d0 * x1**4
21911  ELSE
21912  xval = (1.168d0+1.771d0*s+29.35d0*s2) * exp(-5.776d0*s) *
21913  & x**((0.5d0+0.208d0*s)/(1d0-0.794d0*s+1.516d0*s2)) *
21914  & x1**((2.6d0+7.6d0*s)/(1d0+5d0*s)) *
21915  & xl**(5.15d0*s/(1d0+2d0*s)) +
21916  & (0.965d0+22.35d0*s)/(1d0+18.4d0*s) * x * x1**(2.667d0*s)
21917  xglu = (1.808d0+29.9d0*s)/(1d0+26.4d0*s) * exp(-5.28d0*s) *
21918  & x**((-5.35d0*s-10.11d0*s2)/(1d0+31.71d0*s)) *
21919  & x1**((2d0-7.3d0*s+4d0*s2)/(1d0+2.5d0*s)) *
21920  & xl**(10.9d0*s/(1d0+2.5d0*s))
21921  xsea = (0.209d0+0.644d0*s2)/(1d0+0.319d0*s+17.6d0*s2) *
21922  & x**((-0.373d0*s-7.71d0*s2)/(1d0+0.815d0*s+11.0d0*s2)) *
21923  & x1**(4d0+s) * xl**(0.45d0*s)
21924  xsea0 = 0.209d0 * x1**4
21925  ENDIF
21926  ENDIF
21927 
21928 C...Threshold factors for c and b sea.
21929  sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
21930  xchm=0d0
21931  IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
21932  sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
21933  IF(iset.EQ.0) THEN
21934  xchm=xsea*(1d0-(sch/sll)**2)
21935  ELSE
21936  xchm=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sch/sll)
21937  ENDIF
21938  ENDIF
21939  xbot=0d0
21940  IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
21941  sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
21942  IF(iset.EQ.0) THEN
21943  xbot=xsea*(1d0-(sbt/sll)**2)
21944  ELSE
21945  xbot=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sbt/sll)
21946  ENDIF
21947  ENDIF
21948 
21949 C...Fill parton distributions.
21950  xpga(0)=xglu
21951  xpga(1)=xsea
21952  xpga(2)=xsea
21953  xpga(3)=xsea
21954  xpga(4)=xchm
21955  xpga(5)=xbot
21956  xpga(kfa)=xpga(kfa)+xval
21957  DO 110 kfl=1,5
21958  xpga(-kfl)=xpga(kfl)
21959  110 CONTINUE
21960  vxpga(kfa)=xval
21961  vxpga(-kfa)=xval
21962 
21963  RETURN
21964  END
21965 
21966 C*********************************************************************
21967 
21968 C...PYGANO
21969 C...Evaluates the parton distributions of the anomalous photon,
21970 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
21971 C...KF=0 gives the sum over (up to) 5 flavours,
21972 C...KF<0 limits to flavours up to abs(KF),
21973 C...KF>0 is for flavour KF only.
21974 C...ALAM is the 4-flavour Lambda, which is automatically converted
21975 C...to 3- and 5-flavour equivalents as needed.
21976 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21977 
21978  SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21979 
21980 C...Double precision and integer declarations.
21981  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21982  INTEGER pyk,pychge,pycomp
21983 C...Local arrays and data.
21984  dimension xpga(-6:6), vxpga(-6:6), alamsq(3:5)
21985  DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
21986 
21987 C...Reset output.
21988  DO 100 kfl=-6,6
21989  xpga(kfl)=0d0
21990  vxpga(kfl)=0d0
21991  100 CONTINUE
21992  IF(q2.LE.p2) RETURN
21993  kfa=iabs(kf)
21994 
21995 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21996  alamsq(3)=(alam*(pmc/alam)**(2d0/27d0))**2
21997  alamsq(4)=alam**2
21998  alamsq(5)=(alam*(alam/pmb)**(2d0/23d0))**2
21999  p2eff=max(p2,1.2d0*alamsq(3))
22000  IF(kf.EQ.4) p2eff=max(p2eff,pmc**2)
22001  IF(kf.EQ.5) p2eff=max(p2eff,pmb**2)
22002  q2eff=max(q2,p2eff)
22003  xl=-log(x)
22004 
22005 C...Find number of flavours at lower and upper scale.
22006  nfp=4
22007  IF(p2eff.LT.pmc**2) nfp=3
22008  IF(p2eff.GT.pmb**2) nfp=5
22009  nfq=4
22010  IF(q2eff.LT.pmc**2) nfq=3
22011  IF(q2eff.GT.pmb**2) nfq=5
22012 
22013 C...Define range of flavour loop.
22014  IF(kf.EQ.0) THEN
22015  kflmn=1
22016  kflmx=5
22017  ELSEIF(kf.LT.0) THEN
22018  kflmn=1
22019  kflmx=kfa
22020  ELSE
22021  kflmn=kfa
22022  kflmx=kfa
22023  ENDIF
22024 
22025 C...Loop over flavours the photon can branch into.
22026  DO 110 kfl=kflmn,kflmx
22027 
22028 C...Light flavours: calculate t range and (approximate) s range.
22029  IF(kfl.LE.3.AND.(kfl.EQ.1.OR.kfl.EQ.kf)) THEN
22030  tdiff=log(q2eff/p2eff)
22031  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
22032  & log(p2eff/alamsq(nfq)))
22033  IF(nfq.GT.nfp) THEN
22034  q2div=pmb**2
22035  IF(nfq.EQ.4) q2div=pmc**2
22036  snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
22037  & log(p2eff/alamsq(nfq)))
22038  snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
22039  & log(p2eff/alamsq(nfq-1)))
22040  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
22041  ENDIF
22042  IF(nfq.EQ.5.AND.nfp.EQ.3) THEN
22043  q2div=pmc**2
22044  snf4=(6d0/(33d0-2d0*4))*log(log(q2div/alamsq(4))/
22045  & log(p2eff/alamsq(4)))
22046  snf3=(6d0/(33d0-2d0*3))*log(log(q2div/alamsq(3))/
22047  & log(p2eff/alamsq(3)))
22048  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snf3-snf4)
22049  ENDIF
22050 
22051 C...u and s quark do not need a separate treatment when d has been done.
22052  ELSEIF(kfl.EQ.2.OR.kfl.EQ.3) THEN
22053 
22054 C...Charm: as above, but only include range above c threshold.
22055  ELSEIF(kfl.EQ.4) THEN
22056  IF(q2.LE.pmc**2) goto 110
22057  p2eff=max(p2eff,pmc**2)
22058  q2eff=max(q2eff,p2eff)
22059  tdiff=log(q2eff/p2eff)
22060  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
22061  & log(p2eff/alamsq(nfq)))
22062  IF(nfq.EQ.5.AND.nfp.EQ.4) THEN
22063  q2div=pmb**2
22064  snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
22065  & log(p2eff/alamsq(nfq)))
22066  snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
22067  & log(p2eff/alamsq(nfq-1)))
22068  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
22069  ENDIF
22070 
22071 C...Bottom: as above, but only include range above b threshold.
22072  ELSEIF(kfl.EQ.5) THEN
22073  IF(q2.LE.pmb**2) goto 110
22074  p2eff=max(p2eff,pmb**2)
22075  q2eff=max(q2,p2eff)
22076  tdiff=log(q2eff/p2eff)
22077  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
22078  & log(p2eff/alamsq(nfq)))
22079  ENDIF
22080 
22081 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
22082  chsq=1d0/9d0
22083  IF(kfl.EQ.2.OR.kfl.EQ.4) chsq=4d0/9d0
22084  fac=aem2pi*2d0*chsq*tdiff
22085 
22086 C...Evaluate parton distributions (normalized to unit momentum sum).
22087  IF(kfl.EQ.1.OR.kfl.EQ.4.OR.kfl.EQ.5.OR.kfl.EQ.kf) THEN
22088  xval= ((1.5d0+2.49d0*s+26.9d0*s**2)/(1d0+32.3d0*s**2)*x**2 +
22089  & (1.5d0-0.49d0*s+7.83d0*s**2)/(1d0+7.68d0*s**2)*(1d0-x)**2 +
22090  & 1.5d0*s/(1d0-3.2d0*s+7d0*s**2)*x*(1d0-x)) *
22091  & x**(1d0/(1d0+0.58d0*s)) * (1d0-x**2)**(2.5d0*s/(1d0+10d0*s))
22092  xglu= 2d0*s/(1d0+4d0*s+7d0*s**2) *
22093  & x**(-1.67d0*s/(1d0+2d0*s)) * (1d0-x**2)**(1.2d0*s) *
22094  & ((4d0*x**2+7d0*x+4d0)*(1d0-x)/3d0 - 2d0*x*(1d0+x)*xl)
22095  xsea= 0.333d0*s**2/(1d0+4.90d0*s+4.69d0*s**2+21.4d0*s**3) *
22096  & x**(-1.18d0*s/(1d0+1.22d0*s)) * (1d0-x)**(1.2d0*s) *
22097  & ((8d0-73d0*x+62d0*x**2)*(1d0-x)/9d0 +
22098  & (3d0-8d0*x**2/3d0)*x*xl + (2d0*x-1d0)*x*xl**2)
22099 
22100 C...Threshold factors for c and b sea.
22101  sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
22102  xchm=0d0
22103  IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
22104  sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
22105  xchm=xsea*(1d0-(sch/sll)**3)
22106  ENDIF
22107  xbot=0d0
22108  IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
22109  sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
22110  xbot=xsea*(1d0-(sbt/sll)**3)
22111  ENDIF
22112  ENDIF
22113 
22114 C...Add contribution of each valence flavour.
22115  xpga(0)=xpga(0)+fac*xglu
22116  xpga(1)=xpga(1)+fac*xsea
22117  xpga(2)=xpga(2)+fac*xsea
22118  xpga(3)=xpga(3)+fac*xsea
22119  xpga(4)=xpga(4)+fac*xchm
22120  xpga(5)=xpga(5)+fac*xbot
22121  xpga(kfl)=xpga(kfl)+fac*xval
22122  vxpga(kfl)=vxpga(kfl)+fac*xval
22123  110 CONTINUE
22124  DO 120 kfl=1,5
22125  xpga(-kfl)=xpga(kfl)
22126  vxpga(-kfl)=vxpga(kfl)
22127  120 CONTINUE
22128 
22129  RETURN
22130  END
22131 
22132 C*********************************************************************
22133 
22134 C...PYGBEH
22135 C...Evaluates the Bethe-Heitler cross section for heavy flavour
22136 C...production.
22137 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22138 
22139  SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)
22140 C...Double precision and integer declarations.
22141  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22142  INTEGER pyk,pychge,pycomp
22143 
22144 C...Local data.
22145  DATA aem2pi/0.0011614d0/
22146 
22147 C...Reset output.
22148  xpbh=0d0
22149  sigbh=0d0
22150 
22151 C...Check kinematics limits.
22152  IF(x.GE.q2/(4d0*pm2+q2+p2)) RETURN
22153  w2=q2*(1d0-x)/x-p2
22154  beta2=1d0-4d0*pm2/w2
22155  IF(beta2.LT.1d-10) RETURN
22156  beta=sqrt(beta2)
22157  rmq=4d0*pm2/q2
22158 
22159 C...Simple case: P2 = 0.
22160  IF(p2.LT.1d-4) THEN
22161  IF(beta.LT.0.99d0) THEN
22162  xbl=log((1d0+beta)/(1d0-beta))
22163  ELSE
22164  xbl=log((1d0+beta)**2*w2/(4d0*pm2))
22165  ENDIF
22166  sigbh=beta*(8d0*x*(1d0-x)-1d0-rmq*x*(1d0-x))+
22167  & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)
22168 
22169 C...Complicated case: P2 > 0, based on approximation of
22170 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
22171  ELSE
22172  rpq=1d0-4d0*x**2*p2/q2
22173  IF(rpq.GT.1d-10) THEN
22174  rpbe=sqrt(rpq*beta2)
22175  IF(rpbe.LT.0.99d0) THEN
22176  xbl=log((1d0+rpbe)/(1d0-rpbe))
22177  xbi=2d0*rpbe/(1d0-rpbe**2)
22178  ELSE
22179  rpbesn=4d0*pm2/w2+(4d0*x**2*p2/q2)*beta2
22180  xbl=log((1d0+rpbe)**2/rpbesn)
22181  xbi=2d0*rpbe/rpbesn
22182  ENDIF
22183  sigbh=beta*(6d0*x*(1d0-x)-1d0)+
22184  & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)+
22185  & xbi*(2d0*x/q2)*(pm2*x*(2d0-rmq)-p2*x)
22186  ENDIF
22187  ENDIF
22188 
22189 C...Multiply by charge-squared etc. to get parton distribution.
22190  chsq=1d0/9d0
22191  IF(iabs(kf).EQ.2.OR.iabs(kf).EQ.4) chsq=4d0/9d0
22192  xpbh=3d0*chsq*aem2pi*x*sigbh
22193 
22194  RETURN
22195  END
22196 
22197 C*********************************************************************
22198 
22199 C...PYGDIR
22200 C...Evaluates the direct contribution, i.e. the C^gamma term,
22201 C...as needed in MSbar parametrizations.
22202 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22203 
22204  SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)
22205 
22206 C...Double precision and integer declarations.
22207  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22208  INTEGER pyk,pychge,pycomp
22209 C...Local array and data.
22210  dimension xpga(-6:6)
22211  DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/
22212 
22213 C...Reset output.
22214  DO 100 kfl=-6,6
22215  xpga(kfl)=0d0
22216  100 CONTINUE
22217 
22218 C...Evaluate common x-dependent expression.
22219  xtmp = (x**2+(1d0-x)**2) * (-log(x)) - 1d0
22220  cgam = 3d0*aem2pi*x * (xtmp*(1d0+p2/(p2+q02)) + 6d0*x*(1d0-x))
22221 
22222 C...d, u, s part by simple charge factor.
22223  xpga(1)=(1d0/9d0)*cgam
22224  xpga(2)=(4d0/9d0)*cgam
22225  xpga(3)=(1d0/9d0)*cgam
22226 
22227 C...Also fill for antiquarks.
22228  DO 110 kf=1,5
22229  xpga(-kf)=xpga(kf)
22230  110 CONTINUE
22231 
22232  RETURN
22233  END
22234 
22235 C*********************************************************************
22236 
22237 C...PYPDPI
22238 C...Gives pi+ parton distribution according to two different
22239 C...parametrizations.
22240 
22241  SUBROUTINE pypdpi(X,Q2,XPPI)
22242 
22243 C...Double precision and integer declarations.
22244  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22245  INTEGER pyk,pychge,pycomp
22246 C...Commonblocks.
22247  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
22248  common/pypars/mstp(200),parp(200),msti(200),pari(200)
22249  common/pyint1/mint(400),vint(400)
22250  SAVE /pydat1/,/pypars/,/pyint1/
22251 C...Local arrays.
22252  dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)
22253 
22254 C...The following data lines are coefficients needed in the
22255 C...Owens pion parton distribution parametrizations, see below.
22256 C...Expansion coefficients for up and down valence quark distributions.
22257  DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/
22258  &4.0000d-01, 7.0000d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
22259  &-6.2120d-02, 6.4780d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
22260  &-7.1090d-03, 1.3350d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
22261  DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/
22262  &4.0000d-01, 6.2800d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
22263  &-5.9090d-02, 6.4360d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
22264  &-6.5240d-03, 1.4510d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
22265 C...Expansion coefficients for gluon distribution.
22266  DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/
22267  &8.8800d-01, 0.0000d+00, 3.1100d+00, 6.0000d+00, 0.0000d+00,
22268  &-1.8020d+00, -1.5760d+00, -1.3170d-01, 2.8010d+00, -1.7280d+01,
22269  &1.8120d+00, 1.2000d+00, 5.0680d-01, -1.2160d+01, 2.0490d+01/
22270  DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/
22271  &7.9400d-01, 0.0000d+00, 2.8900d+00, 6.0000d+00, 0.0000d+00,
22272  &-9.1440d-01, -1.2370d+00, 5.9660d-01, -3.6710d+00, -8.1910d+00,
22273  &5.9660d-01, 6.5820d-01, -2.5500d-01, -2.3040d+00, 7.7580d+00/
22274 C...Expansion coefficients for (up+down+strange) quark sea distribution.
22275  DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/
22276  &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
22277  &-2.4280d-01, -2.1200d-01, 8.6730d-01, 1.2660d+00, 2.3820d+00,
22278  &1.3860d-01, 3.6710d-03, 4.7470d-02, -2.2150d+00, 3.4820d-01/
22279  DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/
22280  &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
22281  &-1.4170d-01, -1.6970d-01, -2.4740d+00, -2.5340d+00, 5.6210d-01,
22282  &-1.7400d-01, -9.6230d-02, 1.5750d+00, 1.3780d+00, -2.7010d-01/
22283 C...Expansion coefficients for charm quark sea distribution.
22284  DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/
22285  &0.0000d+00, -2.2120d-02, 2.8940d+00, 0.0000d+00, 0.0000d+00,
22286  &7.9280d-02, -3.7850d-01, 9.4330d+00, 5.2480d+00, 8.3880d+00,
22287  &-6.1340d-02, -1.0880d-01, -1.0852d+01, -7.1870d+00, -1.1610d+01/
22288  DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/
22289  &0.0000d+00, -8.8200d-02, 1.9240d+00, 0.0000d+00, 0.0000d+00,
22290  &6.2290d-02, -2.8920d-01, 2.4240d-01, -4.4630d+00, -8.3670d-01,
22291  &-4.0990d-02, -1.0820d-01, 2.0360d+00, 5.2090d+00, -4.8400d-02/
22292 
22293 C...Euler's beta function, requires ordinary Gamma function
22294  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
22295 
22296 C...Reset output array.
22297  DO 100 kfl=-6,6
22298  xppi(kfl)=0d0
22299  100 CONTINUE
22300 
22301  IF(mstp(53).LE.2) THEN
22302 C...Pion parton distributions from Owens.
22303 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
22304 
22305 C...Determine set, Lambda and s expansion variable.
22306  nset=mstp(53)
22307  IF(nset.EQ.1) alam=0.2d0
22308  IF(nset.EQ.2) alam=0.4d0
22309  vint(231)=4d0
22310  IF(mstp(57).LE.0) THEN
22311  sd=0d0
22312  ELSE
22313  q2in=min(2d3,max(4d0,q2))
22314  sd=log(log(q2in/alam**2)/log(4d0/alam**2))
22315  ENDIF
22316 
22317 C...Calculate parton distributions.
22318  DO 120 kfl=1,4
22319  DO 110 is=1,5
22320  ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+
22321  & cow(3,is,kfl,nset)*sd**2
22322  110 CONTINUE
22323  IF(kfl.EQ.1) THEN
22324  xq(kfl)=x**ts(1)*(1d0-x)**ts(2)/eulbet(ts(1),ts(2)+1d0)
22325  ELSE
22326  xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
22327  & ts(5)*x**2)
22328  ENDIF
22329  120 CONTINUE
22330 
22331 C...Put into output array.
22332  xppi(0)=xq(2)
22333  xppi(1)=xq(3)/6d0
22334  xppi(2)=xq(1)+xq(3)/6d0
22335  xppi(3)=xq(3)/6d0
22336  xppi(4)=xq(4)
22337  xppi(-1)=xq(1)+xq(3)/6d0
22338  xppi(-2)=xq(3)/6d0
22339  xppi(-3)=xq(3)/6d0
22340  xppi(-4)=xq(4)
22341 
22342 C...Leading order pion parton distributions from Gluck, Reya and Vogt.
22343 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
22344 C...10^-5 < x < 1.
22345  ELSE
22346 
22347 C...Determine s expansion variable and some x expressions.
22348  vint(231)=0.25d0
22349  IF(mstp(57).LE.0) THEN
22350  sd=0d0
22351  ELSE
22352  q2in=min(1d8,max(0.25d0,q2))
22353  sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
22354  ENDIF
22355  sd2=sd**2
22356  xl=-log(x)
22357  xs=sqrt(x)
22358 
22359 C...Evaluate valence, gluon and sea distributions.
22360  xfval=(0.519d0+0.180d0*sd-0.011d0*sd2)*x**(0.499d0-0.027d0*sd)*
22361  & (1d0+(0.381d0-0.419d0*sd)*xs)*(1d0-x)**(0.367d0+0.563d0*sd)
22362  xfglu=(x**(0.482d0+0.341d0*sqrt(sd))*((0.678d0+0.877d0*
22363  & sd-0.175d0*sd2)+
22364  & (0.338d0-1.597d0*sd)*xs+(-0.233d0*sd+0.406d0*sd2)*x)+
22365  & sd**0.599d0*exp(-(0.618d0+2.070d0*sd)+sqrt(3.676d0*sd**1.263d0*
22366  & xl)))*
22367  & (1d0-x)**(0.390d0+1.053d0*sd)
22368  xfsea=sd**0.55d0*(1d0-0.748d0*xs+(0.313d0+0.935d0*sd)*x)*(1d0-
22369  & x)**3.359d0*
22370  & exp(-(4.433d0+1.301d0*sd)+sqrt((9.30d0-0.887d0*sd)*sd**0.56d0*
22371  & xl))/
22372  & xl**(2.538d0-0.763d0*sd)
22373  IF(sd.LE.0.888d0) THEN
22374  xfchm=0d0
22375  ELSE
22376  xfchm=(sd-0.888d0)**1.02d0*(1d0+1.008d0*x)*(1d0-x)**(1.208d0+
22377  & 0.771d0*sd)*
22378  & exp(-(4.40d0+1.493d0*sd)+sqrt((2.032d0+1.901d0*sd)*sd**0.39d0*
22379  & xl))
22380  ENDIF
22381  IF(sd.LE.1.351d0) THEN
22382  xfbot=0d0
22383  ELSE
22384  xfbot=(sd-1.351d0)**1.03d0*(1d0-x)**(0.697d0+0.855d0*sd)*
22385  & exp(-(4.51d0+1.490d0*sd)+sqrt((3.056d0+1.694d0*sd)*sd**0.39d0*
22386  & xl))
22387  ENDIF
22388 
22389 C...Put into output array.
22390  xppi(0)=xfglu
22391  xppi(1)=xfsea
22392  xppi(2)=xfsea
22393  xppi(3)=xfsea
22394  xppi(4)=xfchm
22395  xppi(5)=xfbot
22396  DO 130 kfl=1,5
22397  xppi(-kfl)=xppi(kfl)
22398  130 CONTINUE
22399  xppi(2)=xppi(2)+xfval
22400  xppi(-1)=xppi(-1)+xfval
22401  ENDIF
22402 
22403  RETURN
22404  END
22405 
22406 C*********************************************************************
22407 
22408 C...PYPDPR
22409 C...Gives proton parton distributions according to a few different
22410 C...parametrizations.
22411 
22412  SUBROUTINE pypdpr(X,Q2,XPPR)
22413 
22414 C...Double precision and integer declarations.
22415  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22416  INTEGER pyk,pychge,pycomp
22417 C...Commonblocks.
22418  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
22419  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
22420  common/pypars/mstp(200),parp(200),msti(200),pari(200)
22421  common/pyint1/mint(400),vint(400)
22422  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
22423 C...Arrays and data.
22424  dimension xppr(-6:6),q2min(6)
22425  DATA q2min/ 2.56d0, 2.56d0, 2.56d0, 0.4d0, 0.4d0, 0.4d0/
22426 
22427 C...Reset output array.
22428  DO 100 kfl=-6,6
22429  xppr(kfl)=0d0
22430  100 CONTINUE
22431 
22432 C...Common preliminaries.
22433  nset=max(1,min(6,mstp(51)))
22434  vint(231)=q2min(nset)
22435  IF(mstp(57).EQ.0) THEN
22436  q2l=q2min(nset)
22437  ELSE
22438  q2l=max(q2min(nset),q2)
22439  ENDIF
22440 
22441  IF(nset.GE.1.AND.nset.LE.3) THEN
22442 C...Interface to the CTEQ 3 parton distributions.
22443  qrt=sqrt(max(1d0,q2l))
22444 
22445 C...Loop over flavours.
22446  DO 110 i=-6,6
22447  IF(i.LE.0) THEN
22448  xppr(i)=pycteq(nset,i,x,qrt)
22449  ELSEIF(i.LE.2) THEN
22450  xppr(i)=pycteq(nset,i,x,qrt)+xppr(-i)
22451  ELSE
22452  xppr(i)=xppr(-i)
22453  ENDIF
22454  110 CONTINUE
22455 
22456  ELSEIF(nset.GE.4.AND.nset.LE.6) THEN
22457 C...Interface to the GRV 94 distributions.
22458  IF(nset.EQ.4) THEN
22459  CALL pygrvl(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
22460  ELSEIF(nset.EQ.5) THEN
22461  CALL pygrvm(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
22462  ELSE
22463  CALL pygrvd(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
22464  ENDIF
22465 
22466 C...Put into output array.
22467  xppr(0)=gl
22468  xppr(-1)=0.5d0*(udb+del)
22469  xppr(-2)=0.5d0*(udb-del)
22470  xppr(-3)=sb
22471  xppr(-4)=chm
22472  xppr(-5)=bot
22473  xppr(1)=dv+xppr(-1)
22474  xppr(2)=uv+xppr(-2)
22475  xppr(3)=sb
22476  xppr(4)=chm
22477  xppr(5)=bot
22478 
22479  ENDIF
22480 
22481  RETURN
22482  END
22483 
22484 C*********************************************************************
22485 
22486 C...PYCTEQ
22487 C...Gives the CTEQ 3 parton distribution function sets in
22488 C...parametrized form, of October 24, 1994.
22489 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
22490 C...J. Qiu, W.K. Tung and H. Weerts.
22491 
22492  FUNCTION pycteq (ISET, IPRT, X, Q)
22493 
22494 C...Double precision declaration.
22495  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22496 
22497 C...Data on Lambda values of fits, minimum Q and quark masses.
22498  dimension alm(3), qms(4:6)
22499  DATA alm / 0.177d0, 0.239d0, 0.247d0 /
22500  DATA qmn / 1.60d0 /, (qms(i), i=4,6) / 1.60d0, 5.00d0, 180.0d0 /
22501 
22502 C....Check flavour thresholds. Set up QI for SB.
22503  ip = iabs(iprt)
22504  IF(ip .GE. 4) THEN
22505  IF(q .LE. qms(ip)) THEN
22506  pycteq = 0d0
22507  RETURN
22508  ENDIF
22509  qi = qms(ip)
22510  ELSE
22511  qi = qmn
22512  ENDIF
22513 
22514 C...Use "standard lambda" of parametrization program for expansion.
22515  alam = alm(iset)
22516  sbl = log(q/alam) / log(qi/alam)
22517  sb = log(sbl)
22518  sb2 = sb*sb
22519  sb3 = sb2*sb
22520 
22521 C...Expansion for CTEQ3L.
22522  IF(iset .EQ. 1) THEN
22523  IF(iprt .EQ. 2) THEN
22524  a0=exp( 0.1907d+00+0.4205d-01*sb +0.2752d+00*sb2-
22525  & 0.3171d+00*sb3)
22526  a1= 0.4611d+00+0.2331d-01*sb -0.3403d-01*sb2+0.3174d-01*sb3
22527  a2= 0.3504d+01+0.5739d+00*sb +0.2676d+00*sb2-0.1553d+00*sb3
22528  a3= 0.7452d+01-0.6742d+01*sb +0.2849d+01*sb2-0.1964d+00*sb3
22529  a4= 0.1116d+01-0.3435d+00*sb +0.2865d+00*sb2-0.1288d+00*sb3
22530  a5= 0.6659d-01+0.2714d+00*sb -0.2688d+00*sb2+0.2763d+00*sb3
22531  ELSEIF(iprt .EQ. 1) THEN
22532  a0=exp( 0.1141d+00+0.4764d+00*sb -0.1745d+01*sb2+
22533  & 0.7728d+00*sb3)
22534  a1= 0.4275d+00-0.1290d+00*sb +0.3609d+00*sb2-0.1689d+00*sb3
22535  a2= 0.3000d+01+0.2946d+01*sb -0.4117d+01*sb2+0.1989d+01*sb3
22536  a3=-0.1302d+01+0.2322d+01*sb -0.4258d+01*sb2+0.2109d+01*sb3
22537  a4= 0.2586d+01-0.1920d+00*sb -0.3754d+00*sb2+0.2731d+00*sb3
22538  a5=-0.2251d+00-0.5374d+00*sb +0.2245d+01*sb2-0.1034d+01*sb3
22539  ELSEIF(iprt .EQ. 0) THEN
22540  a0=exp(-0.7631d+00-0.7241d+00*sb -0.1170d+01*sb2+
22541  & 0.5343d+00*sb3)
22542  a1=-0.3573d+00+0.3469d+00*sb -0.3396d+00*sb2+0.9188d-01*sb3
22543  a2= 0.5604d+01+0.7458d+00*sb -0.5082d+00*sb2+0.1844d+00*sb3
22544  a3= 0.1549d+02-0.1809d+02*sb +0.1162d+02*sb2-0.3483d+01*sb3
22545  a4= 0.9881d+00+0.1364d+00*sb -0.4421d+00*sb2+0.2051d+00*sb3
22546  a5=-0.9505d-01+0.3259d+01*sb -0.1547d+01*sb2+0.2918d+00*sb3
22547  ELSEIF(iprt .EQ. -1) THEN
22548  a0=exp(-0.2449d+01-0.3513d+01*sb +0.4529d+01*sb2-
22549  & 0.2031d+01*sb3)
22550  a1=-0.4050d+00+0.3411d+00*sb -0.3669d+00*sb2+0.1109d+00*sb3
22551  a2= 0.7470d+01-0.2982d+01*sb +0.5503d+01*sb2-0.2419d+01*sb3
22552  a3= 0.1503d+02+0.1638d+01*sb -0.8772d+01*sb2+0.3852d+01*sb3
22553  a4= 0.1137d+01-0.1006d+01*sb +0.1485d+01*sb2-0.6389d+00*sb3
22554  a5=-0.5299d+00+0.3160d+01*sb -0.3104d+01*sb2+0.1219d+01*sb3
22555  ELSEIF(iprt .EQ. -2) THEN
22556  a0=exp(-0.2740d+01-0.7987d-01*sb -0.9015d+00*sb2-
22557  & 0.9872d-01*sb3)
22558  a1=-0.3909d+00+0.1244d+00*sb -0.4487d-01*sb2+0.1277d-01*sb3
22559  a2= 0.9163d+01+0.2823d+00*sb -0.7720d+00*sb2-0.9360d-02*sb3
22560  a3= 0.1080d+02-0.3915d+01*sb -0.1153d+01*sb2+0.2649d+01*sb3
22561  a4= 0.9894d+00-0.1647d+00*sb -0.9426d-02*sb2+0.2945d-02*sb3
22562  a5=-0.3395d+00+0.6998d+00*sb +0.7000d+00*sb2-0.6730d-01*sb3
22563  ELSEIF(iprt .EQ. -3) THEN
22564  a0=exp(-0.3640d+01+0.1250d+01*sb -0.2914d+01*sb2+
22565  & 0.8390d+00*sb3)
22566  a1=-0.3595d+00-0.5259d-01*sb +0.3122d+00*sb2-0.1642d+00*sb3
22567  a2= 0.7305d+01+0.9727d+00*sb -0.9788d+00*sb2-0.5193d-01*sb3
22568  a3= 0.1198d+02-0.1799d+02*sb +0.2614d+02*sb2-0.1091d+02*sb3
22569  a4= 0.9882d+00-0.6101d+00*sb +0.9737d+00*sb2-0.4935d+00*sb3
22570  a5=-0.1186d+00-0.3231d+00*sb +0.3074d+01*sb2-0.1274d+01*sb3
22571  ELSEIF(iprt .EQ. -4) THEN
22572  a0=sb** 0.1122d+01*exp(-0.3718d+01-0.1335d+01*sb +
22573  & 0.1651d-01*sb2)
22574  a1=-0.4719d+00+0.7509d+00*sb -0.8420d+00*sb2+0.2901d+00*sb3
22575  a2= 0.6194d+01-0.1641d+01*sb +0.4907d+01*sb2-0.2523d+01*sb3
22576  a3= 0.4426d+01-0.4270d+01*sb +0.6581d+01*sb2-0.3474d+01*sb3
22577  a4= 0.2683d+00+0.9876d+00*sb -0.7612d+00*sb2+0.1780d+00*sb3
22578  a5=-0.4547d+00+0.4410d+01*sb -0.3712d+01*sb2+0.1245d+01*sb3
22579  ELSEIF(iprt .EQ. -5) THEN
22580  a0=sb** 0.9838d+00*exp(-0.2548d+01-0.7660d+01*sb +
22581  & 0.3702d+01*sb2)
22582  a1=-0.3122d+00-0.2120d+00*sb +0.5716d+00*sb2-0.3773d+00*sb3
22583  a2= 0.6257d+01-0.8214d-01*sb -0.2537d+01*sb2+0.2981d+01*sb3
22584  a3=-0.6723d+00+0.2131d+01*sb +0.9599d+01*sb2-0.7910d+01*sb3
22585  a4= 0.9169d-01+0.4295d-01*sb -0.5017d+00*sb2+0.3811d+00*sb3
22586  a5= 0.2402d+00+0.2656d+01*sb -0.1586d+01*sb2+0.2880d+00*sb3
22587  ELSEIF(iprt .EQ. -6) THEN
22588  a0=sb** 0.1001d+01*exp(-0.6934d+01+0.3050d+01*sb -
22589  & 0.6943d+00*sb2)
22590  a1=-0.1713d+00-0.5167d+00*sb +0.1241d+01*sb2-0.1703d+01*sb3
22591  a2= 0.6169d+01+0.3023d+01*sb -0.1972d+02*sb2+0.1069d+02*sb3
22592  a3= 0.4439d+01-0.1746d+02*sb +0.1225d+02*sb2+0.8350d+00*sb3
22593  a4= 0.5458d+00-0.4586d+00*sb +0.9089d+00*sb2-0.4049d+00*sb3
22594  a5= 0.3207d+01-0.3362d+01*sb +0.5877d+01*sb2-0.7659d+01*sb3
22595  ENDIF
22596 
22597 C...Expansion for CTEQ3M.
22598  ELSEIF(iset .EQ. 2) THEN
22599  IF(iprt .EQ. 2) THEN
22600  a0=exp( 0.2259d+00+0.1237d+00*sb +0.3035d+00*sb2-
22601  & 0.2935d+00*sb3)
22602  a1= 0.5085d+00+0.1651d-01*sb -0.3592d-01*sb2+0.2782d-01*sb3
22603  a2= 0.3732d+01+0.4901d+00*sb +0.2218d+00*sb2-0.1116d+00*sb3
22604  a3= 0.7011d+01-0.6620d+01*sb +0.2557d+01*sb2-0.1360d+00*sb3
22605  a4= 0.8969d+00-0.2429d+00*sb +0.1811d+00*sb2-0.6888d-01*sb3
22606  a5= 0.8636d-01+0.2558d+00*sb -0.3082d+00*sb2+0.2535d+00*sb3
22607  ELSEIF(iprt .EQ. 1) THEN
22608  a0=exp(-0.7266d+00-0.1584d+01*sb +0.1259d+01*sb2-
22609  & 0.4305d-01*sb3)
22610  a1= 0.5285d+00-0.3721d+00*sb +0.5150d+00*sb2-0.1697d+00*sb3
22611  a2= 0.4075d+01+0.8282d+00*sb -0.4496d+00*sb2+0.2107d+00*sb3
22612  a3= 0.3279d+01+0.5066d+01*sb -0.9134d+01*sb2+0.2897d+01*sb3
22613  a4= 0.4399d+00-0.5888d+00*sb +0.4802d+00*sb2-0.1664d+00*sb3
22614  a5= 0.3678d+00-0.8929d+00*sb +0.1592d+01*sb2-0.5713d+00*sb3
22615  ELSEIF(iprt .EQ. 0) THEN
22616  a0=exp(-0.2318d+00-0.9779d+00*sb -0.3783d+00*sb2+
22617  & 0.1037d-01*sb3)
22618  a1=-0.2916d+00+0.1754d+00*sb -0.1884d+00*sb2+0.6116d-01*sb3
22619  a2= 0.5349d+01+0.7460d+00*sb +0.2319d+00*sb2-0.2622d+00*sb3
22620  a3= 0.6920d+01-0.3454d+01*sb +0.2027d+01*sb2-0.7626d+00*sb3
22621  a4= 0.1013d+01+0.1423d+00*sb -0.1798d+00*sb2+0.1872d-01*sb3
22622  a5=-0.5465d-01+0.2303d+01*sb -0.9584d+00*sb2+0.3098d+00*sb3
22623  ELSEIF(iprt .EQ. -1) THEN
22624  a0=exp(-0.2328d+01-0.3061d+01*sb +0.3620d+01*sb2-
22625  & 0.1602d+01*sb3)
22626  a1=-0.3358d+00+0.3198d+00*sb -0.4210d+00*sb2+0.1571d+00*sb3
22627  a2= 0.8478d+01-0.3112d+01*sb +0.5243d+01*sb2-0.2255d+01*sb3
22628  a3= 0.1971d+02+0.3389d+00*sb -0.5268d+01*sb2+0.2099d+01*sb3
22629  a4= 0.1128d+01-0.4701d+00*sb +0.7779d+00*sb2-0.3506d+00*sb3
22630  a5=-0.4708d+00+0.3341d+01*sb -0.3375d+01*sb2+0.1353d+01*sb3
22631  ELSEIF(iprt .EQ. -2) THEN
22632  a0=exp(-0.2906d+01-0.1069d+00*sb -0.1055d+01*sb2+
22633  & 0.2496d+00*sb3)
22634  a1=-0.2875d+00+0.6571d-01*sb -0.1987d-01*sb2-0.1800d-02*sb3
22635  a2= 0.9854d+01-0.2715d+00*sb -0.7407d+00*sb2+0.2888d+00*sb3
22636  a3= 0.1583d+02-0.7687d+01*sb +0.3428d+01*sb2-0.3327d+00*sb3
22637  a4= 0.9763d+00+0.7599d-01*sb -0.2128d+00*sb2+0.6852d-01*sb3
22638  a5=-0.8444d-02+0.9434d+00*sb +0.4152d+00*sb2-0.1481d+00*sb3
22639  ELSEIF(iprt .EQ. -3) THEN
22640  a0=exp(-0.3780d+01+0.2499d+01*sb -0.4962d+01*sb2+
22641  & 0.1936d+01*sb3)
22642  a1=-0.2639d+00-0.1575d+00*sb +0.3584d+00*sb2-0.1646d+00*sb3
22643  a2= 0.8082d+01+0.2794d+01*sb -0.5438d+01*sb2+0.2321d+01*sb3
22644  a3= 0.1811d+02-0.2000d+02*sb +0.1951d+02*sb2-0.6904d+01*sb3
22645  a4= 0.9822d+00+0.4972d+00*sb -0.8690d+00*sb2+0.3415d+00*sb3
22646  a5= 0.1772d+00-0.6078d+00*sb +0.3341d+01*sb2-0.1473d+01*sb3
22647  ELSEIF(iprt .EQ. -4) THEN
22648  a0=sb** 0.1122d+01*exp(-0.4232d+01-0.1808d+01*sb +
22649  & 0.5348d+00*sb2)
22650  a1=-0.2824d+00+0.5846d+00*sb -0.7230d+00*sb2+0.2419d+00*sb3
22651  a2= 0.5683d+01-0.2948d+01*sb +0.5916d+01*sb2-0.2560d+01*sb3
22652  a3= 0.2051d+01+0.4795d+01*sb -0.4271d+01*sb2+0.4174d+00*sb3
22653  a4= 0.1737d+00+0.1717d+01*sb -0.1978d+01*sb2+0.6643d+00*sb3
22654  a5= 0.8689d+00+0.3500d+01*sb -0.3283d+01*sb2+0.1026d+01*sb3
22655  ELSEIF(iprt .EQ. -5) THEN
22656  a0=sb** 0.9906d+00*exp(-0.1496d+01-0.6576d+01*sb +
22657  & 0.1569d+01*sb2)
22658  a1=-0.2140d+00-0.6419d-01*sb -0.2741d-02*sb2+0.3185d-02*sb3
22659  a2= 0.5781d+01+0.1049d+00*sb -0.3930d+00*sb2+0.5174d+00*sb3
22660  a3=-0.9420d+00+0.5511d+00*sb +0.8817d+00*sb2+0.1903d+01*sb3
22661  a4= 0.2418d-01+0.4232d-01*sb -0.1244d-01*sb2-0.2365d-01*sb3
22662  a5= 0.7664d+00+0.1794d+01*sb -0.4917d+00*sb2-0.1284d+00*sb3
22663  ELSEIF(iprt .EQ. -6) THEN
22664  a0=sb** 0.1000d+01*exp(-0.8460d+01+0.1154d+01*sb +
22665  & 0.8838d+01*sb2)
22666  a1=-0.4316d-01-0.2976d+00*sb +0.3174d+00*sb2-0.1429d+01*sb3
22667  a2= 0.4910d+01+0.2273d+01*sb +0.5631d+01*sb2-0.1994d+02*sb3
22668  a3= 0.1190d+02-0.2000d+02*sb -0.2000d+02*sb2+0.1292d+02*sb3
22669  a4= 0.5771d+00-0.2552d+00*sb +0.7510d+00*sb2+0.6923d+00*sb3
22670  a5= 0.4402d+01-0.1627d+01*sb -0.2085d+01*sb2-0.6737d+01*sb3
22671  ENDIF
22672 
22673 C...Expansion for CTEQ3D.
22674  ELSEIF(iset .EQ. 3) THEN
22675  IF(iprt .EQ. 2) THEN
22676  a0=exp( 0.2148d+00+0.5814d-01*sb +0.2734d+00*sb2-
22677  & 0.2902d+00*sb3)
22678  a1= 0.4810d+00+0.1657d-01*sb -0.3800d-01*sb2+0.3125d-01*sb3
22679  a2= 0.3509d+01+0.3923d+00*sb +0.4010d+00*sb2-0.1932d+00*sb3
22680  a3= 0.7055d+01-0.6552d+01*sb +0.3466d+01*sb2-0.5657d+00*sb3
22681  a4= 0.1061d+01-0.3453d+00*sb +0.4089d+00*sb2-0.1817d+00*sb3
22682  a5= 0.8687d-01+0.2548d+00*sb -0.2967d+00*sb2+0.2647d+00*sb3
22683  ELSEIF(iprt .EQ. 1) THEN
22684  a0=exp( 0.3961d+00+0.4914d+00*sb -0.1728d+01*sb2+
22685  & 0.7257d+00*sb3)
22686  a1= 0.4162d+00-0.1419d+00*sb +0.3680d+00*sb2-0.1618d+00*sb3
22687  a2= 0.3248d+01+0.3028d+01*sb -0.4307d+01*sb2+0.1920d+01*sb3
22688  a3=-0.1100d+01+0.2184d+01*sb -0.3820d+01*sb2+0.1717d+01*sb3
22689  a4= 0.2082d+01-0.2756d+00*sb +0.3043d+00*sb2-0.1260d+00*sb3
22690  a5=-0.4822d+00-0.5706d+00*sb +0.2243d+01*sb2-0.9760d+00*sb3
22691  ELSEIF(iprt .EQ. 0) THEN
22692  a0=exp(-0.4665d+00-0.7554d+00*sb -0.3323d+00*sb2-
22693  & 0.2734d-04*sb3)
22694  a1=-0.3359d+00+0.2395d+00*sb -0.2377d+00*sb2+0.7059d-01*sb3
22695  a2= 0.5451d+01+0.6086d+00*sb +0.8606d-01*sb2-0.1425d+00*sb3
22696  a3= 0.1026d+02-0.9352d+01*sb +0.4879d+01*sb2-0.1150d+01*sb3
22697  a4= 0.9935d+00-0.5017d-01*sb -0.1707d-01*sb2-0.1464d-02*sb3
22698  a5=-0.4160d-01+0.2305d+01*sb -0.1063d+01*sb2+0.3211d+00*sb3
22699  ELSEIF(iprt .EQ. -1) THEN
22700  a0=exp(-0.2714d+01-0.2868d+01*sb +0.3700d+01*sb2-
22701  & 0.1671d+01*sb3)
22702  a1=-0.3893d+00+0.3341d+00*sb -0.3897d+00*sb2+0.1420d+00*sb3
22703  a2= 0.8359d+01-0.3267d+01*sb +0.5327d+01*sb2-0.2245d+01*sb3
22704  a3= 0.2359d+02-0.5669d+01*sb -0.4602d+01*sb2+0.3153d+01*sb3
22705  a4= 0.1106d+01-0.4745d+00*sb +0.7739d+00*sb2-0.3417d+00*sb3
22706  a5=-0.5557d+00+0.3433d+01*sb -0.3390d+01*sb2+0.1354d+01*sb3
22707  ELSEIF(iprt .EQ. -2) THEN
22708  a0=exp(-0.3323d+01+0.2296d+00*sb -0.1109d+01*sb2+
22709  & 0.2223d+00*sb3)
22710  a1=-0.3410d+00+0.8847d-01*sb -0.1111d-01*sb2-0.5927d-02*sb3
22711  a2= 0.9753d+01-0.5182d+00*sb -0.4670d+00*sb2+0.1921d+00*sb3
22712  a3= 0.1977d+02-0.1600d+02*sb +0.9481d+01*sb2-0.1864d+01*sb3
22713  a4= 0.9818d+00+0.2839d-02*sb -0.1188d+00*sb2+0.3584d-01*sb3
22714  a5=-0.7934d-01+0.1004d+01*sb +0.3704d+00*sb2-0.1220d+00*sb3
22715  ELSEIF(iprt .EQ. -3) THEN
22716  a0=exp(-0.3985d+01+0.2855d+01*sb -0.5208d+01*sb2+
22717  & 0.1937d+01*sb3)
22718  a1=-0.3337d+00-0.1150d+00*sb +0.3691d+00*sb2-0.1709d+00*sb3
22719  a2= 0.7968d+01+0.3641d+01*sb -0.6599d+01*sb2+0.2642d+01*sb3
22720  a3= 0.1873d+02-0.1999d+02*sb +0.1734d+02*sb2-0.5813d+01*sb3
22721  a4= 0.9731d+00+0.5082d+00*sb -0.8780d+00*sb2+0.3231d+00*sb3
22722  a5=-0.5542d-01-0.4189d+00*sb +0.3309d+01*sb2-0.1439d+01*sb3
22723  ELSEIF(iprt .EQ. -4) THEN
22724  a0=sb** 0.1105d+01*exp(-0.3952d+01-0.1901d+01*sb +
22725  & 0.5137d+00*sb2)
22726  a1=-0.3543d+00+0.6055d+00*sb -0.6941d+00*sb2+0.2278d+00*sb3
22727  a2= 0.5955d+01-0.2629d+01*sb +0.5337d+01*sb2-0.2300d+01*sb3
22728  a3= 0.1933d+01+0.4882d+01*sb -0.3810d+01*sb2+0.2290d+00*sb3
22729  a4= 0.1806d+00+0.1655d+01*sb -0.1893d+01*sb2+0.6395d+00*sb3
22730  a5= 0.4790d+00+0.3612d+01*sb -0.3152d+01*sb2+0.9684d+00*sb3
22731  ELSEIF(iprt .EQ. -5) THEN
22732  a0=sb** 0.9818d+00*exp(-0.1825d+01-0.7464d+01*sb +
22733  & 0.2143d+01*sb2)
22734  a1=-0.2604d+00-0.1400d+00*sb +0.1702d+00*sb2-0.8476d-01*sb3
22735  a2= 0.6005d+01+0.6275d+00*sb -0.2535d+01*sb2+0.2219d+01*sb3
22736  a3=-0.9067d+00+0.1149d+01*sb +0.1974d+01*sb2+0.4716d+01*sb3
22737  a4= 0.3915d-01+0.5945d-01*sb -0.9844d-01*sb2+0.2783d-01*sb3
22738  a5= 0.5500d+00+0.1994d+01*sb -0.6727d+00*sb2-0.1510d+00*sb3
22739  ELSEIF(iprt .EQ. -6) THEN
22740  a0=sb** 0.1002d+01*exp(-0.8553d+01+0.3793d+00*sb +
22741  & 0.9998d+01*sb2)
22742  a1=-0.5870d-01-0.2792d+00*sb +0.6526d+00*sb2-0.1984d+01*sb3
22743  a2= 0.4716d+01+0.4473d+00*sb +0.1128d+02*sb2-0.1937d+02*sb3
22744  a3= 0.1289d+02-0.1742d+02*sb -0.1983d+02*sb2-0.9274d+00*sb3
22745  a4= 0.5647d+00-0.2732d+00*sb +0.1074d+01*sb2+0.5981d+00*sb3
22746  a5= 0.4390d+01-0.1262d+01*sb -0.9026d+00*sb2-0.9394d+01*sb3
22747  ENDIF
22748  ENDIF
22749 
22750 C...Calculation of x * f(x, Q).
22751  pycteq = max(0d0, a0 *(x**a1) *((1d0-x)**a2) *(1d0+a3*(x**a4))
22752  & *(log(1d0+1d0/x))**a5 )
22753 
22754  RETURN
22755  END
22756 
22757 C*********************************************************************
22758 
22759 C...PYGRVL
22760 C...Gives the GRV 94 L (leading order) parton distribution function set
22761 C...in parametrized form.
22762 C...Authors: M. Glueck, E. Reya and A. Vogt.
22763 
22764  SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22765 
22766 C...Double precision declaration.
22767  IMPLICIT DOUBLE PRECISION (a - z)
22768 
22769 C...Common expressions.
22770  mu2 = 0.23d0
22771  lam2 = 0.2322d0 * 0.2322d0
22772  s = log(log(q2/lam2) / log(mu2/lam2))
22773  ds = sqrt(s)
22774  s2 = s * s
22775  s3 = s2 * s
22776 
22777 C...uv :
22778  nu = 2.284d0 + 0.802d0 * s + 0.055d0 * s2
22779  aku = 0.590d0 - 0.024d0 * s
22780  bku = 0.131d0 + 0.063d0 * s
22781  au = -0.449d0 - 0.138d0 * s - 0.076d0 * s2
22782  bu = 0.213d0 + 2.669d0 * s - 0.728d0 * s2
22783  cu = 8.854d0 - 9.135d0 * s + 1.979d0 * s2
22784  du = 2.997d0 + 0.753d0 * s - 0.076d0 * s2
22785  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
22786 
22787 C...dv :
22788  nd = 0.371d0 + 0.083d0 * s + 0.039d0 * s2
22789  akd = 0.376d0
22790  bkd = 0.486d0 + 0.062d0 * s
22791  ad = -0.509d0 + 3.310d0 * s - 1.248d0 * s2
22792  bd = 12.41d0 - 10.52d0 * s + 2.267d0 * s2
22793  cd = 6.373d0 - 6.208d0 * s + 1.418d0 * s2
22794  dd = 3.691d0 + 0.799d0 * s - 0.071d0 * s2
22795  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
22796 
22797 C...del :
22798  ne = 0.082d0 + 0.014d0 * s + 0.008d0 * s2
22799  ake = 0.409d0 - 0.005d0 * s
22800  bke = 0.799d0 + 0.071d0 * s
22801  ae = -38.07d0 + 36.13d0 * s - 0.656d0 * s2
22802  be = 90.31d0 - 74.15d0 * s + 7.645d0 * s2
22803  ce = 0.0d0
22804  de = 7.486d0 + 1.217d0 * s - 0.159d0 * s2
22805  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
22806 
22807 C...udb :
22808  alx = 1.451d0
22809  bex = 0.271d0
22810  akx = 0.410d0 - 0.232d0 * s
22811  bkx = 0.534d0 - 0.457d0 * s
22812  agx = 0.890d0 - 0.140d0 * s
22813  bgx = -0.981d0
22814  cx = 0.320d0 + 0.683d0 * s
22815  dx = 4.752d0 + 1.164d0 * s + 0.286d0 * s2
22816  ex = 4.119d0 + 1.713d0 * s
22817  esx = 0.682d0 + 2.978d0 * s
22818  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
22819  & dx, ex, esx)
22820 
22821 C...sb :
22822  sts = 0d0
22823  als = 0.914d0
22824  bes = 0.577d0
22825  aks = 1.798d0 - 0.596d0 * s
22826  as = -5.548d0 + 3.669d0 * ds - 0.616d0 * s
22827  bs = 18.92d0 - 16.73d0 * ds + 5.168d0 * s
22828  dst = 6.379d0 - 0.350d0 * s + 0.142d0 * s2
22829  est = 3.981d0 + 1.638d0 * s
22830  ess = 6.402d0
22831  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
22832 
22833 C...cb :
22834  stc = 0.888d0
22835  alc = 1.01d0
22836  bec = 0.37d0
22837  akc = 0d0
22838  ac = 0d0
22839  bc = 4.24d0 - 0.804d0 * s
22840  dct = 3.46d0 - 1.076d0 * s
22841  ect = 4.61d0 + 1.49d0 * s
22842  esc = 2.555d0 + 1.961d0 * s
22843  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
22844 
22845 C...bb :
22846  stb = 1.351d0
22847  alb = 1.00d0
22848  beb = 0.51d0
22849  akb = 0d0
22850  ab = 0d0
22851  bb = 1.848d0
22852  dbt = 2.929d0 + 1.396d0 * s
22853  ebt = 4.71d0 + 1.514d0 * s
22854  esb = 4.02d0 + 1.239d0 * s
22855  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
22856 
22857 C...gl :
22858  alg = 0.524d0
22859  beg = 1.088d0
22860  akg = 1.742d0 - 0.930d0 * s
22861  bkg = - 0.399d0 * s2
22862  ag = 7.486d0 - 2.185d0 * s
22863  bg = 16.69d0 - 22.74d0 * s + 5.779d0 * s2
22864  cg = -25.59d0 + 29.71d0 * s - 7.296d0 * s2
22865  dg = 2.792d0 + 2.215d0 * s + 0.422d0 * s2 - 0.104d0 * s3
22866  eg = 0.807d0 + 2.005d0 * s
22867  esg = 3.841d0 + 0.316d0 * s
22868  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg,
22869  & dg, eg, esg)
22870 
22871  RETURN
22872  END
22873 
22874 C*********************************************************************
22875 
22876 C...PYGRVM
22877 C...Gives the GRV 94 M (MSbar) parton distribution function set
22878 C...in parametrized form.
22879 C...Authors: M. Glueck, E. Reya and A. Vogt.
22880 
22881  SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22882 
22883 C...Double precision declaration.
22884  IMPLICIT DOUBLE PRECISION (a - z)
22885 
22886 C...Common expressions.
22887  mu2 = 0.34d0
22888  lam2 = 0.248d0 * 0.248d0
22889  s = log(log(q2/lam2) / log(mu2/lam2))
22890  ds = sqrt(s)
22891  s2 = s * s
22892  s3 = s2 * s
22893 
22894 C...uv :
22895  nu = 1.304d0 + 0.863d0 * s
22896  aku = 0.558d0 - 0.020d0 * s
22897  bku = 0.183d0 * s
22898  au = -0.113d0 + 0.283d0 * s - 0.321d0 * s2
22899  bu = 6.843d0 - 5.089d0 * s + 2.647d0 * s2 - 0.527d0 * s3
22900  cu = 7.771d0 - 10.09d0 * s + 2.630d0 * s2
22901  du = 3.315d0 + 1.145d0 * s - 0.583d0 * s2 + 0.154d0 * s3
22902  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
22903 
22904 C...dv :
22905  nd = 0.102d0 - 0.017d0 * s + 0.005d0 * s2
22906  akd = 0.270d0 - 0.019d0 * s
22907  bkd = 0.260d0
22908  ad = 2.393d0 + 6.228d0 * s - 0.881d0 * s2
22909  bd = 46.06d0 + 4.673d0 * s - 14.98d0 * s2 + 1.331d0 * s3
22910  cd = 17.83d0 - 53.47d0 * s + 21.24d0 * s2
22911  dd = 4.081d0 + 0.976d0 * s - 0.485d0 * s2 + 0.152d0 * s3
22912  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
22913 
22914 C...del :
22915  ne = 0.070d0 + 0.042d0 * s - 0.011d0 * s2 + 0.004d0 * s3
22916  ake = 0.409d0 - 0.007d0 * s
22917  bke = 0.782d0 + 0.082d0 * s
22918  ae = -29.65d0 + 26.49d0 * s + 5.429d0 * s2
22919  be = 90.20d0 - 74.97d0 * s + 4.526d0 * s2
22920  ce = 0.0d0
22921  de = 8.122d0 + 2.120d0 * s - 1.088d0 * s2 + 0.231d0 * s3
22922  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
22923 
22924 C...udb :
22925  alx = 0.877d0
22926  bex = 0.561d0
22927  akx = 0.275d0
22928  bkx = 0.0d0
22929  agx = 0.997d0
22930  bgx = 3.210d0 - 1.866d0 * s
22931  cx = 7.300d0
22932  dx = 9.010d0 + 0.896d0 * ds + 0.222d0 * s2
22933  ex = 3.077d0 + 1.446d0 * s
22934  esx = 3.173d0 - 2.445d0 * ds + 2.207d0 * s
22935  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
22936  & dx, ex, esx)
22937 
22938 C...sb :
22939  sts = 0d0
22940  als = 0.756d0
22941  bes = 0.216d0
22942  aks = 1.690d0 + 0.650d0 * ds - 0.922d0 * s
22943  as = -4.329d0 + 1.131d0 * s
22944  bs = 9.568d0 - 1.744d0 * s
22945  dst = 9.377d0 + 1.088d0 * ds - 1.320d0 * s + 0.130d0 * s2
22946  est = 3.031d0 + 1.639d0 * s
22947  ess = 5.837d0 + 0.815d0 * s
22948  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
22949 
22950 C...cb :
22951  stc = 0.820d0
22952  alc = 0.98d0
22953  bec = 0d0
22954  akc = -0.625d0 - 0.523d0 * s
22955  ac = 0d0
22956  bc = 1.896d0 + 1.616d0 * s
22957  dct = 4.12d0 + 0.683d0 * s
22958  ect = 4.36d0 + 1.328d0 * s
22959  esc = 0.677d0 + 0.679d0 * s
22960  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
22961 
22962 C...bb :
22963  stb = 1.297d0
22964  alb = 0.99d0
22965  beb = 0d0
22966  akb = - 0.193d0 * s
22967  ab = 0d0
22968  bb = 0d0
22969  dbt = 3.447d0 + 0.927d0 * s
22970  ebt = 4.68d0 + 1.259d0 * s
22971  esb = 1.892d0 + 2.199d0 * s
22972  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
22973 
22974 C...gl :
22975  alg = 1.014d0
22976  beg = 1.738d0
22977  akg = 1.724d0 + 0.157d0 * s
22978  bkg = 0.800d0 + 1.016d0 * s
22979  ag = 7.517d0 - 2.547d0 * s
22980  bg = 34.09d0 - 52.21d0 * ds + 17.47d0 * s
22981  cg = 4.039d0 + 1.491d0 * s
22982  dg = 3.404d0 + 0.830d0 * s
22983  eg = -1.112d0 + 3.438d0 * s - 0.302d0 * s2
22984  esg = 3.256d0 - 0.436d0 * s
22985  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
22986 
22987  RETURN
22988  END
22989 
22990 C*********************************************************************
22991 
22992 C...PYGRVD
22993 C...Gives the GRV 94 D (DIS) parton distribution function set
22994 C...in parametrized form.
22995 C...Authors: M. Glueck, E. Reya and A. Vogt.
22996 
22997  SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22998 
22999 C...Double precision declaration.
23000  IMPLICIT DOUBLE PRECISION (a - z)
23001 
23002 C...Common expressions.
23003  mu2 = 0.34d0
23004  lam2 = 0.248d0 * 0.248d0
23005  s = log(log(q2/lam2) / log(mu2/lam2))
23006  ds = sqrt(s)
23007  s2 = s * s
23008  s3 = s2 * s
23009 
23010 C...uv :
23011  nu = 2.484d0 + 0.116d0 * s + 0.093d0 * s2
23012  aku = 0.563d0 - 0.025d0 * s
23013  bku = 0.054d0 + 0.154d0 * s
23014  au = -0.326d0 - 0.058d0 * s - 0.135d0 * s2
23015  bu = -3.322d0 + 8.259d0 * s - 3.119d0 * s2 + 0.291d0 * s3
23016  cu = 11.52d0 - 12.99d0 * s + 3.161d0 * s2
23017  du = 2.808d0 + 1.400d0 * s - 0.557d0 * s2 + 0.119d0 * s3
23018  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
23019 
23020 C...dv :
23021  nd = 0.156d0 - 0.017d0 * s
23022  akd = 0.299d0 - 0.022d0 * s
23023  bkd = 0.259d0 - 0.015d0 * s
23024  ad = 3.445d0 + 1.278d0 * s + 0.326d0 * s2
23025  bd = -6.934d0 + 37.45d0 * s - 18.95d0 * s2 + 1.463d0 * s3
23026  cd = 55.45d0 - 69.92d0 * s + 20.78d0 * s2
23027  dd = 3.577d0 + 1.441d0 * s - 0.683d0 * s2 + 0.179d0 * s3
23028  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
23029 
23030 C...del :
23031  ne = 0.099d0 + 0.019d0 * s + 0.002d0 * s2
23032  ake = 0.419d0 - 0.013d0 * s
23033  bke = 1.064d0 - 0.038d0 * s
23034  ae = -44.00d0 + 98.70d0 * s - 14.79d0 * s2
23035  be = 28.59d0 - 40.94d0 * s - 13.66d0 * s2 + 2.523d0 * s3
23036  ce = 84.57d0 - 108.8d0 * s + 31.52d0 * s2
23037  de = 7.469d0 + 2.480d0 * s - 0.866d0 * s2
23038  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
23039 
23040 C...udb :
23041  alx = 1.215d0
23042  bex = 0.466d0
23043  akx = 0.326d0 + 0.150d0 * s
23044  bkx = 0.956d0 + 0.405d0 * s
23045  agx = 0.272d0
23046  bgx = 3.794d0 - 2.359d0 * ds
23047  cx = 2.014d0
23048  dx = 7.941d0 + 0.534d0 * ds - 0.940d0 * s + 0.410d0 * s2
23049  ex = 3.049d0 + 1.597d0 * s
23050  esx = 4.396d0 - 4.594d0 * ds + 3.268d0 * s
23051  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
23052  & dx, ex, esx)
23053 
23054 C...sb :
23055  sts = 0d0
23056  als = 0.175d0
23057  bes = 0.344d0
23058  aks = 1.415d0 - 0.641d0 * ds
23059  as = 0.580d0 - 9.763d0 * ds + 6.795d0 * s - 0.558d0 * s2
23060  bs = 5.617d0 + 5.709d0 * ds - 3.972d0 * s
23061  dst = 13.78d0 - 9.581d0 * s + 5.370d0 * s2 - 0.996d0 * s3
23062  est = 4.546d0 + 0.372d0 * s2
23063  ess = 5.053d0 - 1.070d0 * s + 0.805d0 * s2
23064  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
23065 
23066 C...cb :
23067  stc = 0.820d0
23068  alc = 0.98d0
23069  bec = 0d0
23070  akc = -0.625d0 - 0.523d0 * s
23071  ac = 0d0
23072  bc = 1.896d0 + 1.616d0 * s
23073  dct = 4.12d0 + 0.683d0 * s
23074  ect = 4.36d0 + 1.328d0 * s
23075  esc = 0.677d0 + 0.679d0 * s
23076  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
23077 
23078 C...bb :
23079  stb = 1.297d0
23080  alb = 0.99d0
23081  beb = 0d0
23082  akb = - 0.193d0 * s
23083  ab = 0d0
23084  bb = 0d0
23085  dbt = 3.447d0 + 0.927d0 * s
23086  ebt = 4.68d0 + 1.259d0 * s
23087  esb = 1.892d0 + 2.199d0 * s
23088  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
23089 
23090 C...gl :
23091  alg = 1.258d0
23092  beg = 1.846d0
23093  akg = 2.423d0
23094  bkg = 2.427d0 + 1.311d0 * s - 0.153d0 * s2
23095  ag = 25.09d0 - 7.935d0 * s
23096  bg = -14.84d0 - 124.3d0 * ds + 72.18d0 * s
23097  cg = 590.3d0 - 173.8d0 * s
23098  dg = 5.196d0 + 1.857d0 * s
23099  eg = -1.648d0 + 3.988d0 * s - 0.432d0 * s2
23100  esg = 3.232d0 - 0.542d0 * s
23101  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
23102 
23103  RETURN
23104  END
23105 
23106 C*********************************************************************
23107 
23108 C...PYGRVV
23109 C...Auxiliary for the GRV 94 parton distribution functions
23110 C...for u and d valence and d-u sea.
23111 C...Authors: M. Glueck, E. Reya and A. Vogt.
23112 
23113  FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)
23114 
23115 C...Double precision declaration.
23116  IMPLICIT DOUBLE PRECISION (a - z)
23117 
23118 C...Evaluation.
23119  dx = sqrt(x)
23120  pygrvv = n * x**ak * (1d0+ a*x**bk + x * (b + c*dx)) *
23121  & (1d0- x)**d
23122 
23123  RETURN
23124  END
23125 
23126 C*********************************************************************
23127 
23128 C...PYGRVW
23129 C...Auxiliary for the GRV 94 parton distribution functions
23130 C...for d+u sea and gluon.
23131 C...Authors: M. Glueck, E. Reya and A. Vogt.
23132 
23133  FUNCTION pygrvw (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
23134 
23135 C...Double precision declaration.
23136  IMPLICIT DOUBLE PRECISION (a - z)
23137 
23138 C...Evaluation.
23139  lx = log(1d0/x)
23140  pygrvw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al
23141  & * exp(-e + sqrt(es * s**be * lx))) * (1d0- x)**d
23142 
23143  RETURN
23144  END
23145 
23146 C*********************************************************************
23147 
23148 C...PYGRVS
23149 C...Auxiliary for the GRV 94 parton distribution functions
23150 C...for s, c and b sea.
23151 C...Authors: M. Glueck, E. Reya and A. Vogt.
23152 
23153  FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
23154 
23155 C...Double precision declaration.
23156  IMPLICIT DOUBLE PRECISION (a - z)
23157 
23158 C...Evaluation.
23159  IF(s.LE.sth) THEN
23160  pygrvs = 0d0
23161  ELSE
23162  dx = sqrt(x)
23163  lx = log(1d0/x)
23164  pygrvs = (s - sth)**al / lx**ak * (1d0+ ag*dx + b*x) *
23165  & (1d0- x)**d * exp(-e + sqrt(es * s**be * lx))
23166  ENDIF
23167 
23168  RETURN
23169  END
23170 
23171 C*********************************************************************
23172 
23173 C...PYHFTH
23174 C...Gives threshold attractive/repulsive factor for heavy flavour
23175 C...production.
23176 
23177  FUNCTION pyhfth(SH,SQM,FRATT)
23178 
23179 C...Double precision and integer declarations.
23180  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23181  INTEGER pyk,pychge,pycomp
23182 C...Commonblocks.
23183  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23184  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23185  common/pyint1/mint(400),vint(400)
23186  SAVE /pydat1/,/pypars/,/pyint1/
23187 
23188 C...Value for alpha_strong.
23189  IF(mstp(35).LE.1) THEN
23190  alssg=parp(35)
23191  ELSE
23192  mst115=mstu(115)
23193  mstu(115)=mstp(36)
23194  q2bn=sqrt(max(1d0,sqm*((sqrt(sh)-2d0*sqrt(sqm))**2+
23195  & parp(36)**2)))
23196  alssg=pyalps(q2bn)
23197  mstu(115)=mst115
23198  ENDIF
23199 
23200 C...Evaluate attractive and repulsive factors.
23201  xattr=4d0*paru(1)*alssg/(3d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
23202  fattr=xattr/(1d0-exp(-min(50d0,xattr)))
23203  xrepu=paru(1)*alssg/(6d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
23204  frepu=xrepu/(exp(min(50d0,xrepu))-1d0)
23205  pyhfth=fratt*fattr+(1d0-fratt)*frepu
23206  vint(138)=pyhfth
23207 
23208  RETURN
23209  END
23210 
23211 C*********************************************************************
23212 
23213 C...PYSPLI
23214 C...Splits a hadron remnant into two (partons or hadron + parton)
23215 C...in case it is more complicated than just a quark or a diquark.
23216 
23217  SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
23218 
23219 C...Double precision and integer declarations.
23220  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23221  INTEGER pyk,pychge,pycomp
23222 C...Commonblocks.
23223  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23224  common/pyint1/mint(400),vint(400)
23225  SAVE /pypars/,/pyint1/
23226 C...Local array.
23227  dimension kfl(3)
23228 
23229 C...Preliminaries. Parton composition.
23230  kfa=iabs(kf)
23231  kfs=isign(1,kf)
23232  kfl(1)=mod(kfa/1000,10)
23233  kfl(2)=mod(kfa/100,10)
23234  kfl(3)=mod(kfa/10,10)
23235  IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN
23236  kfl(2)=int(1.5d0+pyr(0))
23237  IF(mint(105).EQ.333) kfl(2)=3
23238  IF(mint(105).EQ.443) kfl(2)=4
23239  kfl(3)=kfl(2)
23240  ELSEIF((kfa.EQ.111.OR.kfa.EQ.113).AND.pyr(0).GT.0.5d0) THEN
23241  kfl(2)=2
23242  kfl(3)=2
23243  ELSEIF(kfa.EQ.223.AND.pyr(0).GT.0.5d0) THEN
23244  kfl(2)=1
23245  kfl(3)=1
23246  ENDIF
23247  IF(kflin.NE.21.AND.kflin.NE.22.AND.kflin.NE.23) THEN
23248  kflr=kflin*kfs
23249  ELSE
23250  kflr=kflin
23251  ENDIF
23252  kflch=0
23253 
23254 C...Subdivide lepton.
23255  IF(kfa.GE.11.AND.kfa.LE.18) THEN
23256  IF(kflr.EQ.kfa) THEN
23257  kflsp=kfs*22
23258  ELSEIF(kflr.EQ.22) THEN
23259  kflsp=kfa
23260  ELSEIF(kflr.EQ.-24.AND.mod(kfa,2).EQ.1) THEN
23261  kflsp=kfa+1
23262  ELSEIF(kflr.EQ.24.AND.mod(kfa,2).EQ.0) THEN
23263  kflsp=kfa-1
23264  ELSEIF(kflr.EQ.21) THEN
23265  kflsp=kfa
23266  kflch=kfs*21
23267  ELSE
23268  kflsp=kfa
23269  kflch=-kflr
23270  ENDIF
23271 
23272 C...Subdivide photon.
23273  ELSEIF(kfa.EQ.22.AND.mint(109).NE.2) THEN
23274  IF(kflr.NE.21) THEN
23275  kflsp=-kflr
23276  ELSE
23277  ragr=0.75d0*pyr(0)
23278  kflsp=1
23279  IF(ragr.GT.0.125d0) kflsp=2
23280  IF(ragr.GT.0.625d0) kflsp=3
23281  IF(pyr(0).GT.0.5d0) kflsp=-kflsp
23282  kflch=-kflsp
23283  ENDIF
23284 
23285 C...Subdivide Reggeon or Pomeron.
23286  ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN
23287  IF(kflin.EQ.21) THEN
23288  kflsp=kfs*21
23289  ELSE
23290  kflsp=-kflin
23291  ENDIF
23292 
23293 C...Subdivide meson.
23294  ELSEIF(kfl(1).EQ.0) THEN
23295  kfl(2)=kfl(2)*(-1)**kfl(2)
23296  kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))
23297  IF(kflr.EQ.kfl(2)) THEN
23298  kflsp=kfl(3)
23299  ELSEIF(kflr.EQ.kfl(3)) THEN
23300  kflsp=kfl(2)
23301  ELSEIF(kflr.EQ.21.AND.pyr(0).GT.0.5d0) THEN
23302  kflsp=kfl(2)
23303  kflch=kfl(3)
23304  ELSEIF(kflr.EQ.21) THEN
23305  kflsp=kfl(3)
23306  kflch=kfl(2)
23307  ELSEIF(kflr*kfl(2).GT.0) THEN
23308  CALL pykfdi(-kflr,kfl(2),kfdump,kflch)
23309  kflsp=kfl(3)
23310  ELSE
23311  CALL pykfdi(-kflr,kfl(3),kfdump,kflch)
23312  kflsp=kfl(2)
23313  ENDIF
23314 
23315 C...Subdivide baryon.
23316  ELSE
23317  nagr=0
23318  DO 100 j=1,3
23319  IF(kflr.EQ.kfl(j)) nagr=nagr+1
23320  100 CONTINUE
23321  IF(nagr.GE.1) THEN
23322  ragr=0.00001d0+(nagr-0.00002d0)*pyr(0)
23323  iagr=0
23324  DO 110 j=1,3
23325  IF(kflr.EQ.kfl(j)) ragr=ragr-1d0
23326  IF(iagr.EQ.0.AND.ragr.LE.0d0) iagr=j
23327  110 CONTINUE
23328  ELSE
23329  iagr=1.00001d0+2.99998d0*pyr(0)
23330  ENDIF
23331  id1=1
23332  IF(iagr.EQ.1) id1=2
23333  IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3
23334  id2=6-iagr-id1
23335  ksp=3
23336  IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN
23337  IF(iagr.NE.3.AND.pyr(0).GT.0.25d0) ksp=1
23338  ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN
23339  IF(iagr.NE.1.AND.pyr(0).GT.0.25d0) ksp=1
23340  ELSEIF(mod(kfa,10).EQ.2) THEN
23341  IF(iagr.EQ.1) ksp=1
23342  IF(iagr.NE.1.AND.pyr(0).GT.0.75d0) ksp=1
23343  ENDIF
23344  kflsp=1000*kfl(id1)+100*kfl(id2)+ksp
23345  IF(kflr.EQ.21) THEN
23346  kflch=kfl(iagr)
23347  ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN
23348  CALL pykfdi(-kflr,kfl(iagr),kfdump,kflch)
23349  ELSEIF(nagr.EQ.0) THEN
23350  CALL pykfdi(10000+kflsp,-kflr,kfdump,kflch)
23351  kflsp=kfl(iagr)
23352  ENDIF
23353  ENDIF
23354 
23355 C...Add on correct sign for result.
23356  kflch=kflch*kfs
23357  kflsp=kflsp*kfs
23358 
23359  RETURN
23360  END
23361 
23362 C*********************************************************************
23363 
23364 C...PYGAMM
23365 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
23366 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
23367 C...(Dover, 1965) 6.1.36.
23368 
23369  FUNCTION pygamm(X)
23370 
23371 C...Double precision and integer declarations.
23372  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23373  INTEGER pyk,pychge,pycomp
23374 C...Local array and data.
23375  dimension b(8)
23376  DATA b/-0.577191652d0,0.988205891d0,-0.897056937d0,0.918206857d0,
23377  &-0.756704078d0,0.482199394d0,-0.193527818d0,0.035868343d0/
23378 
23379  nx=int(x)
23380  dx=x-nx
23381 
23382  pygamm=1d0
23383  dxp=1d0
23384  DO 100 i=1,8
23385  dxp=dxp*dx
23386  pygamm=pygamm+b(i)*dxp
23387  100 CONTINUE
23388  IF(x.LT.1d0) THEN
23389  pygamm=pygamm/x
23390  ELSE
23391  DO 110 ix=1,nx-1
23392  pygamm=(x-ix)*pygamm
23393  110 CONTINUE
23394  ENDIF
23395 
23396  RETURN
23397  END
23398 
23399 C***********************************************************************
23400 
23401 C...PYWAUX
23402 C...Calculates real and imaginary parts of the auxiliary functions W1
23403 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
23404 C...der Bij, Nucl. Phys. B297 (1988) 221.
23405 
23406  SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)
23407 
23408 C...Double precision and integer declarations.
23409  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23410  INTEGER pyk,pychge,pycomp
23411 C...Commonblocks.
23412  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23413  SAVE /pydat1/
23414 
23415  asinh(x)=log(x+sqrt(x**2+1d0))
23416  acosh(x)=log(x+sqrt(x**2-1d0))
23417 
23418  IF(eps.LT.0d0) THEN
23419  IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*asinh(sqrt(-1d0/eps))
23420  IF(iaux.EQ.2) wre=4d0*(asinh(sqrt(-1d0/eps)))**2
23421  wim=0d0
23422  ELSEIF(eps.LT.1d0) THEN
23423  IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*acosh(sqrt(1d0/eps))
23424  IF(iaux.EQ.2) wre=4d0*(acosh(sqrt(1d0/eps)))**2-paru(1)**2
23425  IF(iaux.EQ.1) wim=-paru(1)*sqrt(1d0-eps)
23426  IF(iaux.EQ.2) wim=-4d0*paru(1)*acosh(sqrt(1d0/eps))
23427  ELSE
23428  IF(iaux.EQ.1) wre=2d0*sqrt(eps-1d0)*asin(sqrt(1d0/eps))
23429  IF(iaux.EQ.2) wre=-4d0*(asin(sqrt(1d0/eps)))**2
23430  wim=0d0
23431  ENDIF
23432 
23433  RETURN
23434  END
23435 
23436 C***********************************************************************
23437 
23438 C...PYI3AU
23439 C...Calculates real and imaginary parts of the auxiliary function I3;
23440 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
23441 C...Nucl. Phys. B297 (1988) 221.
23442 
23443  SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)
23444 
23445 C...Double precision and integer declarations.
23446  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23447  INTEGER pyk,pychge,pycomp
23448 C...Commonblocks.
23449  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23450  SAVE /pydat1/
23451 
23452  be=0.5d0*(1d0+sqrt(1d0+rat*eps))
23453  IF(eps.LT.1d0) ga=0.5d0*(1d0+sqrt(1d0-eps))
23454 
23455  IF(eps.LT.0d0) THEN
23456  IF(abs(eps).LT.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN
23457  f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
23458  & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
23459  & pyspen(0.25d0*(rat+1d0)*eps/(1d0+0.25d0*rat*eps),0d0,1)-
23460  & pyspen((rat+1d0)/rat,0d0,1)+0.5d0*(log(1d0+0.25d0*rat*eps)**2-
23461  & log(0.25d0*rat*eps)**2)+log(1d0-0.25d0*eps)*
23462  & log((1d0+0.25d0*(rat-1d0)*eps)/(1d0+0.25d0*rat*eps))+
23463  & log(-0.25d0*eps)*log(0.25d0*rat*eps/(1d0+0.25d0*(rat-1d0)*
23464  & eps))
23465  ELSEIF(abs(eps).LT.1.d-4.AND.abs(rat*eps).GE.1.d-4) THEN
23466  f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
23467  & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
23468  & pyspen((be-1d0+0.25d0*eps)/be,0d0,1)-
23469  & pyspen((be-1d0+0.25d0*eps)/(be-1d0),0d0,1)+
23470  & 0.5d0*(log(be)**2-log(be-1d0)**2)+
23471  & log(1d0-0.25d0*eps)*log((be-0.25d0*eps)/be)+
23472  & log(-0.25d0*eps)*log((be-1d0)/(be-0.25d0*eps))
23473  ELSEIF(abs(eps).GE.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN
23474  f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
23475  & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
23476  & pyspen((1d0+0.25d0*rat*eps-ga)/(1d0+0.25d0*rat*eps),0d0,1)-
23477  & pyspen((1d0+0.25d0*rat*eps-ga)/(0.25d0*rat*eps),0d0,1)+
23478  & 0.5d0*(log(1d0+0.25d0*rat*eps)**2-log(0.25d0*rat*eps)**2)+
23479  & log(ga)*log((ga+0.25d0*rat*eps)/(1d0+0.25d0*rat*eps))+
23480  & log(ga-1d0)*log(0.25d0*rat*eps/(ga+0.25d0*rat*eps))
23481  ELSE
23482  f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
23483  & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen((be-ga)/be,0d0,1)-
23484  & pyspen((be-ga)/(be-1d0),0d0,1)+0.5d0*(log(be)**2-
23485  & log(be-1d0)**2)+log(ga)*log((ga+be-1d0)/be)+
23486  & log(ga-1d0)*log((be-1d0)/(ga+be-1d0))
23487  ENDIF
23488  f3im=0d0
23489  ELSEIF(eps.LT.1d0) THEN
23490  IF(abs(eps).LT.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN
23491  f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
23492  & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
23493  & pyspen((1d0-0.25d0*eps)/(-0.25d0*(rat+1d0)*eps),0d0,1)-
23494  & pyspen(1d0/(rat+1d0),0d0,1)+log((1d0-0.25d0*eps)/
23495  & (0.25d0*eps))*log((1d0+0.25d0*(rat-1d0)*eps)/
23496  & (0.25d0*(rat+1d0)*eps))
23497  f3im=-paru(1)*log((1d0+0.25d0*(rat-1d0)*eps)/
23498  & (0.25d0*(rat+1d0)*eps))
23499  ELSEIF(abs(eps).LT.1.d-4.AND.abs(rat*eps).GE.1.d-4) THEN
23500  f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
23501  & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
23502  & pyspen((1d0-0.25d0*eps)/(1d0-0.25d0*eps-be),0d0,1)-
23503  & pyspen(-0.25d0*eps/(1d0-0.25d0*eps-be),0d0,1)+
23504  & log((1d0-0.25d0*eps)/(0.25d0*eps))*
23505  & log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
23506  f3im=-paru(1)*log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
23507  ELSEIF(abs(eps).GE.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN
23508  f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
23509  & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
23510  & pyspen(ga/(ga-1d0-0.25d0*rat*eps),0d0,1)-
23511  & pyspen((ga-1d0)/(ga-1d0-0.25d0*rat*eps),0d0,1)+
23512  & log(ga/(1d0-ga))*log((ga+0.25d0*rat*eps)/
23513  & (1d0+0.25d0*rat*eps-ga))
23514  f3im=-paru(1)*log((ga+0.25d0*rat*eps)/
23515  & (1d0+0.25d0*rat*eps-ga))
23516  ELSE
23517  f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
23518  & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen(ga/(ga-be),0d0,1)-
23519  & pyspen((ga-1d0)/(ga-be),0d0,1)+log(ga/(1d0-ga))*
23520  & log((ga+be-1d0)/(be-ga))
23521  f3im=-paru(1)*log((ga+be-1d0)/(be-ga))
23522  ENDIF
23523  ELSE
23524  rsq=eps/(eps-1d0+(2d0*be-1d0)**2)
23525  rcthe=rsq*(1d0-2d0*be/eps)
23526  rsthe=sqrt(max(0d0,rsq-rcthe**2))
23527  rcphi=rsq*(1d0+2d0*(be-1d0)/eps)
23528  rsphi=sqrt(max(0d0,rsq-rcphi**2))
23529  r=sqrt(rsq)
23530  the=acos(max(-0.999999d0,min(0.999999d0,rcthe/r)))
23531  phi=acos(max(-0.999999d0,min(0.999999d0,rcphi/r)))
23532  f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-
23533  & pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+
23534  & (phi-the)*(phi+the-paru(1))
23535  f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-
23536  & pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)
23537  ENDIF
23538 
23539  y3re=2d0/(2d0*be-1d0)*f3re
23540  y3im=2d0/(2d0*be-1d0)*f3im
23541 
23542  RETURN
23543  END
23544 
23545 C***********************************************************************
23546 
23547 C...PYSPEN
23548 C...Calculates real and imaginary part of Spence function; see
23549 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
23550 
23551  FUNCTION pyspen(XREIN,XIMIN,IREIM)
23552 
23553 C...Double precision and integer declarations.
23554  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23555  INTEGER pyk,pychge,pycomp
23556 C...Commonblocks.
23557  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23558  SAVE /pydat1/
23559 C...Local array and data.
23560  dimension b(0:14)
23561  DATA b/
23562  &1.000000d+00, -5.000000d-01, 1.666667d-01,
23563  &0.000000d+00, -3.333333d-02, 0.000000d+00,
23564  &2.380952d-02, 0.000000d+00, -3.333333d-02,
23565  &0.000000d+00, 7.575757d-02, 0.000000d+00,
23566  &-2.531135d-01, 0.000000d+00, 1.166667d+00/
23567 
23568  xre=xrein
23569  xim=ximin
23570  IF(abs(1d0-xre).LT.1.d-6.AND.abs(xim).LT.1.d-6) THEN
23571  IF(ireim.EQ.1) pyspen=paru(1)**2/6d0
23572  IF(ireim.EQ.2) pyspen=0d0
23573  RETURN
23574  ENDIF
23575 
23576  xmod=sqrt(xre**2+xim**2)
23577  IF(xmod.LT.1.d-6) THEN
23578  IF(ireim.EQ.1) pyspen=0d0
23579  IF(ireim.EQ.2) pyspen=0d0
23580  RETURN
23581  ENDIF
23582 
23583  xarg=sign(acos(xre/xmod),xim)
23584  sp0re=0d0
23585  sp0im=0d0
23586  sgn=1d0
23587  IF(xmod.GT.1d0) THEN
23588  algxre=log(xmod)
23589  algxim=xarg-sign(paru(1),xarg)
23590  sp0re=-paru(1)**2/6d0-(algxre**2-algxim**2)/2d0
23591  sp0im=-algxre*algxim
23592  sgn=-1d0
23593  xmod=1d0/xmod
23594  xarg=-xarg
23595  xre=xmod*cos(xarg)
23596  xim=xmod*sin(xarg)
23597  ENDIF
23598  IF(xre.GT.0.5d0) THEN
23599  algxre=log(xmod)
23600  algxim=xarg
23601  xre=1d0-xre
23602  xim=-xim
23603  xmod=sqrt(xre**2+xim**2)
23604  xarg=sign(acos(xre/xmod),xim)
23605  algyre=log(xmod)
23606  algyim=xarg
23607  sp0re=sp0re+sgn*(paru(1)**2/6d0-(algxre*algyre-algxim*algyim))
23608  sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)
23609  sgn=-sgn
23610  ENDIF
23611 
23612  xre=1d0-xre
23613  xim=-xim
23614  xmod=sqrt(xre**2+xim**2)
23615  xarg=sign(acos(xre/xmod),xim)
23616  zre=-log(xmod)
23617  zim=-xarg
23618 
23619  spre=0d0
23620  spim=0d0
23621  savere=1d0
23622  saveim=0d0
23623  DO 100 i=0,14
23624  IF(max(abs(savere),abs(saveim)).LT.1d-30) goto 110
23625  termre=(savere*zre-saveim*zim)/dble(i+1)
23626  termim=(savere*zim+saveim*zre)/dble(i+1)
23627  savere=termre
23628  saveim=termim
23629  spre=spre+b(i)*termre
23630  spim=spim+b(i)*termim
23631  100 CONTINUE
23632 
23633  110 IF(ireim.EQ.1) pyspen=sp0re+sgn*spre
23634  IF(ireim.EQ.2) pyspen=sp0im+sgn*spim
23635 
23636  RETURN
23637  END
23638 
23639 C***********************************************************************
23640 
23641 C...PYQQBH
23642 C...Calculates the matrix element for the processes
23643 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
23644 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
23645 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
23646 
23647  SUBROUTINE pyqqbh(WTQQBH)
23648 
23649 C...Double precision and integer declarations.
23650  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23651  INTEGER pyk,pychge,pycomp
23652 C...Commonblocks.
23653  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23654  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23655  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23656  common/pyint1/mint(400),vint(400)
23657  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
23658  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/
23659 C...Local arrays and function.
23660  dimension pp(15,4),clr(8,8),fm(10,10),rm(8,8),dx(8)
23661  dot(i,j)=pp(i,4)*pp(j,4)-pp(i,1)*pp(j,1)-pp(i,2)*pp(j,2)-
23662  &pp(i,3)*pp(j,3)
23663 
23664 C...Mass parameters.
23665  wtqqbh=0d0
23666  isub=mint(1)
23667  shpr=sqrt(vint(26))*vint(1)
23668  pq=pmas(pycomp(kfpr(isub,2)),1)
23669  ph=sqrt(vint(21))*vint(1)
23670  spq=pq**2
23671  sph=ph**2
23672 
23673 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
23674  DO 100 i=1,2
23675  pt=sqrt(max(0d0,vint(197+5*i)))
23676  pp(i,1)=pt*cos(vint(198+5*i))
23677  pp(i,2)=pt*sin(vint(198+5*i))
23678  100 CONTINUE
23679  pp(3,1)=-pp(1,1)-pp(2,1)
23680  pp(3,2)=-pp(1,2)-pp(2,2)
23681  pms1=spq+pp(1,1)**2+pp(1,2)**2
23682  pms2=spq+pp(2,1)**2+pp(2,2)**2
23683  pms3=sph+pp(3,1)**2+pp(3,2)**2
23684  pmt3=sqrt(pms3)
23685  pp(3,3)=pmt3*sinh(vint(211))
23686  pp(3,4)=pmt3*cosh(vint(211))
23687  pms12=(shpr-pp(3,4))**2-pp(3,3)**2
23688  pp(1,3)=(-pp(3,3)*(pms12+pms1-pms2)+
23689  &vint(213)*(shpr-pp(3,4))*vint(220))/(2d0*pms12)
23690  pp(2,3)=-pp(1,3)-pp(3,3)
23691  pp(1,4)=sqrt(pms1+pp(1,3)**2)
23692  pp(2,4)=sqrt(pms2+pp(2,3)**2)
23693 
23694 C...Set up incoming kinematics and derived momentum combinations.
23695  DO 110 i=4,5
23696  pp(i,1)=0d0
23697  pp(i,2)=0d0
23698  pp(i,3)=-0.5d0*shpr*(-1)**i
23699  pp(i,4)=-0.5d0*shpr
23700  110 CONTINUE
23701  DO 120 j=1,4
23702  pp(6,j)=pp(1,j)+pp(2,j)
23703  pp(7,j)=pp(1,j)+pp(3,j)
23704  pp(8,j)=pp(1,j)+pp(4,j)
23705  pp(9,j)=pp(1,j)+pp(5,j)
23706  pp(10,j)=-pp(2,j)-pp(3,j)
23707  pp(11,j)=-pp(2,j)-pp(4,j)
23708  pp(12,j)=-pp(2,j)-pp(5,j)
23709  pp(13,j)=-pp(4,j)-pp(5,j)
23710  120 CONTINUE
23711 
23712 C...Derived kinematics invariants.
23713  x1=dot(1,2)
23714  x2=dot(1,3)
23715  x3=dot(1,4)
23716  x4=dot(1,5)
23717  x5=dot(2,3)
23718  x6=dot(2,4)
23719  x7=dot(2,5)
23720  x8=dot(3,4)
23721  x9=dot(3,5)
23722  x10=dot(4,5)
23723 
23724 C...Propagators.
23725  ss1=dot(7,7)-spq
23726  ss2=dot(8,8)-spq
23727  ss3=dot(9,9)-spq
23728  ss4=dot(10,10)-spq
23729  ss5=dot(11,11)-spq
23730  ss6=dot(12,12)-spq
23731  ss7=dot(13,13)
23732  dx(1)=ss1*ss6
23733  dx(2)=ss2*ss6
23734  dx(3)=ss2*ss4
23735  dx(4)=ss1*ss5
23736  dx(5)=ss3*ss5
23737  dx(6)=ss3*ss4
23738  dx(7)=ss7*ss1
23739  dx(8)=ss7*ss4
23740 
23741 C...Define colour coefficients for g + g -> Q + Qbar + H.
23742  IF(isub.EQ.121.OR.isub.EQ.181.OR.isub.EQ.186) THEN
23743  DO 140 i=1,3
23744  DO 130 j=1,3
23745  clr(i,j)=16d0/3d0
23746  clr(i+3,j+3)=16d0/3d0
23747  clr(i,j+3)=-2d0/3d0
23748  clr(i+3,j)=-2d0/3d0
23749  130 CONTINUE
23750  140 CONTINUE
23751  DO 160 l=1,2
23752  DO 150 i=1,3
23753  clr(i,6+l)=-6d0
23754  clr(i+3,6+l)=6d0
23755  clr(6+l,i)=-6d0
23756  clr(6+l,i+3)=6d0
23757  150 CONTINUE
23758  160 CONTINUE
23759  DO 180 k1=1,2
23760  DO 170 k2=1,2
23761  clr(6+k1,6+k2)=12d0
23762  170 CONTINUE
23763  180 CONTINUE
23764 
23765 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
23766  fm(1,1)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x4+x9+2*
23767  & x7+x5)+8*pq**2*ph**2*(-x1-x4+2*x7)+16*pq**2*(x2*x9+4*x2*
23768  & x7+x2*x5-2*x4*x7-2*x9*x7)+8*ph**2*x4*x7-16*x2*x9*x7
23769  fm(1,2)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10+x9-x8+2
23770  & *x7-4*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x4-2*x2*x10+x2*x7-2*
23771  & x2*x6-2*x3*x7+2*x4*x7+4*x10*x7-x9*x7-x8*x7)+16*x2*x7*(x4+
23772  & x10)
23773  fm(1,3)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-2*x3-4*
23774  & x4-8*x10+x9+x8-2*x7-4*x6+2*x5)-(4*pq**2*ph**2)*(x1+x4+x10
23775  & +x6)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
23776  & -4*x2*x4-5*x2*x10+x2*x8-x2*x7-3*x2*x6+x2*x5+x3*x9+2*x3*x7
23777  & -x3*x5+x4*x8+2*x4*x6-3*x4*x5-5*x10*x5+x9*x8+x9*x6+x9*x5+
23778  & x8*x7-4*x6*x5+x5**2)-(16*x2*x5)*(x1+x4+x10+x6)
23779  fm(1,4)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1+x2-x3-x4+x10-
23780  & x9-x8+2*x7+2*x6-x5)+4*pq**2*ph**2*(x1+x3+x4+x10+2*x7+2*x6
23781  & )+8*pq**2*(4*x1*x10+4*x1*x7+4*x1*x6+2*x2*x10-x2*x9-x2*x8+
23782  & 4*x2*x7+4*x2*x6-x2*x5+4*x10*x5+4*x7*x5+4*x6*x5)-(8*ph**2*
23783  & x1)*(x10+x7+x6)+16*x2*x5*(x10+x7+x6)
23784  fm(1,5)=8*pq**4*(-2*x1-2*x4+x10-x9)+4*pq**2*(4*x1**2-2*x1*
23785  & x2+8*x1*x3+6*x1*x10-2*x1*x9+4*x1*x8+4*x1*x7+4*x1*x6+2*x1*
23786  & x5+x2*x10+4*x3*x4-x3*x9+2*x3*x7+3*x4*x8-2*x4*x6+2*x4*x5-4
23787  & *x10*x7+3*x10*x5-3*x9*x6+3*x8*x7-4*x7**2+4*x7*x5)+8*(x1**
23788  & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5-x1*x4*
23789  & x8-x1*x4*x5+x1*x10*x9+x1*x9*x7+x1*x9*x6-x1*x8*x7-x2*x3*x7
23790  & +x2*x4*x6-x2*x10*x7-x2*x7**2+x3*x7*x5-x4*x10*x5-x4*x7*x5-
23791  & x4*x6*x5)
23792  fm(1,6)=16*pq**4*(-4*x1-x4+x9-x7)+4*pq**2*ph**2*(-2*x1-x4-
23793  & x7)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x4-3*x1*x9-2*x1*x7-3*
23794  & x1*x5-2*x2*x4-2*x7*x5)-8*ph**2*x4*x7+8*(-x1*x2*x9-2*x1*x2
23795  & *x5-x1*x9**2-x1*x9*x5+x2**2*x7-x2*x4*x5+x2*x9*x7-x2*x7*x5
23796  & +x4*x9*x5+x4*x5**2)
23797  fm(1,7)=8*pq**4*(2*x3+x4+3*x10+x9+2*x8+3*x7+6*x6)+2*pq**2*
23798  & ph**2*(-2*x3-x4+3*x10+3*x7+6*x6)+4*pq**2*(4*x1*x10+4*x1*
23799  & x7+8*x1*x6+6*x2*x10+x2*x9+2*x2*x8+6*x2*x7+12*x2*x6-8*x3*
23800  & x7+4*x4*x7+4*x4*x6+4*x10*x5+4*x9*x7+4*x9*x6-8*x8*x7+4*x7*
23801  & x5+8*x6*x5)+4*ph**2*(-x1*x10-x1*x7-2*x1*x6+2*x3*x7-x4*x7-
23802  & x4*x6)+8*x2*(x10*x5+x9*x7+x9*x6-2*x8*x7+x7*x5+2*x6*x5)
23803  fm(1,8)=8*pq**4*(2*x3+x4+3*x10+2*x9+x8+3*x7+6*x6)+2*pq**2*
23804  & ph**2*(-2*x3-x4+2*x10+x7+2*x6)+4*pq**2*(4*x1*x10-2*x1*x9+
23805  & 2*x1*x8+4*x1*x7+8*x1*x6+5*x2*x10+2*x2*x9+x2*x8+4*x2*x7+8*
23806  & x2*x6-x3*x9-8*x3*x7+2*x3*x5+2*x4*x9-x4*x8+4*x4*x7+4*x4*x6
23807  & +4*x4*x5+5*x10*x5+x9**2-x9*x8+2*x9*x7+5*x9*x6+x9*x5-7*x8*
23808  & x7+2*x8*x5+2*x7*x5+10*x6*x5)+2*ph**2*(-x1*x10+x3*x7-2*x4*
23809  & x7+x4*x6)+4*(-x1*x9**2+x1*x9*x8-2*x1*x9*x5-x1*x8*x5+2*x2*
23810  & x10*x5+x2*x9*x7+x2*x9*x6-2*x2*x8*x7+3*x2*x6*x5+x3*x9*x5+
23811  & x3*x5**2+x4*x9*x5-2*x4*x8*x5+2*x4*x5**2)
23812  fm(2,2)=16*pq**6+16*pq**4*(-x1+x3-x4-x10+x7-x6)+16*pq**2*(
23813  & x3*x10+x3*x7+x3*x6+x4*x7+x10*x7)-16*x3*x10*x7
23814  fm(2,3)=16*pq**6+8*pq**4*(-2*x1+x2+2*x3-4*x4-4*x10-x9+x8-2
23815  & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5+4*x3*x10-x3*x9-x3*x8-2*x3*
23816  & x7+2*x3*x6+x3*x5-2*x4*x5-2*x10*x5-2*x6*x5)+16*x3*x5*(x10+
23817  & x6)
23818  fm(2,4)=8*pq**4*(-2*x1-2*x3+x10-x8)+4*pq**2*(4*x1**2-2*x1*
23819  & x2+8*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+4*x1*x7+4*x1*x6+2*x1*
23820  & x5+x2*x10+4*x3*x4+3*x3*x9-2*x3*x7+2*x3*x5-x4*x8+2*x4*x6-4
23821  & *x10*x6+3*x10*x5+3*x9*x6-3*x8*x7-4*x6**2+4*x6*x5)+8*(-x1
23822  & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9-x1*x3*x5+x1*x4
23823  & *x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x1*x8*x6+x2*x3*
23824  & x7-x2*x4*x6-x2*x10*x6-x2*x6**2-x3*x10*x5-x3*x7*x5-x3*x6*
23825  & x5+x4*x6*x5)
23826  fm(2,5)=16*pq**4*x10+8*pq**2*(2*x1**2+2*x1*x3+2*x1*x4+2*x1
23827  & *x10+2*x1*x7+2*x1*x6+x3*x7+x4*x6)+8*(-2*x1**3-2*x1**2*x3-
23828  & 2*x1**2*x4-2*x1**2*x10-2*x1**2*x7-2*x1**2*x6-2*x1*x3*x4-
23829  & x1*x3*x10-2*x1*x3*x6-x1*x4*x10-2*x1*x4*x7-x1*x10**2-x1*
23830  & x10*x7-x1*x10*x6-2*x1*x7*x6+x3**2*x7-x3*x4*x7-x3*x4*x6+x3
23831  & *x10*x7+x3*x7**2-x3*x7*x6+x4**2*x6+x4*x10*x6-x4*x7*x6+x4*
23832  & x6**2)
23833  fm(2,6)=8*pq**4*(-2*x1+x10-x9-2*x7)+4*pq**2*(4*x1**2+2*x1*
23834  & x2+4*x1*x3+4*x1*x4+6*x1*x10-2*x1*x9+4*x1*x8+8*x1*x6-2*x1*
23835  & x5+4*x2*x4+3*x2*x10+2*x2*x7-3*x3*x9-2*x3*x7-4*x4**2-4*x4*
23836  & x10+3*x4*x8+2*x4*x6+x10*x5-x9*x6+3*x8*x7+4*x7*x6)+8*(x1**
23837  & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5+x1*x4*
23838  & x9-x1*x4*x8-x1*x4*x5+x1*x10*x9+x1*x9*x6-x1*x8*x7-x2*x3*x7
23839  & -x2*x4*x7+x2*x4*x6-x2*x10*x7+x3*x7*x5-x4**2*x5-x4*x10*x5-
23840  & x4*x6*x5)
23841  fm(2,7)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
23842  & 2*x1*x4-2*x1*x10+x1*x9-x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
23843  & x4+3*x2*x10+x2*x7+2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9-2*x3*
23844  & x7-4*x3*x6-x3*x5-6*x4**2-6*x4*x10-3*x4*x9-x4*x8-4*x4*x7-2
23845  & *x4*x6-2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+x10*x5
23846  & +x9*x7-2*x8*x7-2*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
23847  & -x1**2*x9+x1**2*x8-2*x1*x2*x10-3*x1*x2*x7-3*x1*x2*x6+x1*
23848  & x3*x9-x1*x3*x5+x1*x4*x9+x1*x4*x8+x1*x4*x5+x1*x10*x9+x1*
23849  & x10*x8-x1*x9*x6+x1*x8*x6+x2*x3*x7-3*x2*x4*x7-x2*x4*x6-3*
23850  & x2*x10*x7-3*x2*x10*x6-3*x2*x7*x6-3*x2*x6**2-2*x3*x4*x5-x3
23851  & *x10*x5-x3*x6*x5-x4**2*x5-x4*x10*x5+x4*x6*x5)
23852  fm(2,8)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
23853  & 2*x1*x4-2*x1*x10-x1*x9+x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
23854  & x4+x2*x10-x2*x7-2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9+x3*x8-2*
23855  & x3*x7-4*x3*x6+x3*x5-6*x4**2-6*x4*x10-2*x4*x9-4*x4*x7-2*x4
23856  & *x6+2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+3*x10*x5-
23857  & x9*x6-2*x8*x7-3*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
23858  & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6-3*x1*x3*x5+x1*x4*x9-
23859  & x1*x4*x8-3*x1*x4*x5+x1*x10*x9+x1*x10*x8-2*x1*x10*x5+x1*x9
23860  & *x6+x1*x8*x7+x1*x8*x6-x2*x4*x7+x2*x4*x6-x2*x10*x7-x2*x10*
23861  & x6-2*x2*x7*x6-x2*x6**2-3*x3*x4*x5-3*x3*x10*x5+x3*x7*x5-3*
23862  & x3*x6*x5-3*x4**2*x5-3*x4*x10*x5-x4*x6*x5)
23863  fm(3,3)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x3+x8+x6
23864  & +2*x5)+8*pq**2*ph**2*(-x1+2*x3-x6)+16*pq**2*(x2*x5-2*x3*
23865  & x8-2*x3*x6+4*x3*x5+x8*x5)+8*ph**2*x3*x6-16*x3*x8*x5
23866  fm(3,4)=16*pq**4*(-4*x1-x3+x8-x6)+4*pq**2*ph**2*(-2*x1-x3-
23867  & x6)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x3-3*x1*x8-2*x1*x6-3*
23868  & x1*x5-2*x2*x3-2*x6*x5)-8*ph**2*x3*x6+8*(-x1*x2*x8-2*x1*x2
23869  & *x5-x1*x8**2-x1*x8*x5+x2**2*x6-x2*x3*x5+x2*x8*x6-x2*x6*x5
23870  & +x3*x8*x5+x3*x5**2)
23871  fm(3,5)=8*pq**4*(-2*x1+x10-x8-2*x6)+4*pq**2*(4*x1**2+2*x1*
23872  & x2+4*x1*x3+4*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+8*x1*x7-2*x1*
23873  & x5+4*x2*x3+3*x2*x10+2*x2*x6-4*x3**2-4*x3*x10+3*x3*x9+2*x3
23874  & *x7-3*x4*x8-2*x4*x6+x10*x5+3*x9*x6-x8*x7+4*x7*x6)+8*(-x1
23875  & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9+x1*x3*x8-x1*x3
23876  & *x5+x1*x4*x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x2*x3*
23877  & x7-x2*x3*x6-x2*x4*x6-x2*x10*x6-x3**2*x5-x3*x10*x5-x3*x7*
23878  & x5+x4*x6*x5)
23879  fm(3,6)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1-x2+2*x3+2*x4+
23880  & x10-x9-x8-x7-x6+x5)+4*pq**2*ph**2*(x1+2*x3+2*x4+x10+x7+x6
23881  & )+8*pq**2*(4*x1*x3+4*x1*x4+4*x1*x10+4*x2*x3+4*x2*x4+4*x2*
23882  & x10-x2*x5+4*x3*x5+4*x4*x5+2*x10*x5-x9*x5-x8*x5)-(8*ph**2*
23883  & x1)*(x3+x4+x10)+16*x2*x5*(x3+x4+x10)
23884  fm(3,7)=8*pq**4*(3*x3+6*x4+3*x10+x9+2*x8+2*x7+x6)+2*pq**2*
23885  & ph**2*(x3+2*x4+2*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+4*
23886  & x1*x10+2*x1*x9-2*x1*x8+2*x2*x3+10*x2*x4+5*x2*x10+2*x2*x9+
23887  & x2*x8+2*x2*x7+4*x2*x6-7*x3*x9+2*x3*x8-8*x3*x7+4*x3*x6+4*
23888  & x3*x5+5*x4*x8+4*x4*x6+8*x4*x5+5*x10*x5-x9*x8-x9*x6+x9*x5+
23889  & x8**2-x8*x7+2*x8*x6+2*x8*x5)+2*ph**2*(-x1*x10+x3*x7-2*x3*
23890  & x6+x4*x6)+4*(-x1*x2*x9-2*x1*x2*x8+x1*x9*x8-x1*x8**2+x2**2
23891  & *x7+2*x2**2*x6+3*x2*x4*x5+2*x2*x10*x5-2*x2*x9*x6+x2*x8*x7
23892  & +x2*x8*x6-2*x3*x9*x5+x3*x8*x5+x4*x8*x5)
23893  fm(3,8)=8*pq**4*(3*x3+6*x4+3*x10+2*x9+x8+2*x7+x6)+2*pq**2*
23894  & ph**2*(3*x3+6*x4+3*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+
23895  & 4*x1*x10+4*x2*x3+8*x2*x4+4*x2*x10-8*x3*x9+4*x3*x8-8*x3*x7
23896  & +4*x3*x6+6*x3*x5+4*x4*x8+4*x4*x6+12*x4*x5+6*x10*x5+2*x9*
23897  & x5+x8*x5)+4*ph**2*(-x1*x3-2*x1*x4-x1*x10+2*x3*x7-x3*x6-x4
23898  & *x6)+8*x5*(x2*x3+2*x2*x4+x2*x10-2*x3*x9+x3*x8+x4*x8)
23899  fm(4,4)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x3+x8+2*
23900  & x6+x5)+8*pq**2*ph**2*(-x1-x3+2*x6)+16*pq**2*(x2*x8+4*x2*
23901  & x6+x2*x5-2*x3*x6-2*x8*x6)+8*ph**2*x3*x6-16*x2*x8*x6
23902  fm(4,5)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10-x9+x8-4
23903  & *x7+2*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x3-2*x2*x10-2*x2*x7+
23904  & x2*x6+2*x3*x6-2*x4*x6+4*x10*x6-x9*x6-x8*x6)+16*x2*x6*(x3+
23905  & x10)
23906  fm(4,6)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-4*x3-2*
23907  & x4-8*x10+x9+x8-4*x7-2*x6+2*x5)-(4*pq**2*ph**2)*(x1+x3+x10
23908  & +x7)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
23909  & -4*x2*x3-5*x2*x10+x2*x9-3*x2*x7-x2*x6+x2*x5+x3*x9+2*x3*x7
23910  & -3*x3*x5+x4*x8+2*x4*x6-x4*x5-5*x10*x5+x9*x8+x9*x6+x8*x7+
23911  & x8*x5-4*x7*x5+x5**2)-(16*x2*x5)*(x1+x3+x10+x7)
23912  fm(4,7)=8*pq**4*(-x3-2*x4-3*x10-2*x9-x8-6*x7-3*x6)+2*pq**2
23913  & *ph**2*(x3+2*x4-3*x10-6*x7-3*x6)+4*pq**2*(-4*x1*x10-8*x1*
23914  & x7-4*x1*x6-6*x2*x10-2*x2*x9-x2*x8-12*x2*x7-6*x2*x6-4*x3*
23915  & x7-4*x3*x6+8*x4*x6-4*x10*x5+8*x9*x6-4*x8*x7-4*x8*x6-8*x7*
23916  & x5-4*x6*x5)+4*ph**2*(x1*x10+2*x1*x7+x1*x6+x3*x7+x3*x6-2*
23917  & x4*x6)+8*x2*(-x10*x5+2*x9*x6-x8*x7-x8*x6-2*x7*x5-x6*x5)
23918  fm(4,8)=8*pq**4*(-x3-2*x4-3*x10-x9-2*x8-6*x7-3*x6)+2*pq**2
23919  & *ph**2*(x3+2*x4-2*x10-2*x7-x6)+4*pq**2*(-4*x1*x10-2*x1*x9
23920  & +2*x1*x8-8*x1*x7-4*x1*x6-5*x2*x10-x2*x9-2*x2*x8-8*x2*x7-4
23921  & *x2*x6+x3*x9-2*x3*x8-4*x3*x7-4*x3*x6-4*x3*x5+x4*x8+8*x4*
23922  & x6-2*x4*x5-5*x10*x5+x9*x8+7*x9*x6-2*x9*x5-x8**2-5*x8*x7-2
23923  & *x8*x6-x8*x5-10*x7*x5-2*x6*x5)+2*ph**2*(x1*x10-x3*x7+2*x3
23924  & *x6-x4*x6)+4*(-x1*x9*x8+x1*x9*x5+x1*x8**2+2*x1*x8*x5-2*x2
23925  & *x10*x5+2*x2*x9*x6-x2*x8*x7-x2*x8*x6-3*x2*x7*x5+2*x3*x9*
23926  & x5-x3*x8*x5-2*x3*x5**2-x4*x8*x5-x4*x5**2)
23927  fm(5,5)=16*pq**6+16*pq**4*(-x1-x3+x4-x10-x7+x6)+16*pq**2*(
23928  & x3*x6+x4*x10+x4*x7+x4*x6+x10*x6)-16*x4*x10*x6
23929  fm(5,6)=16*pq**6+8*pq**4*(-2*x1+x2-4*x3+2*x4-4*x10+x9-x8-2
23930  & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5-2*x3*x5+4*x4*x10-x4*x9-x4*
23931  & x8+2*x4*x7-2*x4*x6+x4*x5-2*x10*x5-2*x7*x5)+16*x4*x5*(x10+
23932  & x7)
23933  fm(5,7)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
23934  & 4*x1*x4+2*x1*x10+x1*x9-x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
23935  & x4-3*x2*x10-2*x2*x7-x2*x6+6*x3**2+6*x3*x4+6*x3*x10+x3*x9+
23936  & 3*x3*x8+2*x3*x7+4*x3*x6+2*x3*x5+6*x4*x10+2*x4*x8+4*x4*x7+
23937  & 2*x4*x6+x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-x10*x5+
23938  & 2*x9*x7+2*x9*x6-x8*x6+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(-
23939  & x1**2*x9+x1**2*x8+2*x1*x2*x10+3*x1*x2*x7+3*x1*x2*x6-x1*x3
23940  & *x9-x1*x3*x8-x1*x3*x5-x1*x4*x8+x1*x4*x5-x1*x10*x9-x1*x10*
23941  & x8-x1*x9*x7+x1*x8*x7+x2*x3*x7+3*x2*x3*x6-x2*x4*x6+3*x2*
23942  & x10*x7+3*x2*x10*x6+3*x2*x7**2+3*x2*x7*x6+x3**2*x5+2*x3*x4
23943  & *x5+x3*x10*x5-x3*x7*x5+x4*x10*x5+x4*x7*x5)
23944  fm(5,8)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
23945  & 4*x1*x4+2*x1*x10-x1*x9+x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
23946  & x4-x2*x10+2*x2*x7+x2*x6+6*x3**2+6*x3*x4+6*x3*x10+2*x3*x8+
23947  & 2*x3*x7+4*x3*x6-2*x3*x5+6*x4*x10-x4*x9+2*x4*x8+4*x4*x7+2*
23948  & x4*x6-x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-3*x10*x5+
23949  & 3*x9*x7+2*x9*x6+x8*x7+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(
23950  & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9-x1*x3*x8+3*
23951  & x1*x3*x5+3*x1*x4*x5-x1*x10*x9-x1*x10*x8+2*x1*x10*x5-x1*x9
23952  & *x7-x1*x9*x6-x1*x8*x7-x2*x3*x7+x2*x3*x6+x2*x10*x7+x2*x10*
23953  & x6+x2*x7**2+2*x2*x7*x6+3*x3**2*x5+3*x3*x4*x5+3*x3*x10*x5+
23954  & x3*x7*x5+3*x4*x10*x5+3*x4*x7*x5-x4*x6*x5)
23955  fm(6,6)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x4+x9+x7
23956  & +2*x5)+8*pq**2*ph**2*(-x1+2*x4-x7)+16*pq**2*(x2*x5-2*x4*
23957  & x9-2*x4*x7+4*x4*x5+x9*x5)+8*ph**2*x4*x7-16*x4*x9*x5
23958  fm(6,7)=8*pq**4*(-6*x3-3*x4-3*x10-2*x9-x8-x7-2*x6)+2*pq**2
23959  & *ph**2*(-2*x3-x4-2*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*x4
23960  & -4*x1*x10+2*x1*x9-2*x1*x8-10*x2*x3-2*x2*x4-5*x2*x10-x2*x9
23961  & -2*x2*x8-4*x2*x7-2*x2*x6-5*x3*x9-4*x3*x7-8*x3*x5-2*x4*x9+
23962  & 7*x4*x8-4*x4*x7+8*x4*x6-4*x4*x5-5*x10*x5-x9**2+x9*x8-2*x9
23963  & *x7+x9*x6-2*x9*x5+x8*x7-x8*x5)+2*ph**2*(x1*x10-x3*x7+2*x4
23964  & *x7-x4*x6)+4*(2*x1*x2*x9+x1*x2*x8+x1*x9**2-x1*x9*x8-2*x2
23965  & **2*x7-x2**2*x6-3*x2*x3*x5-2*x2*x10*x5-x2*x9*x7-x2*x9*x6+
23966  & 2*x2*x8*x7-x3*x9*x5-x4*x9*x5+2*x4*x8*x5)
23967  fm(6,8)=8*pq**4*(-6*x3-3*x4-3*x10-x9-2*x8-x7-2*x6)+2*pq**2
23968  & *ph**2*(-6*x3-3*x4-3*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*
23969  & x4-4*x1*x10-8*x2*x3-4*x2*x4-4*x2*x10-4*x3*x9-4*x3*x7-12*
23970  & x3*x5-4*x4*x9+8*x4*x8-4*x4*x7+8*x4*x6-6*x4*x5-6*x10*x5-x9
23971  & *x5-2*x8*x5)+4*ph**2*(2*x1*x3+x1*x4+x1*x10+x3*x7+x4*x7-2*
23972  & x4*x6)+8*x5*(-2*x2*x3-x2*x4-x2*x10-x3*x9-x4*x9+2*x4*x8)
23973  fm(7,7)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+9*
23974  & x2*x10+7*x3*x7+2*x3*x6+2*x4*x7+7*x4*x6+x10*x5+2*x9*x7+7*
23975  & x9*x6+7*x8*x7+2*x8*x6)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2
23976  & *x4*x7-7*x4*x6)+4*x2*(x10*x5+2*x9*x7+7*x9*x6+7*x8*x7+2*x8
23977  & *x6)
23978  fm(7,8)=72*pq**4*x10+2*pq**2*ph**2*x10+4*pq**2*(2*x1*x10+
23979  & 10*x2*x10+7*x3*x9+2*x3*x8+14*x3*x7+4*x3*x6+2*x4*x9+7*x4*
23980  & x8+4*x4*x7+14*x4*x6+10*x10*x5+x9**2+7*x9*x8+2*x9*x7+7*x9*
23981  & x6+x8**2+7*x8*x7+2*x8*x6)+2*ph**2*(7*x1*x10-7*x3*x7-2*x3*
23982  & x6-2*x4*x7-7*x4*x6)+2*(-2*x1*x9**2-14*x1*x9*x8-2*x1*x8**2
23983  & +2*x2*x10*x5+2*x2*x9*x7+7*x2*x9*x6+7*x2*x8*x7+2*x2*x8*x6+
23984  & 7*x3*x9*x5+2*x3*x8*x5+2*x4*x9*x5+7*x4*x8*x5)
23985  fm(8,8)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+x2
23986  & *x10+7*x3*x9+2*x3*x8+7*x3*x7+2*x3*x6+2*x4*x9+7*x4*x8+2*x4
23987  & *x7+7*x4*x6+9*x10*x5)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2*
23988  & x4*x7-7*x4*x6)+4*x5*(x2*x10+7*x3*x9+2*x3*x8+2*x4*x9+7*x4*
23989  & x8)
23990  fm(9,9)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
23991  & x3*x7+x4*x6-x10*x5+x9*x6+x8*x7)+ph**2*(x1*x10-x3*x7-x4*x6
23992  & )+2*x2*(-x10*x5+x9*x6+x8*x7)
23993  fm(9,10)=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
23994  & x10+2*x3*x9+2*x3*x7+2*x4*x6-2*x10*x5+x9*x8+2*x8*x7)+ph**2
23995  & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x8*x7+x3*
23996  & x9*x5)
23997  fmxx=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
23998  & x10+2*x4*x8+2*x4*x6+2*x3*x7-2*x10*x5+x9*x8+2*x9*x6)+ph**2
23999  & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x9*x6+x4*
24000  & x8*x5)
24001  fm(9,10)=0.5d0*(fmxx+fm(9,10))
24002  fm(10,10)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
24003  & x3*x7+x4*x6-x10*x5+x9*x3+x8*x4)+ph**2*(x1*x10-x3*x7-x4*x6
24004  & )+2*x5*(-x10*x2+x9*x3+x8*x4)
24005 
24006 C...Repackage matrix elements.
24007  DO 200 i=1,8
24008  DO 190 j=1,8
24009  rm(i,j)=fm(i,j)
24010  190 CONTINUE
24011  200 CONTINUE
24012  rm(7,7)=fm(7,7)-2d0*fm(9,9)
24013  rm(7,8)=fm(7,8)-2d0*fm(9,10)
24014  rm(8,8)=fm(8,8)-2d0*fm(10,10)
24015 
24016 C...Produce final result: matrix elements * colours * propagators.
24017  DO 220 i=1,8
24018  DO 210 j=i,8
24019  fac=8d0
24020  IF(i.EQ.j)fac=4d0
24021  wtqqbh=wtqqbh+rm(i,j)*fac*clr(i,j)/(dx(i)*dx(j))
24022  210 CONTINUE
24023  220 CONTINUE
24024  wtqqbh=-wtqqbh/256d0
24025 
24026  ELSE
24027 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
24028  a11=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x2*x10+x3
24029  & *x7+x4*x6+x9*x6+x8*x7)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x2)*(x9
24030  & *x6+x8*x7)
24031  a12=-8d0*pq**4*x10+4d0*pq**2*(-x2*x10-x3*x9-2d0*x3*x7-x4*x8-
24032  & 2d0*x4*x6-x10*x5-x9*x8-x9*x6-x8*x7)+2d0*ph**2*(-x1*x10+x3*x7
24033  & +x4*x6)+2d0*(2d0*x1*x9*x8-x2*x9*x6-x2*x8*x7-x3*x9*x5-x4*x8*
24034  & x5)
24035  a22=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x3*x9+x3*
24036  & x7+x4*x8+x4*x6+x10*x5)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x5)*(x3
24037  & *x9+x4*x8)
24038 
24039 C...Produce final result: matrix elements * propagators.
24040  a11=a11/dx(7)**2
24041  a12=a12/(dx(7)*dx(8))
24042  a22=a22/dx(8)**2
24043  wtqqbh=-(a11+a22+2d0*a12)/8d0
24044  ENDIF
24045 
24046  RETURN
24047  END
24048 
24049 C*********************************************************************
24050 
24051 C...PYMSIN
24052 C...Initializes supersymmetry: finds sparticle masses and
24053 C...branching ratios and stores this information.
24054 C...AUTHOR: STEPHEN MRENNA
24055 
24056  SUBROUTINE pymsin
24057 
24058 C...Double precision and integer declarations.
24059  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24060  INTEGER pyk,pychge,pycomp
24061 C...Parameter statement to help give large particle numbers.
24062  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
24063 C...Commonblocks.
24064  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24065  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24066  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
24067  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24068  common/pyint4/mwid(500),wids(500,5)
24069  common/pymssm/imss(0:99),rmss(0:99)
24070  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
24071  &sfmix(16,4)
24072  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint4/,/pymssm/,
24073  &/pyssmt/
24074 
24075 C...Local variables.
24076  INTEGER nstr
24077  DOUBLE PRECISION alfa,beta
24078  DOUBLE PRECISION tanb,al,be,cosa,cosb,sina,sinb,xw,aem,fact
24079  DOUBLE PRECISION pyalem
24080  INTEGER i,j,j1,j2,i1,i2,i3,iknt,k1
24081  INTEGER kc,lknt,idlam(200,3),idlam0(100,3),lknt0
24082  DOUBLE PRECISION xlam(0:200),xlam0(0:200),xall
24083  DOUBLE PRECISION wdtp(0:200),wdte(0:200,0:5)
24084  DOUBLE PRECISION aterm,tan2t,theta,denom
24085  DOUBLE PRECISION xarg,cos2b,xmw2,xmz2
24086  DOUBLE PRECISION cosw,sinw,wdmin,wdmax
24087  DOUBLE PRECISION delm,xmdif,brlim
24088  DOUBLE PRECISION dx,dy,ds,dmu2,dma2,dq2,du2,dd2,dl2,de2,dhu2,dhd2
24089  DOUBLE PRECISION arg,sgnmu,r,gam
24090  INTEGER is1,is2,is3,is4,js1,js2,js3,js4,ks1,ks2,ks3,ks4
24091  INTEGER imssm,kfhigg
24092  INTEGER irprty
24093  INTEGER kfsusy(36)
24094  DATA kfsusy/
24095  &1000001,2000001,1000002,2000002,1000003,2000003,
24096  &1000004,2000004,1000005,2000005,1000006,2000006,
24097  &1000011,2000011,1000012,2000012,1000013,2000013,
24098  &1000014,2000014,1000015,2000015,1000016,2000016,
24099  &1000021,1000022,1000023,1000025,1000035,1000024,
24100  &1000037,1000039, 25, 35, 36, 37/
24101 
24102 C...Do nothing if SUSY not requested.
24103  imssm=imss(1)
24104  IF(imssm.EQ.0) RETURN
24105 
24106 C...First part of routine: set masses and couplings.
24107 
24108 C...Reset mixing values in sfermion sector to pure left/right.
24109  DO 100 i=1,16
24110  sfmix(i,1)=1d0
24111  sfmix(i,4)=1d0
24112  sfmix(i,2)=0d0
24113  sfmix(i,3)=0d0
24114  100 CONTINUE
24115 
24116 C...Common couplings.
24117  tanb=rmss(5)
24118  beta=atan(tanb)
24119  cosb=cos(beta)
24120  sinb=tanb*cosb
24121  cos2b=cos(2d0*beta)
24122  alfa=rmss(18)
24123  xmw2=pmas(24,1)**2
24124  xmz2=pmas(23,1)**2
24125  xw=paru(102)
24126 
24127 C...Define sparticle masses for a general MSSM simulation.
24128  IF(imssm.EQ.1) THEN
24129  IF(imss(9).EQ.0) rmss(22)=rmss(9)
24130  DO 110 i=1,5,2
24131  kc=pycomp(ksusy1+i)
24132  pmas(kc,1)=sqrt(rmss(8)**2-(2d0*xmw2+xmz2)*cos2b/6d0)
24133  kc=pycomp(ksusy2+i)
24134  pmas(kc,1)=sqrt(rmss(9)**2+(xmw2-xmz2)*cos2b/3d0)
24135  kc=pycomp(ksusy1+i+1)
24136  pmas(kc,1)=sqrt(rmss(8)**2+(4d0*xmw2-xmz2)*cos2b/6d0)
24137  kc=pycomp(ksusy2+i+1)
24138  pmas(kc,1)=sqrt(rmss(22)**2-(xmw2-xmz2)*cos2b*2d0/3d0)
24139  110 CONTINUE
24140  xarg=rmss(6)**2-pmas(24,1)**2*abs(cos(2d0*beta))
24141  IF(xarg.LT.0d0) THEN
24142  WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24143  & ' FROM THE SUM RULE. '
24144  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24145  RETURN
24146  ELSE
24147  xarg=sqrt(xarg)
24148  ENDIF
24149  DO 120 i=11,15,2
24150  pmas(pycomp(ksusy1+i),1)=rmss(6)
24151  pmas(pycomp(ksusy2+i),1)=rmss(7)
24152  pmas(pycomp(ksusy1+i+1),1)=xarg
24153  pmas(pycomp(ksusy2+i+1),1)=9999d0
24154  120 CONTINUE
24155  IF(imss(8).EQ.1) THEN
24156  rmss(13)=rmss(6)
24157  rmss(14)=rmss(7)
24158  ENDIF
24159 
24160 C...Alternatively derive masses from SUGRA relations.
24161  ELSEIF(imssm.EQ.2) THEN
24162  CALL pyapps
24163  ENDIF
24164 
24165 C...Add in extra D-term contributions.
24166  IF(imss(7).EQ.1) THEN
24167  r=0.43d0
24168  dx=rmss(23)
24169  dy=rmss(24)
24170  ds=rmss(25)
24171  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24172  WRITE(mstu(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
24173  WRITE(mstu(11),*) 'C IN A U(B-L) THEORY '
24174  WRITE(mstu(11),*) 'C DX = ',dx
24175  WRITE(mstu(11),*) 'C DY = ',dy
24176  WRITE(mstu(11),*) 'C DS = ',ds
24177  WRITE(mstu(11),*) 'C '
24178  dy=r*dy-4d0/33d0*(1d0-r)*dx+(1d0-r)/33d0*ds
24179  WRITE(mstu(11),*) 'C DY AT THE WEAK SCALE = ',dy
24180  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24181  dq2=dy/6d0-dx/3d0-ds/3d0
24182  du2=-2d0*dy/3d0-dx/3d0-ds/3d0
24183  dd2=dy/3d0+dx-2d0*ds/3d0
24184  dl2=-dy/2d0+dx-2d0*ds/3d0
24185  de2=dy-dx/3d0-ds/3d0
24186  dhu2=dy/2d0+2d0*dx/3d0+2d0*ds/3d0
24187  dhd2=-dy/2d0-2d0*dx/3d0+ds
24188  dmu2=(-dy/2d0-2d0/3d0*dx+(cosb**2-2d0*sinb**2/3d0)*ds)
24189  & /abs(cos2b)
24190  dma2 = 2d0*dmu2+dhu2+dhd2
24191  DO 130 i=1,5,2
24192  kc=pycomp(ksusy1+i)
24193  pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
24194  kc=pycomp(ksusy2+i)
24195  pmas(kc,1)=sqrt(pmas(kc,1)**2+dd2)
24196  kc=pycomp(ksusy1+i+1)
24197  pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
24198  kc=pycomp(ksusy2+i+1)
24199  pmas(kc,1)=sqrt(pmas(kc,1)**2+du2)
24200  130 CONTINUE
24201  DO 140 i=11,15,2
24202  kc=pycomp(ksusy1+i)
24203  pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
24204  kc=pycomp(ksusy2+i)
24205  pmas(kc,1)=sqrt(pmas(kc,1)**2+de2)
24206  kc=pycomp(ksusy1+i+1)
24207  pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
24208  140 CONTINUE
24209  IF(rmss(4)**2+dmu2.LT.0d0) THEN
24210  WRITE(mstu(11),*) ' MU2 DRIVEN NEGATIVE '
24211  stop
24212  ENDIF
24213  sgnmu=sign(1d0,rmss(4))
24214  rmss(4)=sgnmu*sqrt(rmss(4)**2+dmu2)
24215  arg=rmss(10)**2*sign(1d0,rmss(10))+dq2
24216  rmss(10)=sign(sqrt(abs(arg)),arg)
24217  arg=rmss(11)**2*sign(1d0,rmss(11))+dd2
24218  rmss(11)=sign(sqrt(abs(arg)),arg)
24219  arg=rmss(12)**2*sign(1d0,rmss(12))+du2
24220  rmss(12)=sign(sqrt(abs(arg)),arg)
24221  arg=rmss(13)**2*sign(1d0,rmss(13))+dl2
24222  rmss(13)=sign(sqrt(abs(arg)),arg)
24223  arg=rmss(14)**2*sign(1d0,rmss(14))+de2
24224  rmss(14)=sign(sqrt(abs(arg)),arg)
24225  IF( rmss(19)**2 + dma2 .LE. 50d0 ) THEN
24226  WRITE(mstu(11),*) ' MA DRIVEN TOO LOW '
24227  stop
24228  ENDIF
24229  rmss(19)=sqrt(rmss(19)**2+dma2)
24230  rmss(6)=sqrt(rmss(6)**2+dl2)
24231  rmss(7)=sqrt(rmss(7)**2+de2)
24232  WRITE(mstu(11),*) ' MTL = ',rmss(10)
24233  WRITE(mstu(11),*) ' MBR = ',rmss(11)
24234  WRITE(mstu(11),*) ' MTR = ',rmss(12)
24235  WRITE(mstu(11),*) ' SEL = ',rmss(6),rmss(13)
24236  WRITE(mstu(11),*) ' SER = ',rmss(7),rmss(14)
24237  ENDIF
24238 
24239 C...Fix the third generation sfermions.
24240  CALL pythrg
24241  xarg=rmss(13)**2-pmas(24,1)**2*abs(cos2b)
24242  IF(xarg.LT.0d0) THEN
24243  WRITE(mstu(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
24244  & ' THE SUM RULE. '
24245  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24246  RETURN
24247  ELSE
24248  pmas(pycomp(ksusy1+16),1)=sqrt(xarg)
24249  ENDIF
24250 
24251 C...Fix the neutralino--chargino--gluino sector.
24252  CALL pyinom
24253 
24254 C...Fix the Higgs sector.
24255  CALL pyhggm(alfa)
24256 
24257 C...Choose the Gunion-Haber convention.
24258  alfa=-alfa
24259  rmss(18)=alfa
24260 
24261 C...Print information on mass parameters.
24262  IF(imssm.EQ.2.AND.mstp(122).GT.0) THEN
24263  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24264  WRITE(mstu(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
24265  WRITE(mstu(11),*) ' M0 = ',rmss(8)
24266  WRITE(mstu(11),*) ' M1/2=',rmss(1)
24267  WRITE(mstu(11),*) ' TANB=',rmss(5)
24268  WRITE(mstu(11),*) ' MU = ',rmss(4)
24269  WRITE(mstu(11),*) ' AT = ',rmss(16)
24270  WRITE(mstu(11),*) ' MA = ',rmss(19)
24271  WRITE(mstu(11),*) ' MTOP=',pmas(6,1)
24272  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24273  ENDIF
24274  IF(imss(20).EQ.1) THEN
24275  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24276  WRITE(mstu(11),*) ' DEBUG MODE '
24277  WRITE(mstu(11),*) ' UMIX = ',umix(1,1),umix(1,2),
24278  & umix(2,1),umix(2,2)
24279  WRITE(mstu(11),*) ' VMIX = ',vmix(1,1),vmix(1,2),
24280  & vmix(2,1),vmix(2,2)
24281  WRITE(mstu(11),*) ' ZMIX = ',zmix
24282  WRITE(mstu(11),*) ' ALFA = ',alfa
24283  WRITE(mstu(11),*) ' BETA = ',beta
24284  WRITE(mstu(11),*) ' STOP = ',(sfmix(6,i),i=1,4)
24285  WRITE(mstu(11),*) ' SBOT = ',(sfmix(5,i),i=1,4)
24286  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24287  ENDIF
24288 
24289 C...Set up the Higgs couplings - needed here since initialization
24290 C...in PYINRE did not yet occur when PYWIDT is called below.
24291  al=alfa
24292  be=beta
24293  sina=sin(al)
24294  cosa=cos(al)
24295  cosb=cos(be)
24296  sinb=tanb*cosb
24297 C...tanb (used for H+)
24298  paru(141)=tanb
24299 
24300 C...Firstly: h
24301 C...Coupling to d-type quarks
24302  paru(161)=sina/cosb
24303 C...Coupling to u-type quarks
24304  paru(162)=-cosa/sinb
24305 C...Coupling to leptons
24306  paru(163)=paru(161)
24307 C...Coupling to Z
24308  paru(164)=sin(be-al)
24309 C...Coupling to W
24310  paru(165)=paru(164)
24311 C...Coupling to H+
24312  paru(168)=-sin(be-al)-cos(2d0*be)*sin(be+al)/2d0/(1d0-xw)
24313 
24314 C...Secondly: H
24315 C...Coupling to d-type quarks
24316  paru(171)=-cosa/cosb
24317 C...Coupling to u-type quarks
24318  paru(172)=-sina/sinb
24319 C...Coupling to leptons
24320  paru(173)=paru(171)
24321 C...Coupling to Z
24322  paru(174)=cos(be-al)
24323 C...Coupling to W
24324  paru(175)=paru(174)
24325 C...Coupling to h
24326  paru(176)=cos(2d0*al)*cos(be+al)-2d0*sin(2d0*al)*sin(be+al)
24327 C...Coupling to A
24328  paru(177)=cos(2d0*be)*cos(be+al)
24329 C...Coupling to H+
24330  paru(178)=-cos(be-al)+cos(2d0*be)*cos(be+al)/2d0/(1d0-xw)
24331 
24332 C...Thirdly, A
24333 C...Coupling to d-type quarks
24334  paru(181)=tanb
24335 C...Coupling to u-type quarks
24336  paru(182)=1d0/paru(181)
24337 C...Coupling to leptons
24338  paru(183)=paru(181)
24339  paru(184)=0d0
24340  paru(185)=0d0
24341 C...Coupling to Z h
24342  paru(186)=cos(be-al)
24343 C...Coupling to Z H
24344  paru(187)=sin(be-al)
24345  paru(188)=0d0
24346  paru(189)=0d0
24347  paru(190)=0d0
24348 
24349 C...Finally: H+
24350 C...Coupling to W h
24351  paru(195)=cos(be-al)
24352 
24353 C...Tell that all Higgs couplings have been set.
24354  mstp(4)=1
24355 
24356 C...Second part of routine: set decay modes and branching ratios.
24357 
24358 C...Allow chi10 -> gravitino + gamma or not.
24359  kc=pycomp(ksusy1+39)
24360  IF( imss(11) .NE. 0 ) THEN
24361  pmas(kc,1)=rmss(21)/1000000000d0
24362  pmas(kc,2)=0.0001d0
24363  irprty=0
24364  WRITE(mstu(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
24365  ELSE
24366  pmas(kc,1)=9999d0
24367  irprty=1
24368  ENDIF
24369 
24370 C...Loop over sparticle and Higgs species.
24371  pmchi1=pmas(pycomp(ksusy1+22),1)
24372  DO 200 i=1,36
24373  kf=kfsusy(i)
24374  kc=pycomp(kf)
24375  lknt=0
24376 
24377 C...Sfermion decays.
24378  IF(i.LE.24) THEN
24379 C...First check to see if sneutrino is lighter than chi10.
24380  IF((i.EQ.15.OR.i.EQ.19.OR.i.EQ.23).AND.
24381  & pmas(kc,1).LT.pmchi1) THEN
24382  ELSE
24383  CALL pysfdc(kf,xlam,idlam,lknt)
24384  ENDIF
24385 
24386 C...Gluino decays.
24387  ELSEIF(i.EQ.25) THEN
24388  CALL pyglui(kf,xlam,idlam,lknt)
24389 
24390 C...Neutralino decays.
24391  ELSEIF(i.GE.26.AND.i.LE.29) THEN
24392  CALL pynjdc(kf,xlam,idlam,lknt)
24393 C...chi10 stable or chi10 -> gravitino + gamma.
24394  IF(i.EQ.26.AND.irprty.EQ.1) THEN
24395  pmas(kc,2)=1d-6
24396  mdcy(kc,1)=0
24397  mwid(kc)=0
24398  ENDIF
24399 
24400 C...Chargino decays.
24401  ELSEIF(i.GE.30.AND.i.LE.31) THEN
24402  CALL pycjdc(kf,xlam,idlam,lknt)
24403 
24404 C...Gravitino is stable.
24405  ELSEIF(i.EQ.32) THEN
24406  mdcy(kc,1)=0
24407  mwid(kc)=0
24408 
24409 C...Higgs decays.
24410  ELSEIF(i.GE.33.AND.i.LE.36) THEN
24411 C...Calculate decays to non-SUSY particles.
24412  CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
24413  lknt=0
24414  DO 150 i1=0,100
24415  xlam(i1)=0d0
24416  150 CONTINUE
24417  DO 170 i1=1,mdcy(kc,3)
24418  k1=mdcy(kc,2)+i1-1
24419  IF(iabs(kfdp(k1,1)).GT.ksusy1.OR.
24420  & iabs(kfdp(k1,2)).GT.ksusy1) goto 170
24421  xlam(i1)=wdtp(i1)
24422  xlam(0)=xlam(0)+xlam(i1)
24423  DO 160 j1=1,3
24424  idlam(i1,j1)=kfdp(k1,j1)
24425  160 CONTINUE
24426  lknt=lknt+1
24427  170 CONTINUE
24428 C...Add the decays to SUSY particles.
24429  CALL pyhext(kf,xlam,idlam,lknt)
24430  ENDIF
24431 
24432 C...Set stable particles.
24433  IF(lknt.EQ.0) THEN
24434  mdcy(kc,1)=0
24435  mwid(kc)=0
24436  pmas(kc,2)=1d-6
24437  pmas(kc,3)=1d-5
24438  pmas(kc,4)=0d0
24439 
24440 C...Store branching ratios in the standard tables.
24441  ELSE
24442  idc=mdcy(kc,2)+mdcy(kc,3)-1
24443  delm=1d6
24444  DO 190 il=1,lknt
24445  idcsv=idc
24446  180 idc=idc+1
24447  IF(idc.EQ.mdcy(kc,2)+mdcy(kc,3)) idc=mdcy(kc,2)
24448  IF(idlam(il,1).EQ.kfdp(idc,1).AND.idlam(il,2).EQ.
24449  & kfdp(idc,2).AND.idlam(il,3).EQ.kfdp(idc,3)) THEN
24450  brat(idc)=xlam(il)/xlam(0)
24451  xmdif=pmas(kc,1)
24452  IF(mdme(idc,1).GE.1) THEN
24453  xmdif=xmdif-pmas(pycomp(kfdp(idc,1)),1)-
24454  & pmas(pycomp(kfdp(idc,2)),1)
24455  IF(kfdp(idc,3).NE.0) xmdif=xmdif-
24456  & pmas(pycomp(kfdp(idc,3)),1)
24457  ENDIF
24458  IF(i.LE.32) THEN
24459  IF(xmdif.GE.0d0) THEN
24460  delm=min(delm,xmdif)
24461  ELSE
24462  WRITE(mstu(11),*) ' ERROR WITH DELM ',delm,xmdif
24463  WRITE(mstu(11),*) ' KF = ',kf
24464  WRITE(mstu(11),*) ' KF(decay) = ',(kfdp(idc,j),j=1,3)
24465  ENDIF
24466  ENDIF
24467  goto 190
24468  ELSEIF(idc.EQ.idcsv) THEN
24469  WRITE(mstu(11),*) ' Error in PYMSIN: SUSY decay ',
24470  & 'channel not recognized:'
24471  WRITE(mstu(11),*) kf,' -> ',(idlam(i,j),j=1,3)
24472  goto 190
24473  ELSE
24474  goto 180
24475  ENDIF
24476  190 CONTINUE
24477 
24478 C...Store width, cutoff and lifetime.
24479  pmas(kc,2)=xlam(0)
24480  IF(pmas(kc,2).LT.0.1d0*delm) THEN
24481  pmas(kc,3)=pmas(kc,2)*10d0
24482  ELSE
24483  pmas(kc,3)=0.95d0*delm
24484  ENDIF
24485  IF(pmas(kc,2).NE.0d0) THEN
24486  pmas(kc,4)=paru(3)/pmas(kc,2)*1d-12
24487  ENDIF
24488  ENDIF
24489  200 CONTINUE
24490 
24491  RETURN
24492  END
24493 
24494 C*********************************************************************
24495 
24496 C...PYAPPS
24497 C...Uses approximate analytical formulae to determine the full set of
24498 C...MSSM parameters from SUGRA input.
24499 C...See M. Drees and S.P. Martin, hep-ph/9504124
24500 
24501  SUBROUTINE pyapps
24502 
24503 C...Double precision and integer declarations.
24504  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24505  INTEGER pyk,pychge,pycomp
24506 C...Parameter statement to help give large particle numbers.
24507  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
24508 C...Commonblocks.
24509  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24510  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24511  common/pymssm/imss(0:99),rmss(0:99)
24512  SAVE /pydat1/,/pydat2/,/pymssm/
24513 
24514  xmt=pmas(6,1)
24515  xmz2=pmas(23,1)**2
24516  xmw2=pmas(24,1)**2
24517  tanb=rmss(5)
24518  beta=atan(tanb)
24519  xw=paru(102)
24520  xmg=rmss(1)
24521  xmg2=xmg*xmg
24522  xm0=rmss(8)
24523  xm02=xm0*xm0
24524  at=rmss(16)
24525  rmss(15)=at
24526  rmss(17)=at
24527  cosb=cos(beta)
24528  sinb=tanb*cosb
24529 
24530  dterm=xmz2*cos(2d0*beta)
24531  xmer=sqrt(xm02+0.15d0*xmg2-xw*dterm)
24532  xmel=sqrt(xm02+0.52d0*xmg2-(0.5d0-xw)*dterm)
24533  rmss(6)=xmel
24534  rmss(7)=xmer
24535  xmur=sqrt(pyrnmq(2,2d0/3d0*xw*dterm))
24536  xmdr=sqrt(pyrnmq(3,-1d0/3d0*xw*dterm))
24537  xmul=sqrt(pyrnmq(1,(0.5d0-2d0/3d0*xw)*dterm))
24538  xmdl=sqrt(pyrnmq(1,-(0.5d0-1d0/3d0*xw)*dterm))
24539  DO 100 i=1,5,2
24540  pmas(pycomp(ksusy1+i),1)=xmdl
24541  pmas(pycomp(ksusy2+i),1)=xmdr
24542  pmas(pycomp(ksusy1+i+1),1)=xmul
24543  pmas(pycomp(ksusy2+i+1),1)=xmur
24544  100 CONTINUE
24545  xarg=xmel**2-xmw2*abs(cos(2d0*beta))
24546  IF(xarg.LT.0d0) THEN
24547  WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24548  & ' FROM THE SUM RULE. '
24549  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24550  RETURN
24551  ELSE
24552  xarg=sqrt(xarg)
24553  ENDIF
24554  DO 110 i=11,15,2
24555  pmas(pycomp(ksusy1+i),1)=xmel
24556  pmas(pycomp(ksusy2+i),1)=xmer
24557  pmas(pycomp(ksusy1+i+1),1)=xarg
24558  pmas(pycomp(ksusy2+i+1),1)=9999d0
24559  110 CONTINUE
24560  xmnu=xarg
24561 
24562  rmt=pyrnmt(xmt)
24563  xtop=(rmt/150d0/sinb)**2*(.9d0*xm02+2.1d0*xmg2+
24564  &(1d0-(rmt/190d0/sinb)**3)*(.24d0*at**2+at*xmg))
24565  rmb=3d0
24566  xbot=(rmb/150d0/cosb)**2*(.9d0*xm02+2.1d0*xmg2+
24567  &(1d0-(rmb/190d0/cosb)**3)*(.24d0*at**2+at*xmg))
24568  xtau=1d-4/cosb**2*(xm02+0.15d0*xmg2+at**2/3d0)
24569  atp=at*(1d0-(rmt/190d0/sinb)**2)+xmg*(3.47d0-1.9d0*(rmt/190d0/
24570  &sinb)**2)
24571  rmss(16)=atp
24572  xmu2=-xm02-0.52d0*xmg2-0.5d0*xmz2+xtop/(1d0-1d0/tanb**2)
24573  xma2=(xmnu**2+xmu2-xbot-xtau/3d0)/sinb**2
24574  xmu=sign(sqrt(xmu2),rmss(4))
24575  rmss(4)=xmu
24576  rmss(19)=sqrt(xma2)
24577  arg=xm02+0.15d0*xmg2-2d0*xtau/3d0-xw*dterm
24578  IF(arg.GT.0d0) THEN
24579  rmss(14)=sqrt(arg)
24580  ELSE
24581  WRITE(mstu(11),*) ' RIGHT STAU MASS < 0 '
24582  stop
24583  ENDIF
24584  arg=xm02+0.52d0*xmg2-xtau/3d0-(0.5d0-xw)*dterm
24585  IF(arg.GT.0d0) THEN
24586  rmss(13)=sqrt(arg)
24587  ELSE
24588  WRITE(mstu(11),*) ' LEFT STAU MASS < 0 '
24589  stop
24590  ENDIF
24591  arg=pyrnmq(1,-(xbot+xtop)/3d0)
24592  IF(arg.GT.0d0) THEN
24593  rmss(10)=sqrt(arg)
24594  ELSE
24595  rmss(10)=-sqrt(-arg)
24596  ENDIF
24597  arg=pyrnmq(2,-2d0*xtop/3d0)
24598  IF(arg.GT.0d0) THEN
24599  rmss(12)=sqrt(arg)
24600  ELSE
24601  rmss(12)=-sqrt(-arg)
24602  ENDIF
24603  arg=pyrnmq(3,-2d0*xbot/3d0)
24604  IF(arg.GT.0d0) THEN
24605  rmss(11)=sqrt(arg)
24606  ELSE
24607  rmss(11)=-sqrt(-arg)
24608  ENDIF
24609 
24610  RETURN
24611  END
24612 
24613 C*********************************************************************
24614 
24615 C...PYRNMQ
24616 C...Determines the running mass of quarks.
24617 
24618  FUNCTION pyrnmq(ID,DTERM)
24619 
24620 C...Double precision and integer declarations.
24621  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24622  INTEGER pyk,pychge,pycomp
24623 C...Commonblock.
24624  common/pymssm/imss(0:99),rmss(0:99)
24625  SAVE /pymssm/
24626 
24627 C...Local variables.
24628  DOUBLE PRECISION pi,r
24629  DOUBLE PRECISION tol
24630  DOUBLE PRECISION ci(3)
24631  EXTERNAL pyalps
24632  DATA tol/0.001d0/
24633  DATA pi,r/3.141592654d0,.61803399d0/
24634  DATA ci/0.47d0,0.07d0,0.02d0/
24635 
24636  c=1d0-r
24637  ca=ci(id)
24638  ag=(0.71d0)**2/4d0/pi
24639  ag=rmss(20)
24640  xm0=rmss(8)
24641  xmg=rmss(1)
24642  xm02=xm0*xm0
24643  xmg2=xmg*xmg
24644 
24645  as=pyalps(xm02+6d0*xmg2)
24646  cg=8d0/9d0*((as/ag)**2-1d0)
24647  bx=xm02+(ca+cg)*xmg2+dterm
24648  ax=min(50d0**2,0.5d0*bx)
24649  cx=max(2000d0**2,2d0*bx)
24650 
24651  x0=ax
24652  x3=cx
24653  IF(abs(cx-bx).GT.abs(bx-ax))THEN
24654  x1=bx
24655  x2=bx+c*(cx-bx)
24656  ELSE
24657  x2=bx
24658  x1=bx-c*(bx-ax)
24659  ENDIF
24660  as1=pyalps(x1)
24661  cg=8d0/9d0*((as1/ag)**2-1d0)
24662  f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
24663  as2=pyalps(x2)
24664  cg=8d0/9d0*((as2/ag)**2-1d0)
24665  f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
24666  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
24667  IF(f2.LT.f1) THEN
24668  x0=x1
24669  x1=x2
24670  x2=r*x1+c*x3
24671  f1=f2
24672  as2=pyalps(x2)
24673  cg=8d0/9d0*((as2/ag)**2-1d0)
24674  f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
24675  ELSE
24676  x3=x2
24677  x2=x1
24678  x1=r*x2+c*x0
24679  f2=f1
24680  as1=pyalps(x1)
24681  cg=8d0/9d0*((as1/ag)**2-1d0)
24682  f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
24683  ENDIF
24684  goto 100
24685  ENDIF
24686  IF(f1.LT.f2) THEN
24687  pyrnmq=x1
24688  xmin=x1
24689  ELSE
24690  pyrnmq=x2
24691  xmin=x2
24692  ENDIF
24693 
24694  RETURN
24695  END
24696 
24697 C*********************************************************************
24698 
24699 C...PYRNMT
24700 C...Determines the running mass of the top quark.
24701 
24702  FUNCTION pyrnmt(XMT)
24703 
24704 C...Double precision and integer declarations.
24705  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24706  INTEGER pyk,pychge,pycomp
24707 C...Commonblock.
24708  common/pymssm/imss(0:99),rmss(0:99)
24709  SAVE /pymssm/
24710 
24711 C...Local variables.
24712  DOUBLE PRECISION xmt
24713  DOUBLE PRECISION pi,r
24714  DOUBLE PRECISION tol
24715  EXTERNAL pyalps
24716  DATA tol/0.001d0/
24717  DATA pi,r/3.141592654d0,0.61803399d0/
24718 
24719  c=1d0-r
24720 
24721  bx=xmt
24722  ax=min(50d0,bx*0.5d0)
24723  cx=max(300d0,2d0*bx)
24724 
24725  x0=ax
24726  x3=cx
24727  IF(abs(cx-bx).GT.abs(bx-ax))THEN
24728  x1=bx
24729  x2=bx+c*(cx-bx)
24730  ELSE
24731  x2=bx
24732  x1=bx-c*(bx-ax)
24733  ENDIF
24734  as1=pyalps(x1**2)/pi
24735  f1=abs(xmt/(1d0+4d0/3d0*as1+11d0*as1**2)-x1)
24736  as2=pyalps(x2**2)/pi
24737  f2=abs(xmt/(1d0+4d0/3d0*as2+11d0*as2**2)-x2)
24738  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
24739  IF(f2.LT.f1) THEN
24740  x0=x1
24741  x1=x2
24742  x2=r*x1+c*x3
24743  f1=f2
24744  as2=pyalps(x2**2)/pi
24745  f2=abs(xmt/(1d0+4d0/3d0*as2+11d0*as2**2)-x2)
24746  ELSE
24747  x3=x2
24748  x2=x1
24749  x1=r*x2+c*x0
24750  f2=f1
24751  as1=pyalps(x1**2)/pi
24752  f1=abs(xmt/(1d0+4d0/3d0*as1+11d0*as1**2)-x1)
24753  ENDIF
24754  goto 100
24755  ENDIF
24756  IF(f1.LT.f2) THEN
24757  pyrnmt=x1
24758  xmin=x1
24759  ELSE
24760  pyrnmt=x2
24761  xmin=x2
24762  ENDIF
24763 
24764  RETURN
24765  END
24766 
24767 C*********************************************************************
24768 
24769 C...PYTHRG
24770 C...Calculates the mass eigenstates of the third generation sfermions.
24771 C...Created: 5-31-96
24772 
24773  SUBROUTINE pythrg
24774 
24775 C...Double precision and integer declarations.
24776  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24777  INTEGER pyk,pychge,pycomp
24778 C...Parameter statement to help give large particle numbers.
24779  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
24780 C...Commonblocks.
24781  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24782  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24783  common/pymssm/imss(0:99),rmss(0:99)
24784  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
24785  &sfmix(16,4)
24786  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
24787 
24788 C...Local variables.
24789  DOUBLE PRECISION beta
24790  DOUBLE PRECISION pyrnmt
24791  DOUBLE PRECISION am2(2,2),rt(2,2),di(2,2)
24792  DOUBLE PRECISION xmz2,xmw2,tanb,xmu,cos2b,xmql2,xmqr2
24793  DOUBLE PRECISION xmf,xmf2,diff,same,xmf12,xmf22,small
24794  DOUBLE PRECISION sin2t,cos2t,twot,atr,amqr,xxx,yyy,amql
24795  INTEGER id1(3),id2(3),id3(3),id4(3)
24796  INTEGER if,i,j,ii,jj,it,l
24797  LOGICAL dterm
24798  DATA small/1d-3/
24799  DATA id1/10,10,13/
24800  DATA id2/5,6,15/
24801  DATA id3/15,16,17/
24802  DATA id4/11,12,14/
24803  DATA dterm/.true./
24804 
24805  xmz2=pmas(23,1)**2
24806  xmw2=pmas(24,1)**2
24807  tanb=rmss(5)
24808  xmu=-rmss(4)
24809  beta=atan(tanb)
24810  cos2b=cos(2d0*beta)
24811 
24812 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
24813 
24814  iopt=imss(5)
24815  IF(iopt.EQ.1) THEN
24816  ctt=rmss(27)
24817  ctt2=ctt**2
24818  stt2=1d0-ctt2
24819  stt=sqrt(stt2)
24820  xm12=rmss(12)**2
24821  xm22=rmss(10)**2
24822  xmql2=ctt2*xm12+stt2*xm22
24823  xmqr2=stt2*xm12+ctt2*xm22
24824  xmfr=pmas(6,1)
24825  xmf2=pyrnmt(xmfr)**2
24826  atop=-xmu/tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
24827  atmt=sqrt(xmf2)*(atop+xmu/tanb)
24828  xtest=(xmql2-xmqr2)*(ctt2-stt2)
24829  IF(xtest.GT.4d0*stt*ctt*atmt) THEN
24830  stt=-stt
24831  atop=-xmu/tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
24832  ENDIF
24833  rmss(16)=atop
24834 C......SUBTRACT OUT D-TERM AND FERMION MASS
24835  xmql2=xmql2-xmf2-(4d0*xmw2-xmz2)*cos2b/6d0
24836  xmqr2=xmqr2-xmf2+(xmw2-xmz2)*cos2b*2d0/3d0
24837  IF(xmql2.GE.0d0) THEN
24838  rmss(10)=sqrt(xmql2)
24839  ELSE
24840  rmss(10)=-sqrt(-xmql2)
24841  ENDIF
24842  IF(xmqr2.GE.0d0) THEN
24843  rmss(12)=sqrt(xmqr2)
24844  ELSE
24845  rmss(12)=-sqrt(-xmqr2)
24846  ENDIF
24847 C SAME FOR SBOTTOM SQUARK
24848  ctt=rmss(26)
24849  ctt2=ctt**2
24850  stt2=1d0-ctt2
24851  stt=max(sqrt(stt2),1d-6)
24852  xmf=3d00
24853  xmf2=xmf**2
24854  xm12=rmss(11)**2
24855  xmql2=rmss(10)**2-(2d0*xmw2+xmz2)*cos2b/6d0+xmf2
24856  IF(abs(ctt).EQ.1d0) THEN
24857  xm22=xm12
24858  xm12=xmql2
24859  xmqr2=xm22
24860  ELSEIF(ctt.EQ.0d0) THEN
24861  xm22=xmql2
24862  xmqr2=xm12
24863  ELSE
24864  xm22=(xmql2-ctt2*xm12)/stt2
24865  xmqr2=stt2*xm12+ctt2*xm22
24866  ENDIF
24867  abot=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
24868  atmt=sqrt(xmf2)*(abot+xmu*tanb)
24869  xtest=(xmql2-xmqr2)*(ctt2-stt2)
24870  IF(xtest.GT.4d0*stt*ctt*atmt) THEN
24871  stt=-stt
24872  abot=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)
24873  ENDIF
24874  rmss(15)=abot
24875 C......SUBTRACT OUT D-TERM AND FERMION MASS
24876  xmqr2=xmqr2-(xmw2-xmz2)*cos2b/3d0-xmf2
24877  IF(xmqr2.GE.0d0) THEN
24878  rmss(11)=sqrt(xmqr2)
24879  ELSE
24880  rmss(11)=-sqrt(-xmqr2)
24881  ENDIF
24882  ENDIF
24883 
24884  DO 170 l=1,3
24885  amql=rmss(id1(l))
24886  IF(amql.LT.0d0) THEN
24887  xmql2=-amql**2
24888  ELSE
24889  xmql2=amql**2
24890  ENDIF
24891  if=id2(l)
24892  xmf=pmas(IF,1)
24893  IF(l.EQ.1) xmf=3d0
24894  IF(l.EQ.2) xmf=pyrnmt(xmf)
24895  xmf2=xmf**2
24896  atr=rmss(id3(l))
24897  amqr=rmss(id4(l))
24898  IF(amqr.LT.0d0) THEN
24899  xmqr2=-amqr**2
24900  ELSE
24901  xmqr2=amqr**2
24902  ENDIF
24903  am2(1,1)=xmql2+xmf2
24904  am2(2,2)=xmqr2+xmf2
24905  IF(dterm) THEN
24906  IF(l.EQ.1) THEN
24907  am2(1,1)=am2(1,1)-(2d0*xmw2+xmz2)*cos2b/6d0
24908  am2(2,2)=am2(2,2)+(xmw2-xmz2)*cos2b/3d0
24909  am2(1,2)=xmf*(atr+xmu*tanb)
24910  ELSEIF(l.EQ.2) THEN
24911  am2(1,1)=am2(1,1)+(4d0*xmw2-xmz2)*cos2b/6d0
24912  am2(2,2)=am2(2,2)-(xmw2-xmz2)*cos2b*2d0/3d0
24913  am2(1,2)=xmf*(atr+xmu/tanb)
24914  ELSEIF(l.EQ.3) THEN
24915  IF(imss(8).EQ.1) THEN
24916  am2(1,1)=rmss(6)**2
24917  am2(2,2)=rmss(7)**2
24918  am2(1,2)=0d0
24919  rmss(13)=rmss(6)
24920  rmss(14)=rmss(7)
24921  ELSE
24922  am2(1,2)=xmf*(atr+xmu*tanb)
24923  ENDIF
24924  ENDIF
24925  ENDIF
24926  am2(2,1)=am2(1,2)
24927  same=0.5d0*(am2(1,1)+am2(2,2))
24928  diff=0.5d0*sqrt((am2(1,1)-am2(2,2))**2+4d0*am2(1,2)*am2(2,1))
24929  xmf12=same-diff
24930  xmf22=same+diff
24931  IF(xmf12.LT.0d0) THEN
24932  WRITE(mstu(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
24933  stop
24934  ENDIF
24935  it=0
24936  IF(xmf22-xmf12.GT.0d0) THEN
24937  rt(1,1) = sqrt((xmf22-am2(1,1))/(xmf22-xmf12))
24938  rt(2,2) = rt(1,1)
24939  rt(1,2) = -sign(sqrt(1d0-rt(1,1)**2),am2(1,2)/(xmf22-xmf12))
24940  rt(2,1) = -rt(1,2)
24941  ELSE
24942  rt(1,1) = 1d0
24943  rt(2,2) = rt(1,1)
24944  rt(1,2) = 0d0
24945  rt(2,1) = -rt(1,2)
24946  ENDIF
24947  100 CONTINUE
24948  it=it+1
24949 
24950  DO 140 i=1,2
24951  DO 130 jj=1,2
24952  di(i,jj)=0d0
24953  DO 120 ii=1,2
24954  DO 110 j=1,2
24955  di(i,jj)=di(i,jj)+rt(i,j)*am2(j,ii)*rt(jj,ii)
24956  110 CONTINUE
24957  120 CONTINUE
24958  130 CONTINUE
24959  140 CONTINUE
24960 
24961  IF(di(1,1).GT.di(2,2)) THEN
24962  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION '
24963  WRITE(mstu(11),*) l,sqrt(xmf12),sqrt(xmf22)
24964  WRITE(mstu(11),*) am2
24965  WRITE(mstu(11),*) di
24966  WRITE(mstu(11),*) rt
24967  di(1,1)=-rt(2,1)
24968  di(2,2)=rt(1,2)
24969  di(1,2)=-rt(2,2)
24970  di(2,1)=rt(1,1)
24971  DO 160 i=1,2
24972  DO 150 j=1,2
24973  rt(i,j)=di(i,j)
24974  150 CONTINUE
24975  160 CONTINUE
24976  goto 100
24977  ELSEIF(abs(di(1,2)*di(2,1)/di(1,1)/di(2,2)).GT.small) THEN
24978  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
24979  & ' OFF DIAGONAL ELEMENTS '
24980  WRITE(mstu(11),*) 'MASSES = ',l,sqrt(xmf12),sqrt(xmf22)
24981  WRITE(mstu(11),*) di
24982  WRITE(mstu(11),*) ' ROTATION = ',rt
24983 C...STOP
24984  ELSEIF(di(1,1).LT.0d0.OR.di(2,2).LT.0d0) THEN
24985  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
24986  & ' NEGATIVE MASSES '
24987  stop
24988  ENDIF
24989  pmas(pycomp(ksusy1+if),1)=sqrt(xmf12)
24990  pmas(pycomp(ksusy2+if),1)=sqrt(xmf22)
24991  sfmix(IF,1)=rt(1,1)
24992  sfmix(IF,2)=rt(1,2)
24993  sfmix(IF,3)=rt(2,1)
24994  sfmix(IF,4)=rt(2,2)
24995  170 CONTINUE
24996 
24997  RETURN
24998  END
24999 
25000 C*********************************************************************
25001 
25002 C...PYINOM
25003 C...Finds the mass eigenstates and mixing matrices for neutralinos
25004 C...and charginos.
25005 
25006  SUBROUTINE pyinom
25007 
25008 C...Double precision and integer declarations.
25009  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25010  INTEGER pyk,pychge,pycomp
25011 C...Parameter statement to help give large particle numbers.
25012  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
25013 C...Commonblocks.
25014  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25015  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
25016  common/pymssm/imss(0:99),rmss(0:99)
25017  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
25018  &sfmix(16,4)
25019  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
25020 
25021 C...Local variables.
25022  DOUBLE PRECISION xmw,xmz
25023  DOUBLE PRECISION ar(4,4),wr(4),zr(4,4)
25024  DOUBLE PRECISION zp(4,4)
25025  DOUBLE PRECISION detx,xi(2,2)
25026  DOUBLE PRECISION xxx,yyy,xmh,xml
25027  DOUBLE PRECISION cosw,sinw
25028  DOUBLE PRECISION xmu
25029  DOUBLE PRECISION termb,termc,discr,xmh2,xml2
25030  DOUBLE PRECISION tanb,al,be,cosa,cosb,sina,sinb,xw
25031  DOUBLE PRECISION xm1,xm2,xm3,beta
25032  DOUBLE PRECISION q2,aem,a1,a2,a3,aq,rm1,rm2
25033  DOUBLE PRECISION arg,x0,x1,ax0,ax1,at,bt
25034  DOUBLE PRECISION y0,y1,amgx0,am1x0,amgx1,am1x1
25035  DOUBLE PRECISION argx0,ar1x0,argx1,ar1x1
25036  DOUBLE PRECISION pyalps,pyalem
25037  DOUBLE PRECISION pyrnm3
25038  INTEGER ierr,index(4),i,j,k,l,iopt,ilr,kfnchi(4)
25039  DATA kfnchi/1000022,1000023,1000025,1000035/
25040 
25041  iopt=imss(2)
25042  IF(imss(1).EQ.2) THEN
25043  iopt=1
25044  ENDIF
25045 C...M1, M2, AND M3 ARE INDEPENDENT
25046  IF(iopt.EQ.0) THEN
25047  xm1=rmss(1)
25048  xm2=rmss(2)
25049  xm3=rmss(3)
25050  ELSEIF(iopt.GE.1) THEN
25051  q2=pmas(23,1)**2
25052  aem=pyalem(q2)
25053  a2=aem/paru(102)
25054  a1=aem/(1d0-paru(102))
25055  xm1=rmss(1)
25056  xm2=rmss(2)
25057  IF(imss(1).EQ.2) xm1=rmss(1)/rmss(20)*a1*5d0/3d0
25058  IF(iopt.EQ.1) THEN
25059  xm2=xm1*a2/a1*3d0/5d0
25060  ELSEIF(iopt.EQ.3) THEN
25061  xm1=xm2*5d0/3d0*a1/a2
25062  ENDIF
25063  xm3=pyrnm3(xm2/a2)
25064  IF(xm3.LE.0d0) THEN
25065  WRITE(mstu(11),*) ' ERROR WITH M3 = ',xm3
25066  stop
25067  ENDIF
25068  ENDIF
25069 
25070 C...GLUINO MASS
25071  IF(imss(3).EQ.1) THEN
25072  pmas(pycomp(ksusy1+21),1)=xm3
25073  ELSE
25074  aq=0d0
25075  DO 110 i=1,4
25076  DO 100 ilr=1,2
25077  rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
25078  aq=aq+0.5d0*((2d0-rm1)*(rm1*log(rm1)-1d0)
25079  & +(1d0-rm1)**2*log(abs(1d0-rm1)))
25080  100 CONTINUE
25081  110 CONTINUE
25082 
25083  DO 130 i=5,6
25084  DO 120 ilr=1,2
25085  rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
25086  rm2=pmas(i,1)**2/xm3**2
25087  arg=(rm1-rm2-1d0)**2-4d0*rm2**2
25088  IF(arg.GE.0d0) THEN
25089  x0=0.5d0*(1d0+rm2-rm1-sqrt(arg))
25090  ax0=abs(x0)
25091  x1=0.5d0*(1d0+rm2-rm1+sqrt(arg))
25092  ax1=abs(x1)
25093  IF(x0.EQ.1d0) THEN
25094  at=-1d0
25095  bt=0.25d0
25096  ELSEIF(x0.EQ.0d0) THEN
25097  at=0d0
25098  bt=-0.25d0
25099  ELSE
25100  at=0.5d0*log(abs(1d0-x0))*(1d0-x0**2)+
25101  & 0.5d0*x0**2*log(ax0)
25102  bt=(-1d0-2d0*x0)/4d0
25103  ENDIF
25104  IF(x1.EQ.1d0) THEN
25105  at=-1d0+at
25106  bt=0.25d0+bt
25107  ELSEIF(x1.EQ.0d0) THEN
25108  at=0d0+at
25109  bt=-0.25d0+bt
25110  ELSE
25111  at=0.5d0*log(abs(1d0-x1))*(1d0-x1**2)+0.5d0*
25112  & x1**2*log(ax1)+at
25113  bt=(-1d0-2d0*x1)/4d0+bt
25114  ENDIF
25115  aq=aq+at+bt
25116  ELSE
25117  x0=0.5d0*(1d0+rm2-rm1)
25118  y0=-0.5d0*sqrt(-arg)
25119  amgx0=sqrt(x0**2+y0**2)
25120  am1x0=sqrt((1d0-x0)**2+y0**2)
25121  argx0=atan2(-x0,-y0)
25122  ar1x0=atan2(1d0-x0,y0)
25123  x1=x0
25124  y1=-y0
25125  amgx1=amgx0
25126  am1x1=am1x0
25127  argx1=atan2(-x1,-y1)
25128  ar1x1=atan2(1d0-x1,y1)
25129  at=0.5d0*log(am1x0)*(1d0-x0**2+3d0*y0**2)
25130  & +0.5d0*(x0**2-y0**2)*log(amgx0)
25131  bt=(-1d0-2d0*x0)/4d0+x0*y0*( ar1x0-argx0 )
25132  at=at+0.5d0*log(am1x1)*(1d0-x1**2+3d0*y1**2)
25133  & +0.5d0*(x1**2-y1**2)*log(amgx1)
25134  bt=bt+(-1d0-2d0*x1)/4d0+x1*y1*( ar1x1-argx1 )
25135  aq=aq+at+bt
25136  ENDIF
25137  120 CONTINUE
25138  130 CONTINUE
25139  pmas(pycomp(ksusy1+21),1)=xm3*(1d0+pyalps(xm3**2)/(2d0*paru(2))*
25140  & (15d0+aq))
25141  ENDIF
25142 
25143 C...NEUTRALINO MASSES
25144  xmz=pmas(23,1)
25145  xmw=pmas(24,1)
25146  xmu=rmss(4)
25147  sinw=sqrt(paru(102))
25148  cosw=sqrt(1d0-paru(102))
25149  tanb=rmss(5)
25150  beta=atan(tanb)
25151  cosb=cos(beta)
25152  sinb=tanb*cosb
25153  ar(1,1) = xm1
25154  ar(2,2) = xm2
25155  ar(3,3) = 0d0
25156  ar(4,4) = 0d0
25157  ar(1,2) = 0d0
25158  ar(2,1) = 0d0
25159  ar(1,3) = -xmz*sinw*cosb
25160  ar(3,1) = ar(1,3)
25161  ar(1,4) = xmz*sinw*sinb
25162  ar(4,1) = ar(1,4)
25163  ar(2,3) = xmz*cosw*cosb
25164  ar(3,2) = ar(2,3)
25165  ar(2,4) = -xmz*cosw*sinb
25166  ar(4,2) = ar(2,4)
25167  ar(3,4) = -xmu
25168  ar(4,3) = -xmu
25169  CALL pyeig4(ar,wr,zr)
25170  DO 150 i=1,4
25171  smz(i)=wr(i)
25172  pmas(pycomp(kfnchi(i)),1)=abs(smz(i))
25173  DO 140 j=1,4
25174  zmix(i,j)=zr(i,j)
25175  IF(abs(zmix(i,j)).LT.1d-6) zmix(i,j)=0d0
25176  140 CONTINUE
25177  150 CONTINUE
25178 
25179 C...CHARGINO MASSES
25180  ar(1,1) = xm2
25181  ar(2,2) = xmu
25182  ar(1,2) = sqrt(2d0)*xmw*sinb
25183  ar(2,1) = sqrt(2d0)*xmw*cosb
25184  termb=ar(1,1)**2+ar(2,2)**2+ar(1,2)**2+ar(2,1)**2
25185  termc=(ar(1,1)**2-ar(2,2)**2)**2+(ar(1,2)**2-ar(2,1)**2)**2
25186  termc=termc+2d0*(ar(1,1)**2+ar(2,2)**2)*
25187  &(ar(1,2)**2+ar(2,1)**2)+
25188  &8d0*ar(1,1)*ar(2,2)*ar(1,2)*ar(2,1)
25189  discr=termc
25190  IF(discr.LT.0d0) THEN
25191  WRITE(mstu(11),*) ' PROBLEM WITH DISCR '
25192  ELSE
25193  discr=sqrt(discr)
25194  ENDIF
25195  xml2=0.5d0*(termb-discr)
25196  xmh2=0.5d0*(termb+discr)
25197  xml=sqrt(xml2)
25198  xmh=sqrt(xmh2)
25199  pmas(pycomp(ksusy1+24),1)=xml
25200  pmas(pycomp(ksusy1+37),1)=xmh
25201  smw(1)=xml
25202  smw(2)=xmh
25203  xxx=ar(1,1)**2+ar(2,1)**2
25204  yyy=ar(1,1)*ar(1,2)+ar(2,2)*ar(2,1)
25205  vmix(2,2) = yyy/sqrt(yyy**2+(xml2-xxx)**2)
25206  vmix(1,1) = sign(vmix(2,2),ar(1,1)*ar(2,2)-0.5d0*ar(1,2)**2)
25207  vmix(2,1) = -(xml2-xxx)/sqrt(yyy**2+(xml2-xxx)**2)
25208  vmix(1,2) = -sign(vmix(2,1),ar(1,1)*ar(2,2)-0.5d0*ar(1,2)**2)
25209  zr(1,1) = xml
25210  zr(1,2) = 0d0
25211  zr(2,1) = 0d0
25212  zr(2,2) = xmh
25213  detx = ar(1,1)*ar(2,2)-ar(1,2)*ar(2,1)
25214  xi(1,1) = ar(2,2)/detx
25215  xi(2,2) = ar(1,1)/detx
25216  xi(1,2) = -ar(1,2)/detx
25217  xi(2,1) = -ar(2,1)/detx
25218  DO 190 i=1,2
25219  DO 180 j=1,2
25220  umix(i,j)=0d0
25221  DO 170 k=1,2
25222  DO 160 l=1,2
25223  umix(i,j)=umix(i,j)+zr(i,k)*vmix(k,l)*xi(l,j)
25224  160 CONTINUE
25225  170 CONTINUE
25226  180 CONTINUE
25227  190 CONTINUE
25228 
25229  RETURN
25230  END
25231 
25232 C*********************************************************************
25233 
25234 C...PYRNM3
25235 C...Calculates the running of M3, the SU(3) gluino mass parameter.
25236 
25237  FUNCTION pyrnm3(RGUT)
25238 
25239 C...Double precision and integer declarations.
25240  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25241  INTEGER pyk,pychge,pycomp
25242 
25243 C...Local variables.
25244  DOUBLE PRECISION pi,r
25245  DOUBLE PRECISION tol
25246  EXTERNAL pyalps
25247  DATA tol/0.001d0/
25248  DATA pi,r/3.141592654d0,0.61803399d0/
25249 
25250  c=1d0-r
25251 
25252  bx=rgut*pyalps(rgut**2)
25253  ax=min(50d0,bx*0.5d0)
25254  cx=max(2000d0,2d0*bx)
25255 
25256  x0=ax
25257  x3=cx
25258  IF(abs(cx-bx).GT.abs(bx-ax))THEN
25259  x1=bx
25260  x2=bx+c*(cx-bx)
25261  ELSE
25262  x2=bx
25263  x1=bx-c*(bx-ax)
25264  ENDIF
25265  as1=pyalps(x1**2)
25266  f1=abs(x1-rgut*as1)
25267  as2=pyalps(x2**2)
25268  f2=abs(x2-rgut*as2)
25269  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
25270  IF(f2.LT.f1) THEN
25271  x0=x1
25272  x1=x2
25273  x2=r*x1+c*x3
25274  f1=f2
25275  as2=pyalps(x2**2)
25276  f2=abs(x2-rgut*as2)
25277  ELSE
25278  x3=x2
25279  x2=x1
25280  x1=r*x2+c*x0
25281  f2=f1
25282  as1=pyalps(x1**2)
25283  f1=abs(x1-rgut*as1)
25284  ENDIF
25285  goto 100
25286  ENDIF
25287  IF(f1.LT.f2) THEN
25288  pyrnm3=x1
25289  xmin=x1
25290  ELSE
25291  pyrnm3=x2
25292  xmin=x2
25293  ENDIF
25294 
25295  RETURN
25296  END
25297 
25298 C*********************************************************************
25299 
25300 C...PYEIG4
25301 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
25302 C...Specific application: mixing in neutralino sector.
25303 
25304  SUBROUTINE pyeig4(A,W,Z)
25305  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25306  INTEGER pyk,pychge,pycomp
25307 
25308 C...Arrays: in call and local.
25309  dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)
25310 
25311 C...Coefficients of fourth-degree equation from matrix.
25312 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
25313  b3=-(a(1,1)+a(2,2)+a(3,3)+a(4,4))
25314  b2=0d0
25315  DO 110 i=1,3
25316  DO 100 j=i+1,4
25317  b2=b2+a(i,i)*a(j,j)-a(i,j)*a(j,i)
25318  100 CONTINUE
25319  110 CONTINUE
25320  b1=0d0
25321  b0=0d0
25322  DO 120 i=1,4
25323  i1=mod(i,4)+1
25324  i2=mod(i+1,4)+1
25325  i3=mod(i+2,4)+1
25326  b1=b1+a(i,i)*(-a(i1,i1)*a(i2,i2)+a(i1,i2)*a(i2,i1)+
25327  & a(i1,i3)*a(i3,i1)+a(i2,i3)*a(i3,i2))-
25328  & a(i,i1)*a(i1,i2)*a(i2,i)-a(i,i2)*a(i2,i1)*a(i1,i)
25329  b0=b0+(-1d0)**(i+1)*a(1,i)*(
25330  & a(2,i1)*(a(3,i2)*a(4,i3)-a(3,i3)*a(4,i2))+
25331  & a(2,i2)*(a(3,i3)*a(4,i1)-a(3,i1)*a(4,i3))+
25332  & a(2,i3)*(a(3,i1)*a(4,i2)-a(3,i2)*a(4,i1)))
25333  120 CONTINUE
25334 
25335 C...Coefficients of third-degree equation needed for
25336 C...separation into two second-degree equations.
25337 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
25338  c2=-b2
25339  c1=b1*b3-4d0*b0
25340  c0=-b1**2-b0*b3**2+4d0*b0*b2
25341  cq=c1/3d0-c2**2/9d0
25342  cr=c1*c2/6d0-c0/2d0-c2**3/27d0
25343  cqr=cq**3+cr**2
25344 
25345 C...Cases with one or three real roots.
25346  IF(cqr.GE.0d0) THEN
25347  s1=(cr+sqrt(cqr))**(1d0/3d0)
25348  s2=(cr-sqrt(cqr))**(1d0/3d0)
25349  u=s1+s2-c2/3d0
25350  ELSE
25351  sabs=sqrt(-cq)
25352 C THE=ASIN(SQRT(CQR/CQ**3))/3D0
25353  the=acos(cr/sabs**3)/3d0
25354  sre=sabs*cos(the)
25355  u=2d0*sre-c2/3d0
25356  ENDIF
25357 
25358 C...Find and solve two second-degree equations.
25359  p1=b3/2d0-sqrt(b3**2/4d0+u-b2)
25360  p2=b3/2d0+sqrt(b3**2/4d0+u-b2)
25361  q1=u/2d0+sqrt(u**2/4d0-b0)
25362  q2=u/2d0-sqrt(u**2/4d0-b0)
25363  x(1)=-p1/2d0+sqrt(p1**2/4d0-q1)
25364  x(2)=-p1/2d0-sqrt(p1**2/4d0-q1)
25365  x(3)=-p2/2d0+sqrt(p2**2/4d0-q2)
25366  x(4)=-p2/2d0-sqrt(p2**2/4d0-q2)
25367 
25368 C...Order eigenvalues in asceding mass.
25369  w(1)=x(1)
25370  DO 150 i1=2,4
25371  DO 130 i2=i1-1,1,-1
25372  IF(abs(x(i1)).GE.abs(w(i2))) goto 140
25373  w(i2+1)=w(i2)
25374  130 CONTINUE
25375  140 w(i2+1)=x(i1)
25376  150 CONTINUE
25377 
25378 C...Find equation system for eigenvectors.
25379  DO 250 i=1,4
25380  DO 170 j1=1,4
25381  d(j1,j1)=a(j1,j1)-w(i)
25382  DO 160 j2=j1+1,4
25383  d(j1,j2)=a(j1,j2)
25384  d(j2,j1)=a(j2,j1)
25385  160 CONTINUE
25386  170 CONTINUE
25387 
25388 C...Find largest element in matrix.
25389  damax=0d0
25390  DO 190 j1=1,4
25391  DO 180 j2=1,4
25392  IF(abs(d(j1,j2)).LE.damax) goto 180
25393  ja=j1
25394  jb=j2
25395  damax=abs(d(j1,j2))
25396  180 CONTINUE
25397  190 CONTINUE
25398 
25399 C...Subtract others by multiple of row selected above.
25400  damax=0d0
25401  DO 210 j3=ja+1,ja+3
25402  j1=j3-4*((j3-1)/4)
25403  rl=d(j1,jb)/d(ja,jb)
25404  DO 200 j2=1,4
25405  d(j1,j2)=d(j1,j2)-rl*d(ja,j2)
25406  IF(abs(d(j1,j2)).LE.damax) goto 200
25407  jc=j1
25408  jd=j2
25409  damax=abs(d(j1,j2))
25410  200 CONTINUE
25411  210 CONTINUE
25412 
25413 C...Do one more subtraction of a row.
25414  damax=0d0
25415  DO 230 j3=jc+1,jc+3
25416  j1=j3-4*((j3-1)/4)
25417  IF(j1.EQ.ja) goto 230
25418  rl=d(j1,jd)/d(jc,jd)
25419  DO 220 j2=1,4
25420  IF(j2.EQ.jb) goto 220
25421  d(j1,j2)=d(j1,j2)-rl*d(jc,j2)
25422  IF(abs(d(j1,j2)).LE.damax) goto 220
25423  je=j1
25424  damax=abs(d(j1,j2))
25425  220 CONTINUE
25426  230 CONTINUE
25427 
25428 C...Construct unnormalized eigenvector.
25429  jf1=jd+1-4*(jd/4)
25430  jf2=jd+2-4*((jd+1)/4)
25431  IF(jf1.EQ.jb) jf1=jd+3-4*((jd+2)/4)
25432  IF(jf2.EQ.jb) jf2=jd+3-4*((jd+2)/4)
25433  e(jf1)=-d(je,jf2)
25434  e(jf2)=d(je,jf1)
25435  e(jd)=-(d(jc,jf1)*e(jf1)+d(jc,jf2)*e(jf2))/d(jc,jd)
25436  e(jb)=-(d(ja,jf1)*e(jf1)+d(ja,jf2)*e(jf2)+d(ja,jd)*e(jd))/
25437  & d(ja,jb)
25438 
25439 C...Normalize and fill in final array.
25440  ea=sqrt(e(1)**2+e(2)**2+e(3)**2+e(4)**2)
25441  sgn=(-1d0)**int(pyr(0)+0.5d0)
25442  DO 240 j=1,4
25443  z(i,j)=sgn*e(j)/ea
25444  240 CONTINUE
25445  250 CONTINUE
25446 
25447  RETURN
25448  END
25449 
25450 C*********************************************************************
25451 
25452 C...PYHGGM
25453 C...Determines the Higgs boson mass spectrum using several inputs.
25454 
25455  SUBROUTINE pyhggm(ALPHA)
25456 
25457 C...Double precision and integer declarations.
25458  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25459  INTEGER pyk,pychge,pycomp
25460 C...Parameter statement to help give large particle numbers.
25461  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
25462 C...Commonblocks.
25463  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25464  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
25465  common/pypars/mstp(200),parp(200),msti(200),pari(200)
25466  common/pymssm/imss(0:99),rmss(0:99)
25467  SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/
25468 
25469 C...Local variables.
25470  DOUBLE PRECISION at,ab,xmu,tanb,xm32,xmt2
25471  DOUBLE PRECISION alpha
25472  INTEGER i,j,ihopt,ii,jj,it
25473  DOUBLE PRECISION dma,dtanb,dmq,dmur,dmtop,dau,dad
25474  DOUBLE PRECISION dmu,dmh,dhm,dmhch,dsa,dca,dtanba
25475  DOUBLE PRECISION dmc,dmdr,dmhp,dhmp,damp
25476  DOUBLE PRECISION dstop1,dstop2,dsbot1,dsbot2
25477 
25478  ihopt=imss(4)
25479  IF(ihopt.EQ.2) THEN
25480  alpha=rmss(18)
25481  RETURN
25482  ENDIF
25483  at=rmss(16)
25484  ab=rmss(15)
25485  xmu=rmss(4)
25486  tanb=rmss(5)
25487 
25488  dma=rmss(19)
25489  dtanb=tanb
25490  dmq=rmss(10)
25491  dmur=rmss(12)
25492  dmdr=rmss(11)
25493  dmtop=pmas(6,1)
25494  dmc=pmas(pycomp(ksusy1+37),1)
25495  dau=at
25496  dad=ab
25497  dmu=xmu
25498 
25499  IF(ihopt.EQ.0) THEN
25500  CALL pysubh(dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
25501  & dmhch,dsa,dca,dtanba)
25502  ELSEIF(ihopt.EQ.1) THEN
25503  CALL pysubh(dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
25504  & dmhch,dsa,dca,dtanba)
25505  CALL pypole(3,dmc,dma,dtanb,dmq,dmur,dmdr,dmtop,dau,dad,dmu,
25506  & dmh,dmhp,dhm,dhmp,damp,dsa,dca,
25507  & dstop1,dstop2,dsbot1,dsbot2,dtanba)
25508  dmh=dmhp
25509  dhm=dhmp
25510  dma=damp
25511  ENDIF
25512 
25513  alpha=acos(dca)
25514 
25515  pmas(25,1)=dmh
25516  pmas(35,1)=dhm
25517  pmas(36,1)=dma
25518  pmas(37,1)=dmhch
25519 
25520  RETURN
25521  END
25522 
25523 C*********************************************************************
25524 
25525 C...PYSUBH
25526 C...This routine computes the renormalization group improved
25527 C...values of Higgs masses and couplings in the MSSM.
25528 
25529 C...Program based on the work by M. Carena, J.R. Espinosa,
25530 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
25531 
25532 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
25533 C...All masses in GeV units. MA is the CP-odd Higgs mass,
25534 C...MTOP is the physical top mass, MQ and MUR are the soft
25535 C...supersymmetry breaking mass parameters of left handed
25536 C...and right handed stops respectively, AU and AD are the
25537 C...stop and sbottom trilinear soft breaking terms,
25538 C...respectively, and MU is the supersymmetric
25539 C...Higgs mass parameter. We use the conventions from
25540 C...the physics report of Haber and Kane: left right
25541 C...stop mixing term proportional to (AU - MU/TANB)
25542 C...We use as input TANB defined at the scale MTOP
25543 
25544 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
25545 C...where MH and HM are the lightest and heaviest CP-even
25546 C...Higgs masses, MHCH is the charged Higgs mass and
25547 C...ALPHA is the Higgs mixing angle
25548 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
25549 
25550 C...Range of validity:
25551 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
25552 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
25553 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
25554 C...are the sbottom mass eigenvalues, respectively. This
25555 C...range automatically excludes the existence of tachyons.
25556 C...For the charged Higgs mass computation, the method is
25557 C...valid if
25558 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
25559 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
25560 C...where M_SUSY**2 is the average of the squared stop mass
25561 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
25562 C...masses have been assumed to be of order of the stop ones
25563 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
25564 
25565  SUBROUTINE pysubh (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
25566  &xmhch,sa,ca,tanba)
25567 
25568 C...Double precision and integer declarations.
25569  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25570  INTEGER pyk,pychge,pycomp
25571 C...Parameter statement to help give large particle numbers.
25572  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
25573 C...Commonblocks.
25574  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25575  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
25576  SAVE /pydat1/,/pydat2/
25577 
25578 C...Local variables.
25579  DOUBLE PRECISION pyalem,pyalps
25580  DOUBLE PRECISION tanb,xmq,xmur,xmtop,au,ad,xmu,xmh,xhm
25581  DOUBLE PRECISION xmhch,sa,ca
25582  DOUBLE PRECISION xma,aem,alp1,alp2,alph3z,v,pi
25583  DOUBLE PRECISION q02
25584  DOUBLE PRECISION tanba,tanbt,xmb,alp3
25585  DOUBLE PRECISION rmtop,xms,t,sinb,cosb
25586  DOUBLE PRECISION xlam1,xlam2,xlam3,xlam4,xlam5,xlam6
25587  DOUBLE PRECISION xlam7,xau,xad,g1,g2,g3,hu,hd,hu2
25588  DOUBLE PRECISION hd2,hu4,hd4,sinbt,cosbt
25589  DOUBLE PRECISION trm2,detm2,xmh2,xhm2,xmhch2
25590  DOUBLE PRECISION sinalp,cosalp,aud,pi2,xms2,xms4,ad2
25591  DOUBLE PRECISION cos2bt,au2,xmu2,xmz,xms3
25592 
25593  xmz = pmas(23,1)
25594  q02=xmz**2
25595  aem=pyalem(q02)
25596  alp1=aem/(1d0-paru(102))
25597  alp2=aem/paru(102)
25598  alph3z=pyalps(q02)
25599 
25600  alp1 = 0.0101d0
25601  alp2 = 0.0337d0
25602  alph3z = 0.12d0
25603 
25604  v = 174.1d0
25605  pi = paru(1)
25606  tanba = tanb
25607  tanbt = tanb
25608 
25609 C...MBOTTOM(MTOP) = 3. GEV
25610  xmb = 3d0
25611  alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*
25612  &log(xmtop**2/xmz**2))
25613 
25614 C...RMTOP= RUNNING TOP QUARK MASS
25615  rmtop = xmtop/(1d0+4d0*alp3/3d0/pi)
25616  xms = ((xmq**2 + xmur**2)/2d0 + xmtop**2)**0.5d0
25617  t = log(xms**2/xmtop**2)
25618  sinb = tanb/((1d0 + tanb**2)**0.5d0)
25619  cosb = sinb/tanb
25620 C...IF(MA.LE.XMTOP) TANBA = TANBT
25621  IF(xma.GT.xmtop)
25622  &tanba = tanbt*(1d0-3d0/32d0/pi**2*
25623  &(rmtop**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
25624  &log(xma**2/xmtop**2))
25625 
25626  sinbt = tanbt/sqrt(1d0 + tanbt**2)
25627  cosbt = 1d0/sqrt(1d0 + tanbt**2)
25628  cos2bt = (tanbt**2 - 1d0)/(tanbt**2 + 1d0)
25629  g1 = sqrt(alp1*4d0*pi)
25630  g2 = sqrt(alp2*4d0*pi)
25631  g3 = sqrt(alp3*4d0*pi)
25632  hu = rmtop/v/sinbt
25633  hd = xmb/v/cosbt
25634  hu2=hu*hu
25635  hd2=hd*hd
25636  hu4=hu2*hu2
25637  hd4=hd2*hd2
25638  au2=au**2
25639  ad2=ad**2
25640  xms2=xms**2
25641  xms3=xms**3
25642  xms4=xms2*xms2
25643  xmu2=xmu*xmu
25644  pi2=pi*pi
25645 
25646  xau = (2d0*au2/xms2)*(1d0 - au2/12d0/xms2)
25647  xad = (2d0*ad2/xms2)*(1d0 - ad2/12d0/xms2)
25648  aud = (-6d0*xmu2/xms2 - ( xmu2- ad*au)**2/xms4
25649  &+ 3d0*(au + ad)**2/xms2)/6d0
25650  xlam1 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hd2*t/8d0/pi2)
25651  &+(3d0*hd4/8d0/pi2) * (t + xad/2d0 + (3d0*hd2/2d0 + hu2/2d0
25652  &- 8d0*g3**2) * (xad*t + t**2)/16d0/pi2)
25653  &-(3d0*hu4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hu2 -5d0* hd2
25654  &- 16d0*g3**2) *t/16d0/pi2)
25655  xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu2*t/8d0/pi2)
25656  &+(3d0*hu4/8d0/pi2) * (t + xau/2d0 + (3d0*hu2/2d0 + hd2/2d0
25657  &- 8d0*g3**2) * (xau*t + t**2)/16d0/pi2)
25658  &-(3d0*hd4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hd2 -5d0* hu2
25659  &- 16d0*g3**2) *t/16d0/pi2)
25660  xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
25661  &(hu2 + hd2)*t/16d0/pi2)
25662  &+(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
25663  &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
25664  &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
25665  &xms4)* (1d0+ (6d0*hu2 -2d0* hd2/2d0
25666  &- 16d0*g3**2) *t/16d0/pi2)
25667  &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
25668  &xms4)*(1d0+ (6d0*hd2 -2d0* hu2
25669  &- 16d0*g3**2) *t/16d0/pi2)
25670  xlam4 = (- g2**2/2d0)*(1d0-3d0*(hu2 + hd2)*t/16d0/pi2)
25671  &-(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
25672  &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
25673  &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
25674  &xms4)*
25675  &(1+ (6d0*hu2 -2d0* hd2
25676  &- 16d0*g3**2) *t/16d0/pi2)
25677  &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
25678  &xms4)*
25679  &(1+ (6d0*hd2 -2d0* hu2/2d0
25680  &- 16d0*g3**2) *t/16d0/pi2)
25681  xlam5 = -(3d0*hu4* xmu2*au2/96d0/pi2/xms4) *
25682  &(1- (2d0*hd2 -6d0* hu2 + 16d0*g3**2) *t/16d0/pi2)
25683  &-(3d0*hd4* xmu2*ad2/96d0/pi2/xms4) *
25684  &(1- (2d0*hu2 -6d0* hd2 + 16d0*g3**2) *t/16d0/pi2)
25685  xlam6 = (3d0*hu4* xmu**3*au/96d0/pi2/xms4) *
25686  &(1- (7d0*hd2/2d0 -15d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
25687  &+(3d0*hd4* xmu *(ad**3/xms3 - 6d0*ad/xms )/96d0/pi2/xms) *
25688  &(1- (hu2/2d0 -9d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
25689  xlam7 = (3d0*hd4* xmu**3*ad/96d0/pi2/xms4) *
25690  &(1- (7d0*hu2/2d0 -15d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
25691  &+(3d0*hu4* xmu *(au**3/xms3 - 6d0*au/xms )/96d0/pi2/xms) *
25692  &(1- (hd2/2d0 -9d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
25693  trm2 = xma**2 + 2d0*v**2* (xlam1* cosbt**2 +
25694  &2d0* xlam6*sinbt*cosbt
25695  &+ xlam5*sinbt**2 + xlam2* sinbt**2 + 2d0* xlam7*sinbt*cosbt
25696  &+ xlam5*cosbt**2)
25697  detm2 = 4d0*v**4*(-(sinbt*cosbt*(xlam3 + xlam4) +
25698  &xlam6*cosbt**2
25699  &+ xlam7* sinbt**2)**2 + (xlam1* cosbt**2 +
25700  &2d0* xlam6* cosbt*sinbt
25701  &+ xlam5*sinbt**2)*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
25702  &+ xlam5*cosbt**2)) + xma**2*2d0*v**2 *
25703  &((xlam1* cosbt**2 +2d0*
25704  &xlam6* cosbt*sinbt + xlam5*sinbt**2)*cosbt**2 +
25705  &(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt + xlam5*cosbt**2)
25706  &*sinbt**2
25707  &+2d0*sinbt*cosbt* (sinbt*cosbt*(xlam3
25708  &+ xlam4) + xlam6*cosbt**2
25709  &+ xlam7* sinbt**2))
25710 
25711  xmh2 = (trm2 - sqrt(trm2**2 - 4d0* detm2))/2d0
25712  xhm2 = (trm2 + sqrt(trm2**2 - 4d0* detm2))/2d0
25713  xhm = sqrt(xhm2)
25714  xmh = sqrt(xmh2)
25715  xmhch2 = xma**2 + (xlam5 - xlam4)* v**2
25716  xmhch = sqrt(xmhch2)
25717 
25718  sinalp = sqrt(((trm2**2 - 4d0* detm2)**0.5d0) -
25719  &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
25720  &xlam6* cosbt*sinbt
25721  &+ xlam5*sinbt**2) + xma**2*sinbt**2)
25722  &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
25723  &+ xlam5*cosbt**2) + xma**2*cosbt**2)))/
25724  &sqrt(((trm2**2 - 4d0* detm2)**0.5d0))/2d0**0.5d0
25725 
25726  cosalp = (2d0*(2d0*v**2*(sinbt*cosbt*(xlam3 + xlam4) +
25727  &xlam6*cosbt**2 + xlam7* sinbt**2) -
25728  &xma**2*sinbt*cosbt))/2d0**0.5d0/
25729  &sqrt(((trm2**2 - 4d0* detm2)**0.5d0)*
25730  &(((trm2**2 - 4d0* detm2)**0.5d0) -
25731  &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
25732  &xlam6* cosbt*sinbt
25733  &+ xlam5*sinbt**2) + xma**2*sinbt**2)
25734  &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
25735  &+ xlam5*cosbt**2) + xma**2*cosbt**2))))
25736 
25737  sa = -sinalp
25738  ca = -cosalp
25739 
25740  100 CONTINUE
25741 
25742  RETURN
25743  END
25744 
25745 C*********************************************************************
25746 
25747 C...PYPOLE
25748 C...This subroutine computes the CP-even higgs and CP-odd pole
25749 c...Higgs masses and mixing angles.
25750 
25751 C...Program based on the work by M. Carena, M. Quiros
25752 C...and C.E.M. Wagner, "Effective potential methods and
25753 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
25754 
25755 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
25756 C...AT,AB,MU
25757 C...where MCHI is the largest chargino mass, MA is the running
25758 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
25759 C...expectaion values at the scale MTOP, MQ is the third generation
25760 C...left handed squark mass parameter, MUR is the third generation
25761 C...right handed stop mass parameter, MDR is the third generation
25762 C...right handed sbottom mass parameter, MTOP is the pole top quark
25763 C...mass; AT,AB are the soft supersymmetry breaking trilinear
25764 C...couplings of the stop and sbottoms, respectively, and MU is the
25765 C...supersymmetric mass parameter
25766 
25767 C...The parameter IHIGGS=0,1,2,3 corresponds to the
25768 c...number of Higgses whose pole mass is computed
25769 c...by the subroutine PYVACU(...). If IHIGGS=0 only running
25770 c...masses are given, what makes the running of the program
25771 c...much faster and it is quite generally a good approximation
25772 c...(for a theoretical discussion see ref. below).
25773 c...If IHIGGS=1, only the pole
25774 c...mass for H is computed. If IHIGGS=2, then h and H, and
25775 c...if IHIGGS=3, then h,H,A polarizations are computed
25776 
25777 C...Output: MH and MHP which are the lightest CP-even Higgs running
25778 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
25779 C...Higgs running and pole masses, repectively; SA and CA are the
25780 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
25781 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
25782 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
25783 C...the value of TANB at the CP-odd Higgs mass scale
25784 
25785 C...This subroutine makes use of CERN library subroutine
25786 C...integration package, which makes the computation of the
25787 C...pole Higgs masses somewhat faster. We thank P. Janot for this
25788 C...improvement. Those who are not able to call the CERN
25789 C...libraries, please use the subroutine SUBHPOLE2.F, which
25790 C...although somewhat slower, gives identical results
25791 
25792  SUBROUTINE pypole(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
25793  &xmh,xmhp,hm,hmp,amp,sa,ca,stop1,stop2,sbot1,sbot2,tanba)
25794 
25795 C...Double precision and integer declarations.
25796  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25797  INTEGER pyk,pychge,pycomp
25798 
25799  CALL pyvacu(ihiggs,xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,xmu,
25800  &xmh,xmhp,hm,hmp,amp,stop1,stop2,sbot1,sbot2,
25801  &sa,ca,stop1w,stop2w,tanba)
25802  sinb = tanb/(tanb**2+1d0)**0.5d0
25803  cosb = 1d0/(tanb**2+1d0)**0.5d0
25804  sinbma = sinb*ca - cosb*sa
25805 
25806  RETURN
25807  END
25808 
25809 C*********************************************************************
25810 
25811 C...PYVACU
25812 C...Computes Higgs masses and mixing angles, see PYPOLE above.
25813 
25814  SUBROUTINE pyvacu(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
25815  &xmt,at,ab,xmu,xmh,xmhp,hm,hmp,amp,stop1,stop2,
25816  &sbot1,sbot2,sa,ca,stop1w,stop2w,tanba)
25817 
25818 C...Double precision and integer declarations.
25819  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25820  INTEGER pyk,pychge,pycomp
25821 
25822 C...Local variables.
25823  dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),
25824  &ssbot2(2),b(2,2),coupb(2,2),
25825  &hcoupt(2,2),hcoupb(2,2),
25826  &acoupt(2,2),acoupb(2,2),pr(3), polar(3)
25827 
25828  delta(1,1) = 1d0
25829  delta(2,2) = 1d0
25830  delta(1,2) = 0d0
25831  delta(2,1) = 0d0
25832  v = 174.1d0
25833  xmz=91.18d0
25834  pi=3.14159d0
25835  alp3z=0.12d0
25836  alp3=1d0/(1d0/alp3z+23d0/6d0/pi*log(xmt/xmz))
25837 
25838  rxmt = xmt/(1d0+4*alp3/3d0/pi)
25839 
25840  ht = rxmt /v
25841  CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,
25842  &xmu,xmh,hm,sa,ca,tanba)
25843  sinb = tanb/(tanb**2+1d0)**0.5d0
25844  cosb = 1d0/(tanb**2+1d0)**0.5d0
25845  cos2b = sinb**2 - cosb**2
25846  sinbpa = sinb*ca + cosb*sa
25847  cosbpa = cosb*ca - sinb*sa
25848  rmbot = 3d0
25849  xmq2 = xmq**2
25850  xmur2 = xmur**2
25851  xmdr2 = xmdr**2
25852  xmst11 = rxmt**2 + xmq2 - 0.35d0*xmz**2*cos2b
25853  xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b
25854  IF(xmst11.LT.0d0) goto 500
25855  IF(xmst22.LT.0d0) goto 500
25856  xmsb11 = rmbot**2 + xmq2 + 0.42d0*xmz**2*cos2b
25857  xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b
25858  IF(xmsb11.LT.0d0) goto 500
25859  IF(xmsb22.LT.0d0) goto 500
25860  wmst11 = rxmt**2 + xmq2
25861  wmst22 = rxmt**2 + xmur2
25862  xmst12 = rxmt*(at - xmu/tanb)
25863  xmsb12 = rmbot*(ab - xmu*tanb)
25864 
25865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25866 C...STOP EIGENVALUES CALCULATION
25867 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25868 
25869  stop12 = 0.5d0*(xmst11+xmst22) +
25870  &0.5d0*((xmst11+xmst22)**2 -
25871  &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0
25872  stop22 = 0.5d0*(xmst11+xmst22) -
25873  &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -
25874  &xmst12**2))**0.5d0
25875  IF(stop22.LT.0d0) goto 500
25876  sstop2(1) = stop12
25877  sstop2(2) = stop22
25878  stop1 = stop12**0.5d0
25879  stop2 = stop22**0.5d0
25880  stop1w = stop1
25881  stop2w = stop2
25882 
25883  IF(xmst12.EQ.0d0) xst11 = 1d0
25884  IF(xmst12.EQ.0d0) xst12 = 0d0
25885  IF(xmst12.EQ.0d0) xst21 = 0d0
25886  IF(xmst12.EQ.0d0) xst22 = 1d0
25887 
25888  IF(xmst12.EQ.0d0) goto 110
25889 
25890  100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0
25891  xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0
25892  xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0
25893  xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0
25894 
25895  110 t(1,1) = xst11
25896  t(2,2) = xst22
25897  t(1,2) = xst12
25898  t(2,1) = xst21
25899 
25900  sbot12 = 0.5d0*(xmsb11+xmsb22) +
25901  &0.5d0*((xmsb11+xmsb22)**2 -
25902  &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0
25903  sbot22 = 0.5d0*(xmsb11+xmsb22) -
25904  &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -
25905  &xmsb12**2))**0.5d0
25906  IF(sbot22.LT.0d0) goto 500
25907  sbot1 = sbot12**0.5d0
25908  sbot2 = sbot22**0.5d0
25909  ssbot2(1) = sbot12
25910  ssbot2(2) = sbot22
25911 
25912  IF(xmsb12.EQ.0d0) xsb11 = 1d0
25913  IF(xmsb12.EQ.0d0) xsb12 = 0d0
25914  IF(xmsb12.EQ.0d0) xsb21 = 0d0
25915  IF(xmsb12.EQ.0d0) xsb22 = 1d0
25916 
25917  IF(xmsb12.EQ.0d0) goto 130
25918 
25919  120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
25920  xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
25921  xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
25922  xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
25923 
25924  130 b(1,1) = xsb11
25925  b(2,2) = xsb22
25926  b(1,2) = xsb12
25927  b(2,1) = xsb21
25928 
25929 
25930  sint = 0.2320d0
25931  sqr = 2d0**0.5d0
25932  vp = 174.1d0*sqr
25933 
25934 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25935 C...STARTING OF LIGHT HIGGS
25936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
25937 
25938  IF(ihiggs.EQ.0) goto 490
25939 
25940  DO 150 i = 1,2
25941  DO 140 j = 1,2
25942  coupt(i,j) =
25943  & sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +
25944  & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
25945  & -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)
25946  & -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +
25947  & t(1,j)*t(2,i))
25948  140 CONTINUE
25949  150 CONTINUE
25950 
25951 
25952  DO 170 i = 1,2
25953  DO 160 j = 1,2
25954  coupb(i,j) =
25955  & -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +
25956  & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
25957  & +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)
25958  & +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +
25959  & b(1,j)*b(2,i))
25960  160 CONTINUE
25961  170 CONTINUE
25962 
25963  prun = xmh
25964  eps = 1d-4*prun
25965  iter = 0
25966  180 iter = iter + 1
25967  DO 230 i3 = 1,3
25968 
25969  pr(i3)=prun+(i3-2)*eps/2
25970  p2=pr(i3)**2
25971  polt = 0d0
25972  DO 200 i = 1,2
25973  DO 190 j = 1,2
25974  polt = polt + coupt(i,j)**2*3d0*
25975  & pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2
25976  190 CONTINUE
25977  200 CONTINUE
25978  polb = 0d0
25979  DO 220 i = 1,2
25980  DO 210 j = 1,2
25981  polb = polb + coupb(i,j)**2*3d0*
25982  & pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2
25983  210 CONTINUE
25984  220 CONTINUE
25985  rxmt2 = rxmt**2
25986  xmt2=xmt**2
25987 
25988  poltt =
25989  & 3d0*rxmt**2/8d0/pi**2/ v **2*
25990  & ca**2/sinb**2 *
25991  & (-2d0*xmt**2+0.5d0*p2)*
25992  & pyfint(p2,xmt2,xmt2)
25993 
25994  pol = polt + polb + poltt
25995  polar(i3) = p2 - xmh**2 - pol
25996  230 CONTINUE
25997  deriv = (polar(3)-polar(1))/eps
25998  drun = - polar(2)/deriv
25999  prun = prun + drun
26000  p2 = prun**2
26001  IF( abs(drun) .LT. 1d-4 ) goto 240
26002  goto 180
26003  240 CONTINUE
26004 
26005  xmhp = p2**0.5d0
26006 
26007 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26008 C...END OF LIGHT HIGGS
26009 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26010 
26011  250 IF(ihiggs.EQ.1) goto 490
26012 
26013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26014 C... STARTING OF HEAVY HIGGS
26015 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26016 
26017  DO 270 i = 1,2
26018  DO 260 j = 1,2
26019  hcoupt(i,j) =
26020  & -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +
26021  & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
26022  & -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)
26023  & -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +
26024  & t(1,j)*t(2,i))
26025  260 CONTINUE
26026  270 CONTINUE
26027 
26028  DO 290 i = 1,2
26029  DO 280 j = 1,2
26030  hcoupb(i,j) =
26031  & sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +
26032  & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
26033  & -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)
26034  & -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +
26035  & b(1,j)*b(2,i))
26036  hcoupb(i,j)=0d0
26037  280 CONTINUE
26038  290 CONTINUE
26039 
26040  prun = hm
26041  eps = 1d-4*prun
26042  iter = 0
26043  300 iter = iter + 1
26044  DO 350 i3 = 1,3
26045  pr(i3)=prun+(i3-2)*eps/2
26046  hp2=pr(i3)**2
26047 
26048  hpolt = 0d0
26049  DO 320 i = 1,2
26050  DO 310 j = 1,2
26051  hpolt = hpolt + hcoupt(i,j)**2*3d0*
26052  & pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2
26053  310 CONTINUE
26054  320 CONTINUE
26055 
26056  hpolb = 0d0
26057  DO 340 i = 1,2
26058  DO 330 j = 1,2
26059  hpolb = hpolb + hcoupb(i,j)**2*3d0*
26060  & pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2
26061  330 CONTINUE
26062  340 CONTINUE
26063 
26064  rxmt2 = rxmt**2
26065  xmt2 = xmt**2
26066 
26067  hpoltt =
26068  & 3d0*rxmt**2/8d0/pi**2/ v **2*
26069  & sa**2/sinb**2 *
26070  & (-2d0*xmt**2+0.5d0*hp2)*
26071  & pyfint(hp2,xmt2,xmt2)
26072 
26073  hpol = hpolt + hpolb + hpoltt
26074  polar(i3) =hp2-hm**2-hpol
26075  350 CONTINUE
26076  deriv = (polar(3)-polar(1))/eps
26077  drun = - polar(2)/deriv
26078  prun = prun + drun
26079  hp2 = prun**2
26080  IF( abs(drun) .LT. 1d-4 ) goto 360
26081  goto 300
26082  360 CONTINUE
26083 
26084 
26085  370 CONTINUE
26086  hmp = hp2**0.5d0
26087 
26088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26089 C... END OF HEAVY HIGGS
26090 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26091 
26092  IF(ihiggs.EQ.2) goto 490
26093 
26094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26095 C...BEGINNING OF PSEUDOSCALAR HIGGS
26096 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26097 
26098  DO 390 i = 1,2
26099  DO 380 j = 1,2
26100  acoupt(i,j) =
26101  & -rxmt/vp/sinb*(at*cosb + xmu*sinb)*
26102  & (t(1,i)*t(2,j) -t(1,j)*t(2,i))
26103  380 CONTINUE
26104  390 CONTINUE
26105  DO 410 i = 1,2
26106  DO 400 j = 1,2
26107  acoupb(i,j) =
26108  & rmbot/vp/cosb*(ab*sinb + xmu*cosb)*
26109  & (b(1,i)*b(2,j) -b(1,j)*b(2,i))
26110  400 CONTINUE
26111  410 CONTINUE
26112 
26113  prun = xma
26114  eps = 1d-4*prun
26115  iter = 0
26116  420 iter = iter + 1
26117  DO 470 i3 = 1,3
26118  pr(i3)=prun+(i3-2)*eps/2
26119  ap2=pr(i3)**2
26120  apolt = 0d0
26121  DO 440 i = 1,2
26122  DO 430 j = 1,2
26123  apolt = apolt + acoupt(i,j)**2*3d0*
26124  & pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2
26125  430 CONTINUE
26126  440 CONTINUE
26127  apolb = 0d0
26128  DO 460 i = 1,2
26129  DO 450 j = 1,2
26130  apolb = apolb + acoupb(i,j)**2*3d0*
26131  & pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2
26132  450 CONTINUE
26133  460 CONTINUE
26134  rxmt2 = rxmt**2
26135  xmt2=xmt**2
26136  apoltt =
26137  & 3d0*rxmt**2/8d0/pi**2/ v **2*
26138  & cosb**2/sinb**2 *
26139  & (-0.5d0*ap2)*
26140  & pyfint(ap2,xmt2,xmt2)
26141  apol = apolt + apolb + apoltt
26142  polar(i3) = ap2 - xma**2 -apol
26143  470 CONTINUE
26144  deriv = (polar(3)-polar(1))/eps
26145  drun = - polar(2)/deriv
26146  prun = prun + drun
26147  ap2 = prun**2
26148  IF( abs(drun) .LT. 1d-4 ) goto 480
26149  goto 420
26150  480 CONTINUE
26151 
26152  amp = ap2**0.5d0
26153 
26154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26155 C...END OF PSEUDOSCALAR HIGGS
26156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26157 
26158  IF(ihiggs.EQ.3) goto 490
26159 
26160  490 CONTINUE
26161  RETURN
26162  500 CONTINUE
26163  stop
26164  END
26165 
26166 C*********************************************************************
26167 
26168 C...PYRGHM
26169 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26170 
26171  SUBROUTINE pyrghm(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
26172  &xmhp,hmp,sa,ca,tanba)
26173 
26174 C...Double precision and integer declarations.
26175  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26176  INTEGER pyk,pychge,pycomp
26177 
26178 C...Local variables.
26179  dimension vh(2,2),xm2(2,2),xm2p(2,2)
26180 
26181  xmz = 91.18d0
26182  alp1 = 0.0101d0
26183  alp2 = 0.0337d0
26184  alp3z = 0.12d0
26185  v = 174.1d0
26186  pi = 3.14159d0
26187  tanba = tanb
26188  tanbt = tanb
26189 
26190 C...MBOTTOM(XMT) = 3. GEV
26191  xmb = 3d0
26192  alp3 = alp3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alp3z*
26193  &log(xmt**2/xmz**2))
26194 
26195 C...RXMT= RUNNING TOP QUARK MASS
26196  rxmt = xmt/(1d0+4d0*alp3/3d0/pi)
26197  tq = log((xmq**2+xmt**2)/xmt**2)
26198  tu = log((xmur**2 + xmt**2)/xmt**2)
26199  td = log((xmdl**2 + xmt**2)/xmt**2)
26200  sinb = tanb/((1d0 + tanb**2)**0.5d0)
26201  cosb = sinb/tanb
26202  IF(xma.GT.xmt)
26203  &tanba = tanb*(1d0-3d0/32d0/pi**2*
26204  &(rxmt**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
26205  &log(xma**2/xmt**2))
26206  IF(xma.LT.xmt.OR.xma.EQ.xmt) tanbt = tanba
26207  sinb = tanbt/((1d0 + tanbt**2)**0.5d0)
26208  cosb = 1d0/((1d0 + tanbt**2)**0.5d0)
26209  cos2b = (tanbt**2 - 1d0)/(tanbt**2 + 1d0)
26210  g1 = (alp1*4d0*pi)**0.5d0
26211  g2 = (alp2*4d0*pi)**0.5d0
26212  g3 = (alp3*4d0*pi)**0.5d0
26213  hu = rxmt/v/sinb
26214  hd = xmb/v/cosb
26215 
26216  CALL pygfxx(xma,tanba,xmq,xmur,xmdl,xmt,au,ad,
26217  &xmu,vh,stop1,stop2)
26218 
26219  IF(xmq.GT.xmur) tp = tq - tu
26220  IF(xmq.LT.xmur.OR.xmq.EQ.xmur) tp = tu - tq
26221  IF(xmq.GT.xmur) tdp = tu
26222  IF(xmq.LT.xmur.OR.xmq.EQ.xmur) tdp = tq
26223  IF(xmq.GT.xmdl) tpd = tq - td
26224  IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) tpd = td - tq
26225  IF(xmq.GT.xmdl) tdpd = td
26226  IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) tdpd = tq
26227 
26228  IF(xmq.GT.xmdl) dlam1 = 6d0/96d0/pi**2*g1**2*hd**2*tpd
26229  IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) dlam1 = 3d0/32d0/pi**2*
26230  &hd**2*(g1**2/3d0+g2**2)*tpd
26231 
26232  IF(xmq.GT.xmur) dlam2 =12d0/96d0/pi**2*g1**2*hu**2*tp
26233  IF(xmq.LT.xmur.OR.xmq.EQ.xmur) dlam2 = 3d0/32d0/pi**2*
26234  &hu**2*(-g1**2/3d0+g2**2)*tp
26235 
26236  dlam3 = 0d0
26237  dlam4 = 0d0
26238 
26239  IF(xmq.GT.xmdl) dlam3 = -1d0/32d0/pi**2*g1**2*hd**2*tpd
26240  IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) dlam3 = 3d0/64d0/pi**2*hd**2*
26241  &(g2**2-g1**2/3d0)*tpd
26242 
26243  IF(xmq.GT.xmur) dlam3 = dlam3 -
26244  &1d0/16d0/pi**2*g1**2*hu**2*tp
26245  IF(xmq.LT.xmur.OR.xmq.EQ.xmur) dlam3 = dlam3 +
26246  &3d0/64d0/pi**2*hu**2*(g2**2+g1**2/3d0)*tp
26247 
26248  IF(xmq.LT.xmur) dlam4 = -3d0/32d0/pi**2*g2**2*hu**2*tp
26249  IF(xmq.LT.xmdl) dlam4 = dlam4 - 3d0/32d0/pi**2*g2**2*
26250  &hd**2*tpd
26251 
26252  xlam1 = ((g1**2 + g2**2)/4d0)*
26253  &(1d0-3d0*hd**2*(tpd + tdpd)/8d0/pi**2)
26254  &+(3d0*hd**4/16d0/pi**2) *tpd*(1d0
26255  &+ (3d0*hd**2/2d0 + hu**2/2d0
26256  &- 8d0*g3**2) * (tpd + 2d0*tdpd)/16d0/pi**2)
26257  &+(3d0*hd**4/8d0/pi**2) *tdpd*(1d0 + (3d0*hd**2/2d0 + hu**2/2d0
26258  &- 8d0*g3**2) * tdpd/16d0/pi**2) + dlam1
26259  xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu**2*
26260  &(tp + tdp)/8d0/pi**2)
26261  &+(3d0*hu**4/16d0/pi**2) *tp*(1d0
26262  &+ (3d0*hu**2/2d0 + hd**2/2d0
26263  &- 8d0*g3**2) * (tp + 2d0*tdp)/16d0/pi**2)
26264  &+(3d0*hu**4/8d0/pi**2) *tdp*(1d0 + (3d0*hu**2/2d0 + hd**2/2d0
26265  &- 8d0*g3**2) * tdp/16d0/pi**2) + dlam2
26266  xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
26267  &(hu**2)*(tp + tdp)/16d0/pi**2 -3d0*
26268  &(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlam3
26269  xlam4 = (- g2**2/2d0)*(1d0
26270  &-3d0*(hu**2)*(tp + tdp)/16d0/pi**2
26271  &-3d0*(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlam4
26272 
26273  xlam5 = 0d0
26274  xlam6 = 0d0
26275  xlam7 = 0d0
26276 
26277  xm2(1,1) = 2d0*v**2*(xlam1*cosb**2+2d0*xlam6*
26278  &cosb*sinb + xlam5*sinb**2) + xma**2*sinb**2
26279 
26280  xm2(2,2) = 2d0*v**2*(xlam5*cosb**2+2d0*xlam7*
26281  &cosb*sinb + xlam2*sinb**2) + xma**2*cosb**2
26282  xm2(1,2) = 2d0*v**2*(xlam6*cosb**2+(xlam3+xlam4)*
26283  &cosb*sinb + xlam7*sinb**2) - xma**2*sinb*cosb
26284 
26285  xm2(2,1) = xm2(1,2)
26286 
26287 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26288 C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
26289 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26290 
26291  xmssu=(0.5d0*(xmq**2+xmur**2)+xmt**2)**0.5d0
26292 
26293  IF(xmc.GT.xmssu) goto 100
26294  IF(xmc.LT.xmt) xmc=xmt
26295 
26296  tchar=log(xmssu**2/xmc**2)
26297 
26298  del12=(9d0/64d0/pi**2*g2**4+5d0/192d0/pi**2*g1**4)*tchar
26299  del3p4=(3d0/64d0/pi**2*g2**4+7d0/192d0/pi**2*g1**4
26300  &+4d0/32/pi**2*g1**2*g2**2)*tchar
26301 
26302  dem112=2d0*del12*v**2*cosb**2
26303  dem222=2d0*del12*v**2*sinb**2
26304  dem122=2d0*del3p4*v**2*sinb*cosb
26305 
26306  xm2(1,1)=xm2(1,1)+dem112
26307  xm2(2,2)=xm2(2,2)+dem222
26308  xm2(1,2)=xm2(1,2)+dem122
26309  xm2(2,1)=xm2(2,1)+dem122
26310 
26311  100 CONTINUE
26312 
26313 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26314 C...END OF CHARGINOS/NEUTRALINOS
26315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26316 
26317  DO 120 i = 1,2
26318  DO 110 j = 1,2
26319  xm2p(i,j) = xm2(i,j) + vh(i,j)
26320  110 CONTINUE
26321  120 CONTINUE
26322 
26323  trm2p = xm2p(1,1) + xm2p(2,2)
26324  detm2p = xm2p(1,1)*xm2p(2,2) - xm2p(1,2)*xm2p(2,1)
26325 
26326  xmh2p = (trm2p - (trm2p**2 - 4d0* detm2p)**0.5d0)/2d0
26327  hm2p = (trm2p + (trm2p**2 - 4d0* detm2p)**0.5d0)/2d0
26328  hmp = hm2p**0.5d0
26329  IF(xmh2p.LT.0d0) goto 130
26330  xmhp = xmh2p**0.5d0
26331  s2alp = 2d0*xm2p(1,2)/(trm2p**2-4d0*detm2p)**0.5d0
26332  c2alp = (xm2p(1,1)-xm2p(2,2))/(trm2p**2-4d0*detm2p)**0.5d0
26333  IF(c2alp.GT.0d0) alp = asin(s2alp)/2d0
26334  IF(c2alp.LT.0d0) alp = -pi/2d0-asin(s2alp)/2d0
26335  sa = sin(alp)
26336  ca = cos(alp)
26337  sqbma = (sinb*ca - cosb*sa)**2
26338  130 xin = 1d0
26339  140 CONTINUE
26340 
26341  RETURN
26342  END
26343 
26344 C*********************************************************************
26345 
26346 C...PYGFXX
26347 C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
26348 
26349  SUBROUTINE pygfxx(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
26350  &stop1,stop2)
26351 
26352 C...Double precision and integer declarations.
26353  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26354  INTEGER pyk,pychge,pycomp
26355 
26356 C...Local variables.
26357  dimension diah(2),vh(2,2),vh1(2,2),vh2(2,2),
26358  &vh3t(2,2),vh3b(2,2),
26359  &hmix(2,2),al(2,2),xm2(2,2)
26360 
26361 C...Statement function.
26362  g(x,y) = 2d0 - (x+y)/(x-y)*log(x/y)
26363 
26364  IF(dabs(xmu).LT.0.000001d0) xmu = 0.000001d0
26365  xmq2 = xmq**2
26366  xmur2 = xmur**2
26367  xmdl2 = xmdl**2
26368  tanba = tanb
26369  sinba = tanba/(tanba**2+1d0)**0.5d0
26370  cosba = sinba/tanba
26371 
26372  sinb = tanb/(tanb**2+1d0)**0.5d0
26373  cosb = sinb/tanb
26374  pi = 3.14159d0
26375  g2 = (0.0336d0*4d0*pi)**0.5d0
26376  g12 = (0.0101d0*4d0*pi)
26377  g1 = g12**0.5d0
26378  xmz = 91.18d0
26379  v = 174.1d0
26380  mw = (g2**2*v**2/2d0)**0.5d0
26381  alp3 = 0.12d0/(1d0+23/12d0/pi*0.12d0*log(xmt**2/xmz**2))
26382 
26383  xmb = 3d0
26384  IF(xmq.GT.xmur) xmst = xmq
26385  IF(xmur.GT.xmq.OR.xmur.EQ.xmq) xmst = xmur
26386 
26387  xmsut = (xmst**2 + xmt**2)**0.5d0
26388 
26389  IF(xmq.GT.xmdl) xmsb = xmq
26390  IF(xmdl.GT.xmq.OR.xmdl.EQ.xmq) xmsb = xmdl
26391 
26392  xmsub = (xmsb**2 + xmb**2)**0.5d0
26393 
26394  tt = log(xmsut**2/xmt**2)
26395  tb = log(xmsub**2/xmt**2)
26396 
26397  rxmt = xmt/(1d0+4d0*alp3/3d0/pi)
26398  ht = rxmt/(174.1d0*sinb)
26399  htst = rxmt/174.1d0
26400  hb = xmb/174.1d0/cosb
26401  g32 = alp3*4d0*pi
26402  bt2 = -(8d0*g32 - 9d0*ht**2/2d0 - hb**2/2d0)/(4d0*pi)**2
26403  bb2 = -(8d0*g32 - 9d0*hb**2/2d0 - ht**2/2d0)/(4d0*pi)**2
26404  al2 = 3d0/8d0/pi**2*ht**2
26405  bt2st = -(8d0*g32 - 9d0*htst**2/2d0)/(4d0*pi)**2
26406  alst = 3d0/8d0/pi**2*htst**2
26407  al1 = 3d0/8d0/pi**2*hb**2
26408 
26409  al(1,1) = al1
26410  al(1,2) = (al2+al1)/2d0
26411  al(2,1) = (al2+al1)/2d0
26412  al(2,2) = al2
26413 
26414  xmt4 = rxmt**4*(1d0+2d0*bt2*tt- al2*tt)
26415  xmt2 = sqrt(xmt4)
26416  xmbot4 = xmb**4*(1d0+2d0*bb2*tb - al1*tb)
26417  xmbot2 = sqrt(xmbot4)
26418 
26419  IF(xma.GT.xmt) THEN
26420  vi = 174.1d0*(1d0 + 3d0/32d0/pi**2*htst**2*
26421  & log(xmt**2/xma**2))
26422  h1i = vi* cosba
26423  h2i = vi*sinba
26424  h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xma**2/xmsut**2))**0.25d0
26425  h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xma**2/xmsut**2))**0.25d0
26426  h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xma**2/xmsub**2))**0.25d0
26427  h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xma**2/xmsub**2))**0.25d0
26428  ELSE
26429  vi = 174.1d0
26430  h1i = vi*cosb
26431  h2i = vi*sinb
26432  h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xmt**2/xmsut**2))**0.25d0
26433  h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xmt**2/xmsut**2))**0.25d0
26434  h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xmt**2/xmsub**2))**0.25d0
26435  h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xmt**2/xmsub**2))**0.25d0
26436  ENDIF
26437 
26438  tanbst = h2t/h1t
26439  sinbt = tanbst/(1d0+tanbst**2)**0.5d0
26440  cosbt = sinbt/tanbst
26441 
26442  tanbsb = h2b/h1b
26443  sinbb = tanbsb/(1d0+tanbsb**2)**0.5d0
26444  cosbb = sinbb/tanbsb
26445 
26446  stop12 = (xmq2 + xmur2)*0.5d0 + xmt2
26447  &+1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
26448  &+(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
26449  &xmq2 - xmur2)**2*0.25d0 + xmt2*(at-xmu/tanbst)**2)**0.5d0
26450  stop22 = (xmq2 + xmur2)*0.5d0 + xmt2
26451  &+1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
26452  &- (((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
26453  &xmq2 - xmur2)**2*0.25d0
26454  &+ xmt2*(at-xmu/tanbst)**2)**0.5d0
26455  IF(stop22.LT.0d0) goto 120
26456  sbot12 = (xmq2 + xmdl2)*0.5d0
26457  &- 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
26458  &+ (((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
26459  &xmq2 - xmdl2)**2*0.25d0 + xmbot2*(ab-xmu*tanbsb)**2)**0.5d0
26460  sbot22 = (xmq2 + xmdl2)*0.5d0
26461  &- 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
26462  &- (((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
26463  &xmq2 - xmdl2)**2*0.25d0 + xmbot2*(ab-xmu*tanbsb)**2)**0.5d0
26464  IF(sbot22.LT.0d0) goto 120
26465 
26466  stop1 = stop12**0.5d0
26467  stop2 = stop22**0.5d0
26468  sbot1 = sbot12**0.5d0
26469  sbot2 = sbot22**0.5d0
26470 
26471  vh1(1,1) = 1d0/tanbst
26472  vh1(2,1) = -1d0
26473  vh1(1,2) = -1d0
26474  vh1(2,2) = tanbst
26475  vh2(1,1) = tanbst
26476  vh2(1,2) = -1d0
26477  vh2(2,1) = -1d0
26478  vh2(2,2) = 1d0/tanbst
26479 
26480 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26481 C...D-TERMS
26482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26483  stw=0.2320d0
26484 
26485  f1t=(xmq2-xmur2)/(stop12-stop22)*(0.5d0-4d0/3d0*stw)*
26486  &log(stop1/stop2)
26487  &+(0.5d0-2d0/3d0*stw)*log(stop1*stop2/(xmq2+xmt2))
26488  &+ 2d0/3d0*stw*log(stop1*stop2/(xmur2+xmt2))
26489 
26490  f1b=(xmq2-xmdl2)/(sbot12-sbot22)*(-0.5d0+2d0/3d0*stw)*
26491  &log(sbot1/sbot2)
26492  &+(-0.5d0+1d0/3d0*stw)*log(sbot1*sbot2/(xmq2+xmbot2))
26493  &- 1d0/3d0*stw*log(sbot1*sbot2/(xmdl2+xmbot2))
26494 
26495  f2t=xmt2**0.5d0*(at-xmu/tanbst)/(stop12-stop22)*
26496  &(-0.5d0*log(stop12/stop22)
26497  &+(4d0/3d0*stw-0.5d0)*(xmq2-xmur2)/(stop12-stop22)*
26498  &g(stop12,stop22))
26499 
26500  f2b=xmbot2**0.5d0*(ab-xmu*tanbsb)/(sbot12-sbot22)*
26501  &(0.5d0*log(sbot12/sbot22)
26502  &+(-2d0/3d0*stw+0.5d0)*(xmq2-xmdl2)/(sbot12-sbot22)*
26503  &g(sbot12,sbot22))
26504 
26505  vh3b(1,1) = xmbot4/(cosbb**2)*(log(sbot1**2*sbot2**2/
26506  &(xmq2+xmbot2)/(xmdl2+xmbot2))
26507  &+ 2d0*(ab*(ab-xmu*tanbsb)/(sbot1**2-sbot2**2))*
26508  &log(sbot1**2/sbot2**2)) +
26509  &xmbot4/(cosbb**2)*(ab*(ab-xmu*tanbsb)/
26510  &(sbot1**2-sbot2**2))**2*g(sbot12,sbot22)
26511 
26512  vh3t(1,1) =
26513  &xmt4/(sinbt**2)*(xmu*(-at+xmu/tanbst)/(stop1**2
26514  &-stop2**2))**2*g(stop12,stop22)
26515 
26516  vh3b(1,1)=vh3b(1,1)+
26517  &xmz**2*(2*xmbot2*f1b-xmbot2**0.5d0*ab*f2b)
26518 
26519  vh3t(1,1) = vh3t(1,1) +
26520  &xmz**2*(xmt2**0.5d0*xmu/tanbst*f2t)
26521 
26522  vh3t(2,2) = xmt4/(sinbt**2)*(log(stop1**2*stop2**2/
26523  &(xmq2+xmt2)/(xmur2+xmt2))
26524  &+ 2d0*(at*(at-xmu/tanbst)/(stop1**2-stop2**2))*
26525  &log(stop1**2/stop2**2)) +
26526  &xmt4/(sinbt**2)*(at*(at-xmu/tanbst)/
26527  &(stop1**2-stop2**2))**2*g(stop12,stop22)
26528 
26529  vh3b(2,2) =
26530  &xmbot4/(cosbb**2)*(xmu*(-ab+xmu*tanbsb)/(sbot1**2
26531  &-sbot2**2))**2*g(sbot12,sbot22)
26532 
26533  vh3t(2,2)=vh3t(2,2)+
26534  &xmz**2*(-2*xmt2*f1t+xmt2**0.5d0*at*f2t)
26535 
26536  vh3b(2,2) = vh3b(2,2) -xmz**2*xmbot2**0.5d0*xmu*tanbsb*f2b
26537 
26538  vh3t(1,2) = -
26539  &xmt4/(sinbt**2)*xmu*(at-xmu/tanbst)/
26540  &(stop1**2-stop2**2)*(log(stop1**2/stop2**2) + at*
26541  &(at - xmu/tanbst)/(stop1**2-stop2**2)*g(stop12,stop22))
26542 
26543  vh3b(1,2) =
26544  &- xmbot4/(cosbb**2)*xmu*(at-xmu*tanbsb)/
26545  &(sbot1**2-sbot2**2)*(log(sbot1**2/sbot2**2) + ab*
26546  &(ab - xmu*tanbsb)/(sbot1**2-sbot2**2)*g(sbot12,sbot22))
26547 
26548  vh3t(1,2)=vh3t(1,2) +
26549  &xmz**2*(xmt2/tanbst*f1t-xmt2**0.5d0*(at/tanbst+xmu)/2d0*f2t)
26550 
26551  vh3b(1,2)=vh3b(1,2)
26552  &+xmz**2*(-xmbot2*tanbsb*f1b+xmbot2**0.5d0*(ab*tanbsb+xmu)/2d0*f2b)
26553 
26554  vh3t(2,1) = vh3t(1,2)
26555  vh3b(2,1) = vh3b(1,2)
26556 
26557  tq = log((xmq2 + xmt2)/xmt2)
26558  tu = log((xmur2+xmt2)/xmt2)
26559  tqd = log((xmq2 + xmb**2)/xmb**2)
26560  td = log((xmdl2+xmb**2)/xmb**2)
26561 
26562  DO 110 i = 1,2
26563  DO 100 j = 1,2
26564 
26565  vh(i,j) =
26566  & 6d0/(8d0*pi**2*(h1t**2+h2t**2))
26567  & *vh3t(i,j)*0.5d0*(1d0-al(i,j)*tt/2d0) +
26568  & 6d0/(8d0*pi**2*(h1b**2+h2b**2))
26569  & *vh3b(i,j)*0.5d0*(1d0-al(i,j)*tb/2d0)
26570 
26571  100 CONTINUE
26572  110 CONTINUE
26573 
26574  goto 150
26575  120 DO 140 i =1,2
26576  DO 130 j = 1,2
26577  vh(i,j) = -1d+15
26578  130 CONTINUE
26579  140 CONTINUE
26580 
26581  150 CONTINUE
26582 
26583  RETURN
26584  END
26585 
26586 C*********************************************************************
26587 
26588 C...PYFINT
26589 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26590 
26591  FUNCTION pyfint(A,B,C)
26592 
26593 C...Double precision and integer declarations.
26594  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26595  INTEGER pyk,pychge,pycomp
26596 C...Commonblock.
26597  common/pyints/xxm(20)
26598  SAVE/pyints/
26599 
26600 C...Local variables.
26601  EXTERNAL pyfisb
26602 
26603  xxm(1)=a
26604  xxm(2)=b
26605  xxm(3)=c
26606  pyfint = pygaus(pyfisb,xlo,xhi,1d-3)
26607 
26608  RETURN
26609  END
26610 
26611 C*********************************************************************
26612 
26613 C...PYFISB
26614 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
26615 
26616  FUNCTION pyfisb(X)
26617 
26618 C...Double precision and integer declarations.
26619  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26620  INTEGER pyk,pychge,pycomp
26621 C...Commonblock.
26622  common/pyints/xxm(20)
26623  SAVE/pyints/
26624 
26625  pyfisb = log(abs(x*xxm(2)+(1-x)*xxm(3)-x*(1-x)*xxm(1))/
26626  &(x*(xxm(2)-xxm(3))+xxm(3)))
26627 
26628  RETURN
26629  END
26630 
26631 C*********************************************************************
26632 
26633 C...PYSFDC
26634 C...Calculates decays of sfermions.
26635 
26636  SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)
26637 
26638 C...Double precision and integer declarations.
26639  IMPLICIT DOUBLE PRECISION(a-h, o-z)
26640  INTEGER pyk,pychge,pycomp
26641 C...Parameter statement to help give large particle numbers.
26642  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
26643 C...Commonblocks.
26644  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
26645  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
26646  common/pymssm/imss(0:99),rmss(0:99)
26647  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
26648  &sfmix(16,4)
26649  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
26650 
26651 C...Local variables.
26652  INTEGER kfin,kcin
26653  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,xmz,
26654  &xmz2,axmj,axmi
26655  DOUBLE PRECISION xmi2,xmi3,xmj2,xma2,xmb2,xmfp
26656  DOUBLE PRECISION pylamf,xl
26657  DOUBLE PRECISION tanw,xw,aem,c1,as
26658  DOUBLE PRECISION ca,cb,al,ar,bl,br,alp,arp,blp,brp
26659  DOUBLE PRECISION ch1,ch2,ch3,ch4
26660  DOUBLE PRECISION xmbot,xmtop
26661  DOUBLE PRECISION xlam(0:200)
26662  INTEGER idlam(200,3)
26663  INTEGER lknt,ix,ic,ilr,idu,j,ij,i,iknt,ifl,ifp,ii
26664  DOUBLE PRECISION sr2
26665  DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k
26666  DOUBLE PRECISION cw
26667  DOUBLE PRECISION beta,alfa,xmu,at,ab,atrit,atrib,atril
26668  DOUBLE PRECISION cosa,sina,tanb
26669  DOUBLE PRECISION pyalem,pi,pyalps,ei,pyrnmt
26670  DOUBLE PRECISION ghrr,ghll,ghlr,cf,xmb,blr
26671  INTEGER ig,kf1,kf2,ilr2,idp
26672  INTEGER igg(4),kfnchi(4),kfcchi(2)
26673  DATA igg/23,25,35,36/
26674  DATA pi/3.141592654d0/
26675  DATA sr2/1.4142136d0/
26676  DATA kfnchi/1000022,1000023,1000025,1000035/
26677  DATA kfcchi/1000024,1000037/
26678 
26679 C...COUNT THE NUMBER OF DECAY MODES
26680  lknt=0
26681 
26682 C...NO NU_R DECAYS
26683  IF(kfin.EQ.ksusy2+12.OR.kfin.EQ.ksusy2+14.OR.
26684  &kfin.EQ.ksusy2+16) RETURN
26685 
26686  xmw=pmas(24,1)
26687  xmw2=xmw**2
26688  xmz=pmas(23,1)
26689  xmz2=xmz**2
26690  xw=paru(102)
26691  tanw = sqrt(xw/(1d0-xw))
26692  cw=sqrt(1d0-xw)
26693 
26694 C...KCIN
26695  kcin=pycomp(kfin)
26696 C...ILR is 1 for left and 2 for right.
26697  ilr=kfin/ksusy1
26698 C...IFL is matching non-SUSY flavour.
26699  ifl=mod(kfin,ksusy1)
26700 C...IDU is weak isospin, 1 for down and 2 for up.
26701  idu=2-mod(ifl,2)
26702 
26703  xmi=pmas(kcin,1)
26704  xmi2=xmi**2
26705  aem=pyalem(xmi2)
26706  as =pyalps(xmi2)
26707  c1=aem/xw
26708  xmi3=xmi**3
26709  ei=kchg(ifl,1)/3d0
26710 
26711  xmbot=3d0
26712  xmtop=pyrnmt(pmas(6,1))
26713  xmbot=0d0
26714 
26715  tanb=rmss(5)
26716  beta=atan(tanb)
26717  alfa=rmss(18)
26718  cbeta=cos(beta)
26719  sbeta=tanb*cbeta
26720  sina=sin(alfa)
26721  cosa=cos(alfa)
26722  xmu=-rmss(4)
26723  atrit=rmss(16)
26724  atrib=rmss(15)
26725  atril=rmss(17)
26726 
26727 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
26728 
26729  IF(imss(11).EQ.1) THEN
26730  xmp=rmss(28)
26731  idg=39+ksusy1
26732  xmgr=pmas(pycomp(idg),1)
26733  xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
26734  IF(ifl.EQ.5) THEN
26735  xmf=xmbot
26736  ELSEIF(ifl.EQ.6) THEN
26737  xmf=xmtop
26738  ELSE
26739  xmf=pmas(ifl,1)
26740  ENDIF
26741  IF(xmi.GT.xmgr+xmf) THEN
26742  lknt=lknt+1
26743  idlam(lknt,1)=idg
26744  idlam(lknt,2)=ifl
26745  idlam(lknt,3)=0
26746  xlam(lknt)=xfac*(1d0-xmf**2/xmi2)**4
26747  ENDIF
26748  ENDIF
26749 
26750 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
26751 
26752 C...CHARGED DECAYS:
26753  DO 100 ix=1,2
26754 C...DI -> U CHI1-,CHI2-
26755  IF(idu.EQ.1) THEN
26756  xmfp=pmas(ifl+1,1)
26757  xmf =pmas(ifl,1)
26758 C...UI -> D CHI1+,CHI2+
26759  ELSE
26760  xmfp=pmas(ifl-1,1)
26761  xmf =pmas(ifl,1)
26762  ENDIF
26763  xmj=smw(ix)
26764  axmj=abs(xmj)
26765  IF(xmi.GE.axmj+xmfp) THEN
26766  xma2=xmj**2
26767  xmb2=xmfp**2
26768  IF(idu.EQ.2) THEN
26769  IF(ifl.EQ.6) THEN
26770  xmfp=xmbot
26771  xmf =xmtop
26772  ELSEIF(ifl.LT.6) THEN
26773  xmf=0d0
26774  xmfp=0d0
26775  ENDIF
26776  bl=vmix(ix,1)
26777  al=-xmfp*umix(ix,2)/sr2/xmw/cbeta
26778  br=-xmf*vmix(ix,2)/sr2/xmw/sbeta
26779  ar=0d0
26780  ELSE
26781  IF(ifl.EQ.5) THEN
26782  xmf =xmbot
26783  xmfp=xmtop
26784  ELSEIF(ifl.LT.5) THEN
26785  xmf=0d0
26786  xmfp=0d0
26787  ENDIF
26788  bl=umix(ix,1)
26789  al=-xmfp*vmix(ix,2)/sr2/xmw/sbeta
26790  br=-xmf*umix(ix,2)/sr2/xmw/cbeta
26791  ar=0d0
26792  ENDIF
26793 
26794  alp=sfmix(ifl,1)*al + sfmix(ifl,2)*ar
26795  blp=sfmix(ifl,1)*bl + sfmix(ifl,2)*br
26796  arp=sfmix(ifl,4)*ar + sfmix(ifl,3)*al
26797  brp=sfmix(ifl,4)*br + sfmix(ifl,3)*bl
26798  al=alp
26799  bl=blp
26800  ar=arp
26801  br=brp
26802 
26803 C...F1 -> F` CHI
26804  IF(ilr.EQ.1) THEN
26805  ca=al
26806  cb=bl
26807 C...F2 -> F` CHI
26808  ELSE
26809  ca=ar
26810  cb=br
26811  ENDIF
26812  lknt=lknt+1
26813  xl=pylamf(xmi2,xma2,xmb2)
26814 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
26815  xlam(lknt)=2d0*c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
26816  & (ca**2+cb**2)-4d0*ca*cb*xmj*xmfp)
26817  idlam(lknt,3)=0
26818  IF(idu.EQ.1) THEN
26819  idlam(lknt,1)=-kfcchi(ix)
26820  idlam(lknt,2)=ifl+1
26821  ELSE
26822  idlam(lknt,1)=kfcchi(ix)
26823  idlam(lknt,2)=ifl-1
26824  ENDIF
26825  ENDIF
26826  100 CONTINUE
26827 
26828 C...NEUTRAL DECAYS
26829  DO 110 ix=1,4
26830 C...DI -> D CHI10
26831  xmf=pmas(ifl,1)
26832  xmj=smz(ix)
26833  axmj=abs(xmj)
26834  IF(xmi.GE.axmj+xmf) THEN
26835  xma2=xmj**2
26836  xmb2=xmf**2
26837  IF(idu.EQ.1) THEN
26838  IF(ifl.EQ.5) THEN
26839  xmf=xmbot
26840  ELSEIF(ifl.LT.5) THEN
26841  xmf=0d0
26842  ENDIF
26843  bl=-zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei+1)
26844  al=xmf*zmix(ix,3)/xmw/cbeta
26845  ar=-2d0*ei*tanw*zmix(ix,1)
26846  br=al
26847  ELSE
26848  IF(ifl.EQ.6) THEN
26849  xmf=xmtop
26850  ELSEIF(ifl.LT.5) THEN
26851  xmf=0d0
26852  ENDIF
26853  bl=zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-1)
26854  al=xmf*zmix(ix,4)/xmw/sbeta
26855  ar=-2d0*ei*tanw*zmix(ix,1)
26856  br=al
26857  ENDIF
26858 
26859  alp=sfmix(ifl,1)*al + sfmix(ifl,2)*ar
26860  blp=sfmix(ifl,1)*bl + sfmix(ifl,2)*br
26861  arp=sfmix(ifl,4)*ar + sfmix(ifl,3)*al
26862  brp=sfmix(ifl,4)*br + sfmix(ifl,3)*bl
26863  al=alp
26864  bl=blp
26865  ar=arp
26866  br=brp
26867 
26868 C...F1 -> F CHI
26869  IF(ilr.EQ.1) THEN
26870  ca=al
26871  cb=bl
26872 C...F2 -> F CHI
26873  ELSE
26874  ca=ar
26875  cb=br
26876  ENDIF
26877  lknt=lknt+1
26878  xl=pylamf(xmi2,xma2,xmb2)
26879 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
26880  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
26881  & (ca**2+cb**2)-4d0*ca*cb*xmj*xmf)
26882  idlam(lknt,1)=kfnchi(ix)
26883  idlam(lknt,2)=ifl
26884  idlam(lknt,3)=0
26885  ENDIF
26886  110 CONTINUE
26887 
26888 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
26889 C...IG=23,25,35,36
26890  DO 120 ii=1,4
26891  ig=igg(ii)
26892  IF(ilr.EQ.1) goto 120
26893  xmb=pmas(ig,1)
26894  xmsf1=pmas(pycomp(kfin-ksusy1),1)
26895  IF(xmi.LT.xmsf1+xmb) goto 120
26896  IF(ig.EQ.23) THEN
26897  bl=-sign(.5d0,ei)/cw+ei*xw/cw
26898  br=ei*xw/cw
26899  blr=0d0
26900  ELSEIF(ig.EQ.25) THEN
26901  IF(ifl.EQ.5) THEN
26902  xmf=xmbot
26903  ELSEIF(ifl.EQ.6) THEN
26904  xmf=xmtop
26905  ELSEIF(ifl.LT.5) THEN
26906  xmf=0d0
26907  ELSE
26908  xmf=pmas(ifl,1)
26909  ENDIF
26910  IF(idu.EQ.2) THEN
26911  ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
26912  & xmf**2/xmw*cosa/sbeta
26913  ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
26914  & xmf**2/xmw*cosa/sbeta
26915  ELSE
26916  ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
26917  & xmf**2/xmw*(-sina)/cbeta
26918  ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
26919  & xmf**2/xmw*(-sina)/cbeta
26920  ENDIF
26921  IF(ifl.EQ.5) THEN
26922  at=atrib
26923  ELSEIF(ifl.EQ.6) THEN
26924  at=atrit
26925  ELSEIF(ifl.EQ.15) THEN
26926  at=atril
26927  ELSE
26928  at=0d0
26929  ENDIF
26930  IF(idu.EQ.2) THEN
26931  ghlr=xmf/2d0/xmw/sbeta*(-xmu*sina+
26932  & at*cosa)
26933  ELSE
26934  ghlr=xmf/2d0/xmw/cbeta*(xmu*cosa-
26935  & at*sina)
26936  ENDIF
26937  bl=ghll
26938  br=ghrr
26939  blr=-ghlr
26940  ELSEIF(ig.EQ.35) THEN
26941  IF(ifl.EQ.5) THEN
26942  xmf=xmbot
26943  ELSEIF(ifl.EQ.6) THEN
26944  xmf=xmtop
26945  ELSEIF(ifl.LT.5) THEN
26946  xmf=0d0
26947  ELSE
26948  xmf=pmas(ifl,1)
26949  ENDIF
26950  IF(idu.EQ.2) THEN
26951  ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
26952  & xmf**2/xmw*sina/sbeta
26953  ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
26954  & xmf**2/xmw*sina/sbeta
26955  ELSE
26956  ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
26957  & xmf**2/xmw*cosa/cbeta
26958  ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
26959  & xmf**2/xmw*cosa/cbeta
26960  ENDIF
26961  IF(ifl.EQ.5) THEN
26962  at=atrib
26963  ELSEIF(ifl.EQ.6) THEN
26964  at=atrit
26965  ELSEIF(ifl.EQ.15) THEN
26966  at=atril
26967  ELSE
26968  at=0d0
26969  ENDIF
26970  IF(idu.EQ.2) THEN
26971  ghlr=xmf/2d0/xmw/sbeta*(xmu*cosa+
26972  & at*sina)
26973  ELSE
26974  ghlr=xmf/2d0/xmw/cbeta*(xmu*sina+
26975  & at*cosa)
26976  ENDIF
26977  bl=ghll
26978  br=ghrr
26979  blr=ghlr
26980  ELSEIF(ig.EQ.36) THEN
26981  ghll=0d0
26982  ghrr=0d0
26983  IF(ifl.EQ.5) THEN
26984  xmf=xmbot
26985  ELSEIF(ifl.EQ.6) THEN
26986  xmf=xmtop
26987  ELSEIF(ifl.LT.5) THEN
26988  xmf=0d0
26989  ELSE
26990  xmf=pmas(ifl,1)
26991  ENDIF
26992  IF(ifl.EQ.5) THEN
26993  at=atrib
26994  ELSEIF(ifl.EQ.6) THEN
26995  at=atrit
26996  ELSEIF(ifl.EQ.15) THEN
26997  at=atril
26998  ELSE
26999  at=0d0
27000  ENDIF
27001  IF(idu.EQ.2) THEN
27002  ghlr=xmf/2d0/xmw*(-xmu+at/tanb)
27003  ELSE
27004  ghlr=xmf/2d0/xmw/(-xmu+at*tanb)
27005  ENDIF
27006  bl=ghll
27007  br=ghrr
27008  blr=ghlr
27009  ENDIF
27010  al=sfmix(ifl,1)*sfmix(ifl,3)*bl+
27011  & sfmix(ifl,2)*sfmix(ifl,4)*br+
27012  & (sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,3)*sfmix(ifl,2))*blr
27013  xl=pylamf(xmi2,xmsf1**2,xmb**2)
27014  lknt=lknt+1
27015  IF(ig.EQ.23) THEN
27016  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
27017  ELSE
27018  xlam(lknt)=c1/4d0/xmi3*sqrt(xl)*al**2
27019  ENDIF
27020  idlam(lknt,3)=0
27021  idlam(lknt,1)=kfin-ksusy1
27022  idlam(lknt,2)=ig
27023  120 CONTINUE
27024 
27025 C...SF -> SF' + W
27026  xmb=pmas(24,1)
27027  IF(mod(ifl,2).EQ.0) THEN
27028  kf1=ksusy1+ifl-1
27029  ELSE
27030  kf1=ksusy1+ifl+1
27031  ENDIF
27032  kf2=kf1+ksusy1
27033  xmsf1=pmas(pycomp(kf1),1)
27034  xmsf2=pmas(pycomp(kf2),1)
27035  IF(xmi.GT.xmb+xmsf1) THEN
27036  IF(mod(ifl,2).EQ.0) THEN
27037  IF(ilr.EQ.1) THEN
27038  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,1)
27039  ELSE
27040  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,1)
27041  ENDIF
27042  ELSE
27043  IF(ilr.EQ.1) THEN
27044  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,1)
27045  ELSE
27046  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,1)
27047  ENDIF
27048  ENDIF
27049  xl=pylamf(xmi2,xmsf1**2,xmb**2)
27050  lknt=lknt+1
27051  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
27052  idlam(lknt,3)=0
27053  idlam(lknt,1)=kf1
27054  idlam(lknt,2)=sign(24,kchg(ifl,1))
27055  ENDIF
27056  IF(xmi.GT.xmb+xmsf2) THEN
27057  IF(mod(ifl,2).EQ.0) THEN
27058  IF(ilr.EQ.1) THEN
27059  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,3)
27060  ELSE
27061  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,3)
27062  ENDIF
27063  ELSE
27064  IF(ilr.EQ.1) THEN
27065  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,3)
27066  ELSE
27067  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,3)
27068  ENDIF
27069  ENDIF
27070  xl=pylamf(xmi2,xmsf2**2,xmb**2)
27071  lknt=lknt+1
27072  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
27073  idlam(lknt,3)=0
27074  idlam(lknt,1)=kf2
27075  idlam(lknt,2)=sign(24,kchg(ifl,1))
27076  ENDIF
27077 
27078 C...SF -> SF' + HC
27079  xmb=pmas(37,1)
27080  IF(mod(ifl,2).EQ.0) THEN
27081  kf1=ksusy1+ifl-1
27082  ELSE
27083  kf1=ksusy1+ifl+1
27084  ENDIF
27085  kf2=kf1+ksusy1
27086  xmsf1=pmas(pycomp(kf1),1)
27087  xmsf2=pmas(pycomp(kf2),1)
27088  IF(xmi.GT.xmb+xmsf1) THEN
27089  xmf=0d0
27090  xmfp=0d0
27091  at=0d0
27092  ab=0d0
27093  IF(mod(ifl,2).EQ.0) THEN
27094 C...T1-> B1 HC
27095  IF(ilr.EQ.1) THEN
27096  ch1=-sfmix(ifl,1)*sfmix(ifl-1,1)
27097  ch2= sfmix(ifl,2)*sfmix(ifl-1,2)
27098  ch3=-sfmix(ifl,1)*sfmix(ifl-1,2)
27099  ch4=-sfmix(ifl,2)*sfmix(ifl-1,1)
27100 C...T2-> B1 HC
27101  ELSE
27102  ch1= sfmix(ifl,3)*sfmix(ifl-1,1)
27103  ch2=-sfmix(ifl,4)*sfmix(ifl-1,2)
27104  ch3= sfmix(ifl,3)*sfmix(ifl-1,2)
27105  ch4= sfmix(ifl,4)*sfmix(ifl-1,1)
27106  ENDIF
27107  IF(ifl.EQ.6) THEN
27108  xmf=xmtop
27109  xmfp=xmbot
27110  at=atrit
27111  ab=atrib
27112  ENDIF
27113  ELSE
27114 C...B1 -> T1 HC
27115  IF(ilr.EQ.1) THEN
27116  ch1=-sfmix(ifl+1,1)*sfmix(ifl,1)
27117  ch2= sfmix(ifl+1,2)*sfmix(ifl,2)
27118  ch3=-sfmix(ifl+1,1)*sfmix(ifl,2)
27119  ch4=-sfmix(ifl+1,2)*sfmix(ifl,1)
27120 C...B2-> T1 HC
27121  ELSE
27122  ch1= sfmix(ifl,3)*sfmix(ifl+1,1)
27123  ch2=-sfmix(ifl,4)*sfmix(ifl+1,2)
27124  ch3= sfmix(ifl,4)*sfmix(ifl+1,1)
27125  ch4= sfmix(ifl,3)*sfmix(ifl+1,2)
27126  ENDIF
27127  IF(ifl.EQ.5) THEN
27128  xmf=xmtop
27129  xmfp=xmbot
27130  at=atrit
27131  ab=atrib
27132  ENDIF
27133  ENDIF
27134  xl=pylamf(xmi2,xmsf1**2,xmb**2)
27135  lknt=lknt+1
27136  al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
27137  & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
27138  & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
27139  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
27140  idlam(lknt,3)=0
27141  idlam(lknt,1)=kf1
27142  idlam(lknt,2)=sign(37,kchg(ifl,1))
27143  ENDIF
27144  IF(xmi.GT.xmb+xmsf2) THEN
27145  xmf=0d0
27146  xmfp=0d0
27147  at=0d0
27148  ab=0d0
27149  IF(mod(ifl,2).EQ.0) THEN
27150 C...T1-> B2 HC
27151  IF(ilr.EQ.1) THEN
27152  ch1= sfmix(ifl-1,3)*sfmix(ifl,1)
27153  ch2=-sfmix(ifl-1,4)*sfmix(ifl,2)
27154  ch3= sfmix(ifl-1,4)*sfmix(ifl,1)
27155  ch4= sfmix(ifl-1,3)*sfmix(ifl,2)
27156 C...T2-> B2 HC
27157  ELSE
27158  ch1= -sfmix(ifl,3)*sfmix(ifl-1,3)
27159  ch2= sfmix(ifl,4)*sfmix(ifl-1,4)
27160  ch3= -sfmix(ifl,3)*sfmix(ifl-1,4)
27161  ch4= -sfmix(ifl,4)*sfmix(ifl-1,3)
27162  ENDIF
27163  IF(ifl.EQ.6) THEN
27164  xmf=xmtop
27165  xmfp=xmbot
27166  at=atrit
27167  ab=atrib
27168  ENDIF
27169  ELSE
27170 C...B1 -> T2 HC
27171  IF(ilr.EQ.1) THEN
27172  ch1= sfmix(ifl+1,3)*sfmix(ifl,1)
27173  ch2=-sfmix(ifl+1,4)*sfmix(ifl,2)
27174  ch3= sfmix(ifl+1,3)*sfmix(ifl,2)
27175  ch4= sfmix(ifl+1,4)*sfmix(ifl,1)
27176 C...B2-> T2 HC
27177  ELSE
27178  ch1= -sfmix(ifl+1,3)*sfmix(ifl,3)
27179  ch2= sfmix(ifl+1,4)*sfmix(ifl,4)
27180  ch3= -sfmix(ifl+1,3)*sfmix(ifl,4)
27181  ch4= -sfmix(ifl+1,4)*sfmix(ifl,3)
27182  ENDIF
27183  IF(ifl.EQ.5) THEN
27184  xmf=xmtop
27185  xmfp=xmbot
27186  at=atrit
27187  ab=atrib
27188  ENDIF
27189  ENDIF
27190  xl=pylamf(xmi2,xmsf1**2,xmb**2)
27191  lknt=lknt+1
27192  al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
27193  & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
27194  & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
27195  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
27196  idlam(lknt,3)=0
27197  idlam(lknt,1)=kf2
27198  idlam(lknt,2)=sign(37,kchg(ifl,1))
27199  ENDIF
27200 
27201 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
27202 
27203  IF(ifl.LE.6) THEN
27204  xmfp=0d0
27205  xmf=0d0
27206  IF(ifl.EQ.6) xmf=pmas(6,1)
27207  IF(ifl.EQ.5) xmf=pmas(5,1)
27208  xmj=pmas(pycomp(ksusy1+21),1)
27209  axmj=abs(xmj)
27210  IF(xmi.GE.axmj+xmf) THEN
27211  al=-sfmix(ifl,2)
27212  bl=sfmix(ifl,1)
27213  ar=-sfmix(ifl,4)
27214  br=sfmix(ifl,3)
27215 C...F1 -> F CHI
27216  IF(ilr.EQ.1) THEN
27217  ca=al
27218  cb=bl
27219 C...F2 -> F CHI
27220  ELSE
27221  ca=ar
27222  cb=br
27223  ENDIF
27224  lknt=lknt+1
27225  xma2=xmj**2
27226  xmb2=xmf**2
27227  xl=pylamf(xmi2,xma2,xmb2)
27228  xlam(lknt)=4d0/3d0*as/2d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
27229  & (ca**2+cb**2)-4d0*ca*cb*xmj*xmf)
27230  idlam(lknt,1)=ksusy1+21
27231  idlam(lknt,2)=ifl
27232  idlam(lknt,3)=0
27233  ENDIF
27234  ENDIF
27235 
27236 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
27237  IF(kfin.EQ.ksusy1+6.AND.pmas(kcin,1).GT.
27238  &pmas(pycomp(ksusy1+22),1)+pmas(4,1)) THEN
27239 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
27240 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
27241 C...M*M = C1**2 * G**2/(16PI**2)
27242 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
27243  lknt=lknt+1
27244  xl=pylamf(xmi2,0d0,pmas(pycomp(ksusy1+22),1)**2)
27245  xlam(lknt)=c1**3/64d0/pi**2/xmi3*sqrt(xl)
27246  IF(xlam(lknt).EQ.0) xlam(lknt)=1d-3
27247  idlam(lknt,1)=ksusy1+22
27248  idlam(lknt,2)=4
27249  idlam(lknt,3)=0
27250  ENDIF
27251 
27252  iknt=lknt
27253  xlam(0)=0d0
27254  DO 130 i=1,iknt
27255  IF(xlam(i).LT.0d0) xlam(i)=0d0
27256  xlam(0)=xlam(0)+xlam(i)
27257  130 CONTINUE
27258  IF(xlam(0).EQ.0d0) xlam(0)=1d-3
27259 
27260  RETURN
27261  END
27262 
27263 C*********************************************************************
27264 
27265 C...PYGLUI
27266 C...Calculates gluino decay modes.
27267 
27268  SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)
27269 
27270 C...Double precision and integer declarations.
27271  IMPLICIT DOUBLE PRECISION(a-h, o-z)
27272  INTEGER pyk,pychge,pycomp
27273 C...Parameter statement to help give large particle numbers.
27274  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
27275 C...Commonblocks.
27276  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27277  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27278  common/pymssm/imss(0:99),rmss(0:99)
27279  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
27280  &sfmix(16,4)
27281  common/pyints/xxm(20)
27282  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/
27283 
27284 C...Local variables.
27285  INTEGER kfin,kcin,kf
27286  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,
27287  &xmz,xmz2,axmj,axmi
27288  DOUBLE PRECISION xmi2,xmi3,xmj2,xma2,xmb2,xmfp
27289  DOUBLE PRECISION c1l,c1r,d1l,d1r
27290  DOUBLE PRECISION c2l,c2r,d2l,d2r
27291  DOUBLE PRECISION pylamf,xl
27292  DOUBLE PRECISION tanw,xw,aem,c1,as,s12max,s12min
27293  DOUBLE PRECISION ca,cb,al,ar,bl,br
27294  DOUBLE PRECISION alfa,beta
27295  DOUBLE PRECISION sw,cw,sinb,cosb,qt,t3
27296  DOUBLE PRECISION xlam(0:200)
27297  INTEGER idlam(200,3)
27298  INTEGER lknt,ix,ic,ilr,idu,j,ij,i,iknt,ifl
27299  DOUBLE PRECISION sr2
27300  DOUBLE PRECISION gam
27301  DOUBLE PRECISION pyalem,pi,pyalps,ei
27302  DOUBLE PRECISION pygaus
27303  EXTERNAL pygaus,pyxxz5,pyxxw5,pyxxz2
27304  DOUBLE PRECISION prec
27305  INTEGER kfnchi(4),kfcchi(2)
27306  DATA pi/3.141592654d0/
27307  DATA sr2/1.4142136d0/
27308  DATA prec/1d-2/
27309  DATA kfnchi/1000022,1000023,1000025,1000035/
27310  DATA kfcchi/1000024,1000037/
27311 
27312 C...COUNT THE NUMBER OF DECAY MODES
27313  lknt=0
27314  IF(kfin.NE.ksusy1+21) RETURN
27315  kcin=pycomp(kfin)
27316 
27317  xmw=pmas(24,1)
27318  xmw2=xmw**2
27319  xmz=pmas(23,1)
27320  xmz2=xmz**2
27321  xw=paru(102)
27322  tanw = sqrt(xw/(1d0-xw))
27323 
27324  xmi=pmas(kcin,1)
27325  axmi=abs(xmi)
27326  xmi2=xmi**2
27327  aem=pyalem(xmi2)
27328  as =pyalps(xmi2)
27329  c1=aem/xw
27330  xmi3=xmi**3
27331  beta=atan(rmss(5))
27332 
27333 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
27334 
27335  IF(imss(11).EQ.1) THEN
27336  xmp=rmss(28)
27337  idg=39+ksusy1
27338  xmgr=pmas(pycomp(idg),1)
27339  xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
27340  IF(axmi.GT.xmgr) THEN
27341  lknt=lknt+1
27342  idlam(lknt,1)=idg
27343  idlam(lknt,2)=21
27344  idlam(lknt,3)=0
27345  xlam(lknt)=xfac
27346  ENDIF
27347  ENDIF
27348 
27349 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
27350 
27351  DO 110 ifl=1,6
27352  DO 100 ilr=1,2
27353  xmj=pmas(pycomp(ilr*ksusy1+ifl),1)
27354  axmj=abs(xmj)
27355  xmf=pmas(ifl,1)
27356  idu=3-(1+mod(ifl,2))
27357  IF(xmi.GE.axmj+xmf) THEN
27358  al=sfmix(ifl,1)
27359  bl=sfmix(ifl,2)
27360  ar=sfmix(ifl,3)
27361  br=sfmix(ifl,4)
27362 C...F1 -> F CHI
27363  IF(ilr.EQ.1) THEN
27364  ca=al
27365  cb=bl
27366 C...F2 -> F CHI
27367  ELSE
27368  ca=ar
27369  cb=br
27370  ENDIF
27371  lknt=lknt+1
27372  xma2=xmj**2
27373  xmb2=xmf**2
27374  xl=pylamf(xmi2,xma2,xmb2)
27375  xlam(lknt)=4d0/8d0*as/4d0/xmi3*sqrt(xl)*((xmi2+xmb2-xma2)*
27376  & (ca**2+cb**2)+4d0*ca*cb*xmi*xmf)
27377  idlam(lknt,1)=ilr*ksusy1+ifl
27378  idlam(lknt,2)=-ifl
27379  idlam(lknt,3)=0
27380  lknt=lknt+1
27381  xlam(lknt)=xlam(lknt-1)
27382  idlam(lknt,1)=-idlam(lknt-1,1)
27383  idlam(lknt,2)=-idlam(lknt-1,2)
27384  idlam(lknt,3)=0
27385  ENDIF
27386  100 CONTINUE
27387  110 CONTINUE
27388 
27389 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
27390 C...GLUINO -> NI Q QBAR
27391  DO 160 ix=1,4
27392  xmj=smz(ix)
27393  axmj=abs(xmj)
27394  IF(xmi.GE.axmj) THEN
27395  xxm(1)=0d0
27396  xxm(2)=xmj
27397  xxm(3)=0d0
27398  xxm(4)=xmi
27399  xxm(5)=pmas(pycomp(ksusy1+1),1)
27400  xxm(6)=pmas(pycomp(ksusy2+1),1)
27401  xxm(7)=1d6
27402  xxm(8)=0d0
27403  xxm(9)=0d0
27404  xxm(10)=0d0
27405  s12min=0d0
27406  s12max=(xmi-axmj)**2
27407 C...D-TYPE QUARKS
27408  xxm(11)=0d0
27409  xxm(12)=0d0
27410  xxm(13)=1d0
27411  xxm(14)=-sr2*(-0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
27412  xxm(15)=1d0
27413  xxm(16)=sr2*(-tanw*zmix(ix,1)/3d0)
27414  IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 120
27415  IF(xmi.GE.axmj+2d0*pmas(1,1)) THEN
27416  lknt=lknt+1
27417  xlam(lknt)=c1*as/xmi3/(16d0*pi)*
27418  & pygaus(pyxxz5,s12min,s12max,1d-2)
27419  idlam(lknt,1)=kfnchi(ix)
27420  idlam(lknt,2)=1
27421  idlam(lknt,3)=-1
27422  ENDIF
27423  IF(xmi.GE.axmj+2d0*pmas(3,1)) THEN
27424  lknt=lknt+1
27425  xlam(lknt)=xlam(lknt-1)
27426  idlam(lknt,1)=kfnchi(ix)
27427  idlam(lknt,2)=3
27428  idlam(lknt,3)=-3
27429  ENDIF
27430  120 CONTINUE
27431  IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 130
27432  IF(xmi.GE.axmj+2d0*pmas(5,1)) THEN
27433  CALL pytbbn(ix,80,-1d0/3d0,axmi,gam)
27434  lknt=lknt+1
27435  xlam(lknt)=gam
27436  idlam(lknt,1)=kfnchi(ix)
27437  idlam(lknt,2)=5
27438  idlam(lknt,3)=-5
27439  ENDIF
27440 C...U-TYPE QUARKS
27441  130 CONTINUE
27442  xxm(5)=pmas(pycomp(ksusy1+2),1)
27443  xxm(6)=pmas(pycomp(ksusy2+2),1)
27444  xxm(13)=1d0
27445  xxm(14)=-sr2*(0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
27446  xxm(15)=1d0
27447  xxm(16)=sr2*(2d0*tanw*zmix(ix,1)/3d0)
27448  IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 140
27449  IF(xmi.GE.axmj+2d0*pmas(2,1)) THEN
27450  lknt=lknt+1
27451  xlam(lknt)=c1*as/xmi3/(16d0*pi)*
27452  & pygaus(pyxxz5,s12min,s12max,1d-2)
27453  idlam(lknt,1)=kfnchi(ix)
27454  idlam(lknt,2)=2
27455  idlam(lknt,3)=-2
27456  ENDIF
27457  IF(xmi.GE.axmj+2d0*pmas(4,1)) THEN
27458  lknt=lknt+1
27459  xlam(lknt)=xlam(lknt-1)
27460  idlam(lknt,1)=kfnchi(ix)
27461  idlam(lknt,2)=4
27462  idlam(lknt,3)=-4
27463  ENDIF
27464  140 CONTINUE
27465 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
27466 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
27467  IF(xmi.GE.pmas(pycomp(ksusy1+6),1)+pmas(6,1)) goto 150
27468  xmf=pmas(6,1)
27469  IF(xmi.GE.axmj+2d0*xmf) THEN
27470  CALL pytbbn(ix,80,2d0/3d0,axmi,gam)
27471  lknt=lknt+1
27472  xlam(lknt)=gam
27473  idlam(lknt,1)=kfnchi(ix)
27474  idlam(lknt,2)=6
27475  idlam(lknt,3)=-6
27476  ENDIF
27477  150 CONTINUE
27478  ENDIF
27479  160 CONTINUE
27480 
27481 C...GLUINO -> CI Q QBAR'
27482  DO 190 ix=1,2
27483  xmj=smw(ix)
27484  axmj=abs(xmj)
27485  IF(xmi.GE.axmj) THEN
27486  s12min=0d0
27487  s12max=(axmi-axmj)**2
27488  xxm(1)=0d0
27489  xxm(2)=xmj
27490  xxm(3)=0d0
27491  xxm(4)=xmi
27492  xxm(5)=0d0
27493  xxm(6)=0d0
27494  xxm(9)=1d6
27495  xxm(10)=0d0
27496  xxm(7)=umix(ix,1)*sr2
27497  xxm(8)=vmix(ix,1)*sr2
27498  xxm(11)=pmas(pycomp(ksusy1+1),1)
27499  xxm(12)=pmas(pycomp(ksusy1+2),1)
27500  IF( xxm(11).LT.axmi .OR. xxm(12).LT.axmi ) goto 170
27501  IF(xmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
27502  lknt=lknt+1
27503  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
27504  & pygaus(pyxxw5,s12min,s12max,prec)
27505  idlam(lknt,1)=kfcchi(ix)
27506  idlam(lknt,2)=1
27507  idlam(lknt,3)=-2
27508  lknt=lknt+1
27509  xlam(lknt)=xlam(lknt-1)
27510  idlam(lknt,1)=-idlam(lknt-1,1)
27511  idlam(lknt,2)=-idlam(lknt-1,2)
27512  idlam(lknt,3)=-idlam(lknt-1,3)
27513  ENDIF
27514  IF(xmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
27515  lknt=lknt+1
27516  xlam(lknt)=xlam(lknt-1)
27517  idlam(lknt,1)=kfcchi(ix)
27518  idlam(lknt,2)=3
27519  idlam(lknt,3)=-4
27520  lknt=lknt+1
27521  xlam(lknt)=xlam(lknt-1)
27522  idlam(lknt,1)=-idlam(lknt-1,1)
27523  idlam(lknt,2)=-idlam(lknt-1,2)
27524  idlam(lknt,3)=-idlam(lknt-1,3)
27525  ENDIF
27526  170 CONTINUE
27527 
27528  IF(xmi.GE.pmas(pycomp(ksusy1+5),1)+pmas(5,1)) goto 180
27529  IF(xmi.GE.pmas(pycomp(ksusy1+6),1)+pmas(6,1)) goto 180
27530  xmf=pmas(6,1)
27531  xmfp=pmas(5,1)
27532  IF(xmi.GE.axmj+xmf+xmfp) THEN
27533  CALL pytbbc(ix,80,axmi,gam)
27534  lknt=lknt+1
27535  xlam(lknt)=gam
27536  idlam(lknt,1)=kfcchi(ix)
27537  idlam(lknt,2)=5
27538  idlam(lknt,3)=-6
27539  lknt=lknt+1
27540  xlam(lknt)=xlam(lknt-1)
27541  idlam(lknt,1)=-idlam(lknt-1,1)
27542  idlam(lknt,2)=-idlam(lknt-1,2)
27543  idlam(lknt,3)=-idlam(lknt-1,3)
27544  ENDIF
27545  180 CONTINUE
27546  ENDIF
27547  190 CONTINUE
27548 
27549  iknt=lknt
27550  xlam(0)=0d0
27551  DO 200 i=1,iknt
27552  IF(xlam(i).LT.0d0) xlam(i)=0d0
27553  xlam(0)=xlam(0)+xlam(i)
27554  200 CONTINUE
27555  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
27556 
27557  RETURN
27558  END
27559 
27560 C*********************************************************************
27561 
27562 C...PYTBBN
27563 C...Calculates the three-body decay of gluinos into
27564 C...neutralinos and third generation fermions.
27565 
27566  SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)
27567 
27568 C...Double precision and integer declarations.
27569  IMPLICIT DOUBLE PRECISION(a-h, o-z)
27570  INTEGER pyk,pychge,pycomp
27571 C...Parameter statement to help give large particle numbers.
27572  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
27573 C...Commonblocks.
27574  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27575  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27576  common/pymssm/imss(0:99),rmss(0:99)
27577  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
27578  &sfmix(16,4)
27579  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
27580 
27581 C...Local variables.
27582  EXTERNAL pysimp,pylamf
27583  INTEGER lin,nn
27584  DOUBLE PRECISION cosd,sind,cosd2,sind2,cos2d,sin2d
27585  DOUBLE PRECISION hl,hr,fl,fr,hl2,hr2,fl2,fr2
27586  DOUBLE PRECISION xms2(2),xm,xm2,xmg,xmg2,xmr,xmr2
27587  DOUBLE PRECISION sbar,smin,smax,xmqa,w,grs,g(0:6),summe(0:100)
27588  DOUBLE PRECISION ff,hh,hfl,hfr,hrfl,hlfr,xmq4,xm24
27589  DOUBLE PRECISION xln1,xln2,b1,b2
27590  DOUBLE PRECISION e,xmglu,gam
27591  DOUBLE PRECISION pysimp,pylamf
27592  DOUBLE PRECISION hrb(4),hlb(4),flb(4),frb(4)
27593  SAVE hrb,hlb,flb,frb
27594  DOUBLE PRECISION alphaw,alphas,gsu2
27595  DOUBLE PRECISION hlt(4),hrt(4),flt(4),frt(4)
27596  SAVE hlt,hrt,flt,frt
27597  DOUBLE PRECISION amc(2),amn(4),an(4,4),zn(3),flu(4),fru(4),
27598  &fld(4),frd(4)
27599  SAVE amc,amn,an,zn,flu,fru,fld,frd
27600  DOUBLE PRECISION ambot,amsb(2),sinc,cosc
27601  DOUBLE PRECISION amtop,amst(2),sina,cosa
27602  SAVE amsb,amst
27603  DOUBLE PRECISION sinw,cosw,tanw,cosw2,sinw2
27604  DOUBLE PRECISION rot1(4,4)
27605  LOGICAL ifirst
27606  SAVE ifirst
27607  DATA ifirst/.true./
27608 
27609  tanb=rmss(5)
27610  sinb=tanb/sqrt(1d0+tanb**2)
27611  cosb=sinb/tanb
27612  xw=paru(102)
27613  sinw=sqrt(xw)
27614  cosw=sqrt(1d0-xw)
27615  tanw=sinw/cosw
27616  amw=pmas(24,1)
27617  cosc=sfmix(5,1)
27618  sinc=sfmix(5,3)
27619  cosa=sfmix(6,1)
27620  sina=sfmix(6,3)
27621  ambot=0d0
27622  amtop=pyrnmt(pmas(6,1))
27623  w2=sqrt(2d0)
27624  fakt1=ambot/w2/amw/cosb
27625  fakt2=amtop/w2/amw/sinb
27626  IF(ifirst) THEN
27627  DO 110 ii=1,4
27628  amn(ii)=smz(ii)
27629  DO 100 j=1,4
27630  rot1(ii,j)=0d0
27631  an(ii,j)=0d0
27632  100 CONTINUE
27633  110 CONTINUE
27634  rot1(1,1)=cosw
27635  rot1(1,2)=-sinw
27636  rot1(2,1)=-rot1(1,2)
27637  rot1(2,2)=rot1(1,1)
27638  rot1(3,3)=cosb
27639  rot1(3,4)=sinb
27640  rot1(4,3)=-rot1(3,4)
27641  rot1(4,4)=rot1(3,3)
27642  DO 140 ii=1,4
27643  DO 130 j=1,4
27644  DO 120 jj=1,4
27645  an(ii,j)=an(ii,j)+zmix(ii,jj)*rot1(jj,j)
27646  120 CONTINUE
27647  130 CONTINUE
27648  140 CONTINUE
27649  DO 150 j=1,4
27650  zn(1)=-fakt2*(-sinb*an(j,3)+cosb*an(j,4))
27651  zn(2)=-2d0*w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
27652  zn(3)=-2*w2/3d0*sinw*an(j,1)-w2*(0.5d0-2d0/3d0*
27653  & xw)*an(j,2)/cosw
27654  hrt(j)=zn(1)*cosa-zn(3)*sina
27655  hlt(j)=zn(1)*cosa+zn(2)*sina
27656  flt(j)=zn(3)*cosa+zn(1)*sina
27657  frt(j)=zn(2)*cosa-zn(1)*sina
27658  flu(j)=zn(3)
27659  fru(j)=zn(2)
27660  zn(1)=-fakt1*(cosb*an(j,3)+sinb*an(j,4))
27661  zn(2)=w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
27662  zn(3)=w2/3d0*sinw*an(j,1)+w2*(0.5d0-xw/3d0)*an(j,2)/cosw
27663  hrb(j)=zn(1)*cosc-zn(3)*sinc
27664  hlb(j)=zn(1)*cosc+zn(2)*sinc
27665  flb(j)=zn(3)*cosc+zn(1)*sinc
27666  frb(j)=zn(2)*cosc-zn(1)*sinc
27667  fld(j)=zn(3)
27668  frd(j)=zn(2)
27669  150 CONTINUE
27670  amst(1)=pmas(pycomp(ksusy1+6),1)
27671  amst(2)=pmas(pycomp(ksusy2+6),1)
27672  amsb(1)=pmas(pycomp(ksusy1+5),1)
27673  amsb(2)=pmas(pycomp(ksusy2+5),1)
27674  ifirst=.false.
27675  ENDIF
27676 
27677  IF(nint(3d0*e).EQ.2) THEN
27678  hl=hlt(i)
27679  hr=hrt(i)
27680  fl=flt(i)
27681  fr=frt(i)
27682  cosd=sfmix(6,1)
27683  sind=sfmix(6,3)
27684  xms2(1)=pmas(pycomp(ksusy1+6),1)**2
27685  xms2(2)=pmas(pycomp(ksusy2+6),1)**2
27686  xm=pmas(6,1)
27687  ELSE
27688  hl=hlb(i)
27689  hr=hrb(i)
27690  fl=flb(i)
27691  fr=frb(i)
27692  cosd=sfmix(5,1)
27693  sind=sfmix(5,3)
27694  xms2(1)=pmas(pycomp(ksusy1+5),1)**2
27695  xms2(2)=pmas(pycomp(ksusy2+5),1)**2
27696  xm=pmas(5,1)
27697  ENDIF
27698  cosd2=cosd*cosd
27699  sind2=sind*sind
27700  cos2d=cosd2-sind2
27701  sin2d=sind*cosd*2d0
27702  hl2=hl*hl
27703  hr2=hr*hr
27704  fl2=fl*fl
27705  fr2=fr*fr
27706  ff=fl*fr
27707  hh=hl*hr
27708  hfl=hl*fl
27709  hfr=hr*fr
27710  hrfl=hr*fl
27711  hlfr=hl*fr
27712  xm2=xm*xm
27713  xmg=xmglu
27714  xmg2=xmg*xmg
27715  alphaw=pyalem(xmg2)
27716  alphas=pyalps(xmg2)
27717  xmr=amn(i)
27718  xmr2=xmr*xmr
27719  xmq4=xmg*xm2*xmr
27720  xm24=(xmg2+xm2)*(xm2+xmr2)
27721  smin=4d0*xm2
27722  smax=(xmg-abs(xmr))**2
27723  xmqa=xmg2+2d0*xm2+xmr2
27724  DO 170 lin=1,nn-1
27725  sbar=smin+dble(lin)*(smax-smin)/dble(nn)
27726  grs=sbar-xmqa
27727  w=pylamf(xmg2,xmr2,sbar)*(0.25d0-xm2/sbar)
27728  w=dsqrt(w)
27729  xln1=log(abs((grs/2d0+xms2(1)-w)/(grs/2d0+xms2(1)+w)))
27730  xln2=log(abs((grs/2d0+xms2(2)-w)/(grs/2d0+xms2(2)+w)))
27731  b1=1d0/(grs/2d0+xms2(1)-w)-1d0/(grs/2d0+xms2(1)+w)
27732  b2=1d0/(grs/2d0+xms2(2)-w)-1d0/(grs/2d0+xms2(2)+w)
27733  g(0)=-2d0*(hl2+fl2+hr2+fr2+(hfr-hfl)*sin2d
27734  & +2d0*(ff*sind2-hh*cosd2))*w
27735  g(1)=((hl2+fl2)*(xmqa-2d0*xms2(1)-2d0*xm*xmg*sin2d)
27736  & +4d0*hfl*xm*xmr)*xln1
27737  & +((hl2+fl2)*((xmqa-xms2(1))*xms2(1)-xm24
27738  & +2d0*xm*xmg*(xm2+xmr2-xms2(1))*sin2d)
27739  & -4d0*hfl*xmr*xm*(xmg2+xm2-xms2(1))
27740  & +8d0*hfl*xmq4*sin2d)*b1
27741  g(2)=((hr2+fr2)*(xmqa-2d0*xms2(2)+2d0*xm*xmg*sin2d)
27742  & +4d0*hfr*xmr*xm)*xln2
27743  & +((hr2+fr2)*((xmqa-xms2(2))*xms2(2)-xm24
27744  & +2d0*xmg*xm*sin2d*(xms2(2)-xm2-xmr2))
27745  & +4d0*hfr*xm*xmr*(xms2(2)-xmg2-xm2)
27746  & -8d0*hfr*xmq4*sin2d)*b2
27747  g(3)=(2d0*hfl*sin2d*(xms2(1)*(grs+xms2(1))+xm2*(sbar-xmg2-xmr2)
27748  & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hl2*sind2+fl2*cosd2)*sbar
27749  & -2d0*xmg*xm*hfl*(sbar+xmr2-xmg2)
27750  & +xmr*xm*(hl2+fl2)*sin2d*(sbar+xmg2-xmr2)
27751  & -4d0*xmq4*(hl2-fl2)*cos2d)/(grs+2d0*xms2(1))*xln1
27752  g(4)=4d0*cos2d*xm*xmg/(xms2(1)-xms2(2))*
27753  & (((hlfr+hrfl)*(xm2+xmr2)+2d0*xm*xmr*(hh+ff))*(xln1-xln2)
27754  & +(hlfr+hrfl)*(xms2(2)*xln2-xms2(1)*xln1))
27755  g(5)=(2d0*(hh*cosd2-ff*sind2)
27756  & *((xms2(2)*(xms2(2)+grs)+xm2*xm2+xmg2*xmr2)*xln2
27757  & +(xms2(1)*(xms2(1)+grs)+xm2*xm2+xmg2*xmr2)*xln1)
27758  & +xm*((hh-ff)*sin2d*xmg-(hrfl-hlfr)*xmr)
27759  & *((grs+xms2(1)*2d0)*xln1-(grs+xms2(2)*2d0)*xln2)
27760  & +((hrfl-hlfr)*xmr*(sin2d*xmg*(sbar-4d0*xm2)
27761  & +cos2d*xm*(sbar+xmg2-xmr2))
27762  & +2d0*(ff*cosd2-hh*sind2)*xm2*(sbar-xmg2-xmr2))
27763  & *(xln1+xln2))/(grs+xms2(1)+xms2(2))
27764  g(6)=(-2d0*hfr*sin2d*(xms2(2)*(grs+xms2(2))+xm2*(sbar-xmg2-xmr2)
27765  & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hr2*sind2+fr2*cosd2)*sbar
27766  & -2d0*xmg*xm*hfr*(sbar+xmr2-xmg2)
27767  & -xmr*xm*(hr2+fr2)*sin2d*(sbar+xmg2-xmr2)
27768  & -4d0*xmq4*(hr2-fr2)*cos2d)/(grs+2d0*xms2(2))*xln2
27769  summe(lin)=0d0
27770  DO 160 j=0,6
27771  summe(lin)=summe(lin)+g(j)
27772  160 CONTINUE
27773  170 CONTINUE
27774  summe(0)=0d0
27775  summe(nn)=0d0
27776  gam = alphaw * alphas * pysimp(summe,smin,smax,nn)
27777  &/ (16d0 * paru(1) * paru(102) * xmglu**3)
27778 
27779  RETURN
27780  END
27781 
27782 C*********************************************************************
27783 
27784 C...PYTBBC
27785 C...Calculates the three-body decay of gluinos into
27786 C...charginos and third generation fermions.
27787 
27788  SUBROUTINE pytbbc(I,NN,XMGLU,GAM)
27789 
27790 C...Double precision and integer declarations.
27791  IMPLICIT DOUBLE PRECISION(a-h, o-z)
27792  INTEGER pyk,pychge,pycomp
27793 C...Parameter statement to help give large particle numbers.
27794  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
27795 C...Commonblocks.
27796  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27797  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27798  common/pymssm/imss(0:99),rmss(0:99)
27799  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
27800  &sfmix(16,4)
27801  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
27802 
27803 C...Local variables.
27804  EXTERNAL pysimp,pylamf
27805  INTEGER i,nn,lin
27806  DOUBLE PRECISION xmg,xmg2,xmb,xmb2,xmr,xmr2
27807  DOUBLE PRECISION xmt,xmt2,xmst(4),xmsb(4)
27808  DOUBLE PRECISION ulr(2),vlr(2),xmq2,xmq4,am,w,sbar,smin,smax
27809  DOUBLE PRECISION summe(0:100),a(4,8)
27810  DOUBLE PRECISION cos2a,sin2a,cos2c,sin2c
27811  DOUBLE PRECISION grs,xmq3,xmgbtr,xmgtbr,ant1,ant2,anb1,anb2
27812  DOUBLE PRECISION xmglu,gam
27813  DOUBLE PRECISION pysimp,pylamf
27814  DOUBLE PRECISION xx1(2),xx2(2),aaa(2),bbb(2),ccc(2),
27815  &ddd(2),eee(2),fff(2)
27816  SAVE xx1,xx2,aaa,bbb,ccc,ddd,eee,fff
27817  DOUBLE PRECISION alphaw,alphas,gsu2
27818  DOUBLE PRECISION amc(2),amn(4)
27819  SAVE amc,amn
27820  DOUBLE PRECISION ambot,amsb(2),sinc,cosc
27821  DOUBLE PRECISION amtop,amst(2),sina,cosa
27822  SAVE amsb,amst
27823  DOUBLE PRECISION sinw,cosw,tanw,cosw2,sinw2
27824  LOGICAL ifirst
27825  SAVE ifirst
27826  DATA ifirst/.true./
27827 
27828  tanb=rmss(5)
27829  sinb=tanb/sqrt(1d0+tanb**2)
27830  cosb=sinb/tanb
27831  xw=paru(102)
27832  sinw=sqrt(xw)
27833  cosw=sqrt(1d0-xw)
27834  amw=pmas(24,1)
27835  cosc=sfmix(5,1)
27836  sinc=sfmix(5,3)
27837  cosa=sfmix(6,1)
27838  sina=sfmix(6,3)
27839  ambot=0d0
27840  amtop=pyrnmt(pmas(6,1))
27841  w2=sqrt(2d0)
27842  amw=pmas(24,1)
27843  fakt1=ambot/w2/amw/cosb
27844  fakt2=amtop/w2/amw/sinb
27845  IF(ifirst) THEN
27846  amc(1)=smw(1)
27847  amc(2)=smw(2)
27848  DO 100 jj=1,2
27849  ccc(jj)=fakt1*umix(jj,2)*sinc-umix(jj,1)*cosc
27850  eee(jj)=fakt2*vmix(jj,2)*cosc
27851  ddd(jj)=fakt1*umix(jj,2)*cosc+umix(jj,1)*sinc
27852  fff(jj)=fakt2*vmix(jj,2)*sinc
27853  xx1(jj)=fakt2*vmix(jj,2)*sina-vmix(jj,1)*cosa
27854  aaa(jj)=fakt1*umix(jj,2)*cosa
27855  xx2(jj)=fakt2*vmix(jj,2)*cosa+vmix(jj,1)*sina
27856  bbb(jj)=fakt1*umix(jj,2)*sina
27857  100 CONTINUE
27858  amst(1)=pmas(pycomp(ksusy1+6),1)
27859  amst(2)=pmas(pycomp(ksusy2+6),1)
27860  amsb(1)=pmas(pycomp(ksusy1+5),1)
27861  amsb(2)=pmas(pycomp(ksusy2+5),1)
27862  ifirst=.false.
27863  ENDIF
27864  amtop=pmas(6,1)
27865 
27866  ulr(1)=xx1(i)*xx1(i)+aaa(i)*aaa(i)
27867  ulr(2)=xx2(i)*xx2(i)+bbb(i)*bbb(i)
27868  vlr(1)=ccc(i)*ccc(i)+eee(i)*eee(i)
27869  vlr(2)=ddd(i)*ddd(i)+fff(i)*fff(i)
27870 
27871  cos2a=cosa**2-sina**2
27872  sin2a=sina*cosa*2d0
27873  cos2c=cosc**2-sinc**2
27874  sin2c=sinc*cosc*2d0
27875 
27876  xmg=xmglu
27877  xmt=amtop
27878  xmb=0d0
27879  xmr=amc(i)
27880  xmg2=xmg*xmg
27881  alphaw=pyalem(xmg2)
27882  alphas=pyalps(xmg2)
27883  xmt2=xmt*xmt
27884  xmb2=xmb*xmb
27885  xmr2=xmr*xmr
27886  xmq2=xmg2+xmt2+xmb2+xmr2
27887  xmq4=xmg*xmt*xmb*xmr
27888  xmq3=xmg2*xmr2+xmt2*xmb2
27889  xmgbtr=(xmg2+xmb2)*(xmt2+xmr2)
27890  xmgtbr=(xmg2+xmt2)*(xmb2+xmr2)
27891 
27892  xmst(1)=amst(1)*amst(1)
27893  xmst(2)=amst(1)*amst(1)
27894  xmst(3)=amst(2)*amst(2)
27895  xmst(4)=amst(2)*amst(2)
27896  xmsb(1)=amsb(1)*amsb(1)
27897  xmsb(2)=amsb(2)*amsb(2)
27898  xmsb(3)=amsb(1)*amsb(1)
27899  xmsb(4)=amsb(2)*amsb(2)
27900 
27901  a(1,1)=-cosa*sinc*ccc(i)*aaa(i)-sina*cosc*eee(i)*xx1(i)
27902  a(1,2)=xmg*xmb*(cosa*cosc*ccc(i)*aaa(i)+sina*sinc*eee(i)*xx1(i))
27903  a(1,3)=-xmg*xmr*(cosa*cosc*ccc(i)*xx1(i)+sina*sinc*eee(i)*aaa(i))
27904  a(1,4)=xmb*xmr*(cosa*sinc*ccc(i)*xx1(i)+sina*cosc*eee(i)*aaa(i))
27905  a(1,5)=xmg*xmt*(cosa*cosc*eee(i)*xx1(i)+sina*sinc*ccc(i)*aaa(i))
27906  a(1,6)=-xmt*xmb*(cosa*sinc*eee(i)*xx1(i)+sina*cosc*ccc(i)*aaa(i))
27907  a(1,7)=xmt*xmr*(cosa*sinc*eee(i)*aaa(i)+sina*cosc*ccc(i)*xx1(i))
27908  a(1,8)=-xmq4*(cosa*cosc*eee(i)*aaa(i)+sina*sinc*ccc(i)*xx1(i))
27909 
27910  a(2,1)=-cosa*cosc*ddd(i)*aaa(i)-sina*sinc*fff(i)*xx1(i)
27911  a(2,2)=-xmg*xmb*(cosa*sinc*ddd(i)*aaa(i)+sina*cosc*fff(i)*xx1(i))
27912  a(2,3)=xmg*xmr*(cosa*sinc*ddd(i)*xx1(i)+sina*cosc*fff(i)*aaa(i))
27913  a(2,4)=xmb*xmr*(cosa*cosc*ddd(i)*xx1(i)+sina*sinc*fff(i)*aaa(i))
27914  a(2,5)=xmg*xmt*(cosa*sinc*fff(i)*xx1(i)+sina*cosc*ddd(i)*aaa(i))
27915  a(2,6)=xmt*xmb*(cosa*cosc*fff(i)*xx1(i)+sina*sinc*ddd(i)*aaa(i))
27916  a(2,7)=-xmt*xmr*(cosa*cosc*fff(i)*aaa(i)+sina*sinc*ddd(i)*xx1(i))
27917  a(2,8)=-xmq4*(cosa*sinc*fff(i)*aaa(i)+sina*cosc*ddd(i)*xx1(i))
27918 
27919  a(3,1)=-cosa*cosc*eee(i)*xx2(i)-sina*sinc*ccc(i)*bbb(i)
27920  a(3,2)=xmg*xmb*(cosa*sinc*eee(i)*xx2(i)+sina*cosc*ccc(i)*bbb(i))
27921  a(3,3)=xmg*xmr*(cosa*sinc*eee(i)*bbb(i)+sina*cosc*ccc(i)*xx2(i))
27922  a(3,4)=-xmb*xmr*(cosa*cosc*eee(i)*bbb(i)+sina*sinc*ccc(i)*xx2(i))
27923  a(3,5)=-xmg*xmt*(cosa*sinc*ccc(i)*bbb(i)+sina*cosc*eee(i)*xx2(i))
27924  a(3,6)=xmt*xmb*(cosa*cosc*ccc(i)*bbb(i)+sina*sinc*eee(i)*xx2(i))
27925  a(3,7)=xmt*xmr*(cosa*cosc*ccc(i)*xx2(i)+sina*sinc*eee(i)*bbb(i))
27926  a(3,8)=-xmq4*(cosa*sinc*ccc(i)*xx2(i)+sina*cosc*eee(i)*bbb(i))
27927 
27928  a(4,1)=-cosa*sinc*fff(i)*xx2(i)-sina*cosc*ddd(i)*bbb(i)
27929  a(4,2)=-xmg*xmb*(cosa*cosc*fff(i)*xx2(i)+sina*sinc*ddd(i)*bbb(i))
27930  a(4,3)=-xmg*xmr*(cosa*cosc*fff(i)*bbb(i)+sina*sinc*ddd(i)*xx2(i))
27931  a(4,4)=-xmb*xmr*(cosa*sinc*fff(i)*bbb(i)+sina*cosc*ddd(i)*xx2(i))
27932  a(4,5)=-xmg*xmt*(cosa*cosc*ddd(i)*bbb(i)+sina*sinc*fff(i)*xx2(i))
27933  a(4,6)=-xmt*xmb*(cosa*sinc*ddd(i)*bbb(i)+sina*cosc*fff(i)*xx2(i))
27934  a(4,7)=-xmt*xmr*(cosa*sinc*ddd(i)*xx2(i)+sina*cosc*fff(i)*bbb(i))
27935  a(4,8)=-xmq4*(cosa*cosc*ddd(i)*xx2(i)+sina*sinc*fff(i)*bbb(i))
27936 
27937  smax=(xmg-abs(xmr))**2
27938  smin=(xmb+xmt)**2+0.1d0
27939 
27940  DO 120 lin=0,nn-1
27941  sbar=smin+dble(lin)*(smax-smin)/dble(nn)
27942  am=(xmg2-xmr2)*(xmt2-xmb2)/2d0/sbar
27943  grs=sbar-xmq2
27944  w=pylamf(sbar,xmb2,xmt2)*pylamf(sbar,xmg2,xmr2)
27945  w=dsqrt(w)/2d0/sbar
27946  ant1=log(abs((grs/2d0+am+xmst(1)-w)/(grs/2d0+am+xmst(1)+w)))
27947  ant2=log(abs((grs/2d0+am+xmst(3)-w)/(grs/2d0+am+xmst(3)+w)))
27948  anb1=log(abs((grs/2d0-am+xmsb(1)-w)/(grs/2d0-am+xmsb(1)+w)))
27949  anb2=log(abs((grs/2d0-am+xmsb(2)-w)/(grs/2d0-am+xmsb(2)+w)))
27950  summe(lin)=-ulr(1)*w+(ulr(1)*(xmq2/2d0-xmst(1)-xmg*xmt*sin2a)
27951  & +2d0*xx1(i)*aaa(i)*xmr*xmb)*ant1
27952  & +(ulr(1)/2d0*(xmst(1)*(xmq2-xmst(1))-xmgtbr
27953  & -2d0*xmg*xmt*sin2a*(xmst(1)-xmb2-xmr2))
27954  & +2d0*xx1(i)*aaa(i)*xmr*xmb*(xmst(1)-xmg2-xmt2)
27955  & +4d0*sin2a*xx1(i)*aaa(i)*xmq4)
27956  & *(1d0/(grs/2d0+am+xmst(1)-w)-1d0/(grs/2d0+am+xmst(1)+w))
27957  summe(lin)=summe(lin)-ulr(2)*w
27958  & +(ulr(2)*(xmq2/2d0-xmst(3)+xmg*xmt*sin2a)
27959  & -2d0*xx2(i)*bbb(i)*xmr*xmb)*ant2
27960  & +(ulr(2)/2d0*(xmst(3)*(xmq2-xmst(3))-xmgtbr
27961  & +2d0*xmg*xmt*sin2a*(xmst(3)-xmb2-xmr2))
27962  & -2d0*xx2(i)*bbb(i)*xmr*xmb*(xmst(3)-xmg2-xmt2)
27963  & +4d0*sin2a*xx2(i)*bbb(i)*xmq4)
27964  & *(1d0/(grs/2d0+am+xmst(3)-w)-1d0/(grs/2d0+am+xmst(3)+w))
27965  summe(lin)=summe(lin)-vlr(1)*w
27966  & +(vlr(1)*(xmq2/2d0-xmsb(1)-xmg*xmb*sin2c)
27967  & +2d0*ccc(i)*eee(i)*xmr*xmt)*anb1
27968  & +(vlr(1)/2d0*(xmsb(1)*(xmq2-xmsb(1))-xmgbtr
27969  & -2d0*xmg*xmb*sin2c*(xmsb(1)-xmt2-xmr2))
27970  & +2d0*ccc(i)*eee(i)*xmr*xmt*(xmsb(1)-xmg2-xmb2)
27971  & +4d0*sin2c*ccc(i)*eee(i)*xmq4)
27972  & *(1d0/(grs/2d0-am+xmsb(1)-w)-1d0/(grs/2d0-am+xmsb(1)+w))
27973  summe(lin)=summe(lin)-vlr(2)*w
27974  & +(vlr(2)*(xmq2/2d0-xmsb(2)+xmg*xmb*sin2c)
27975  & -2d0*ddd(i)*fff(i)*xmr*xmt)*anb2
27976  & +(vlr(2)/2d0*(xmsb(2)*(xmq2-xmsb(2))-xmgbtr
27977  & +2d0*xmg*xmb*sin2c*(xmsb(2)-xmt2-xmr2))
27978  & -2d0*ddd(i)*fff(i)*xmr*xmt*(xmsb(2)-xmg2-xmb2)
27979  & +4d0*sin2c*ddd(i)*fff(i)*xmq4)
27980  & *(1d0/(grs/2d0-am+xmsb(2)-w)-1d0/(grs/2d0-am+xmsb(2)+w))
27981  summe(lin)=summe(lin)+2d0*xmg*xmt*cos2a/(xmst(3)-xmst(1))
27982  & *((aaa(i)*bbb(i)-xx1(i)*xx2(i))
27983  & *((xmst(3)-xmb2-xmr2)*ant2-(xmst(1)-xmb2-xmr2)*ant1)
27984  & +2d0*(aaa(i)*xx2(i)-xx1(i)*bbb(i))*xmb*xmr*(ant2-ant1))
27985  summe(lin)=summe(lin)+2d0*xmg*xmb*cos2c/(xmsb(2)-xmsb(1))
27986  & *((eee(i)*fff(i)-ccc(i)*ddd(i))
27987  & *((xmsb(2)-xmt2-xmr2)*anb2-(xmsb(1)-xmt2-xmr2)*anb1)
27988  & +2d0*(eee(i)*ddd(i)-ccc(i)*fff(i))*xmt*xmr*(anb2-anb1))
27989  DO 110 j=1,4
27990  summe(lin)=summe(lin)-2d0*a(j,1)*w
27991  & +((-a(j,1)*(xmsb(j)*(grs+xmsb(j))+xmq3)
27992  & +a(j,2)*(xmsb(j)-xmt2-xmr2)+a(j,3)*(sbar-xmb2-xmt2)
27993  & +a(j,4)*(xmsb(j)+sbar-xmb2-xmr2)
27994  & -a(j,5)*(xmsb(j)+sbar-xmg2-xmt2)+a(j,6)*(xmg2+xmr2-sbar)
27995  & -a(j,7)*(xmsb(j)-xmg2-xmb2)+2d0*a(j,8))
27996  & *log(abs((grs/2d0+xmsb(j)-am-w)/(grs/2d0+xmsb(j)-am+w)))
27997  & -(a(j,1)*(xmst(j)*(grs+xmst(j))+xmq3)
27998  & +a(j,2)*(xmst(j)+sbar-xmg2-xmb2)-a(j,3)*(sbar-xmb2-xmt2)
27999  & +a(j,4)*(xmst(j)-xmg2-xmt2)-a(j,5)*(xmst(j)-xmr2-xmb2)
28000  & -a(j,6)*(xmg2+xmr2-sbar)
28001  & -a(j,7)*(xmst(j)+sbar-xmt2-xmr2)-2d0*a(j,8))
28002  & *log(abs((grs/2d0+xmst(j)+am-w)/(grs/2d0+xmst(j)+am+w))))
28003  & /(grs+xmsb(j)+xmst(j))
28004  110 CONTINUE
28005  120 CONTINUE
28006  summe(nn)=0d0
28007  gam= alphaw * alphas * pysimp(summe,smin,smax,nn)
28008  &/ (16d0 * paru(1) * paru(102) * xmglu**3)
28009 
28010  RETURN
28011  END
28012 
28013 C*********************************************************************
28014 
28015 C...PYNJDC
28016 C...Calculates decay widths for the neutralinos (admixtures of
28017 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
28018 
28019 C...Input: KCIN = KF code for particle
28020 C...Output: XLAM = widths
28021 C... IDLAM = KF codes for decay particles
28022 C... IKNT = number of decay channels defined
28023 C...AUTHOR: STEPHEN MRENNA
28024 C...Last change:
28025 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
28026 C...when CHIGAMMA .NE. 0
28027 C...10 FEB 96: Calculate this decay for small tan(beta)
28028 
28029  SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)
28030 
28031 C...Double precision and integer declarations.
28032  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28033  INTEGER pyk,pychge,pycomp
28034 C...Parameter statement to help give large particle numbers.
28035  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
28036 C...Commonblocks.
28037  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28038  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28039  common/pymssm/imss(0:99),rmss(0:99)
28040  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
28041  &sfmix(16,4)
28042  common/pyints/xxm(20)
28043  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/
28044 
28045 C...Local variables.
28046  INTEGER kfin,kcin
28047  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,
28048  &xmz,xmz2,axmj,axmi
28049  DOUBLE PRECISION xmfp,xmf1,xmf2,xmsl,xmg,xmk
28050  DOUBLE PRECISION s12min,s12max
28051  DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xmhp2,xma2,xmb2
28052  DOUBLE PRECISION pylamf,xl,qij,rij
28053  DOUBLE PRECISION tanw,xw,aem,c1,as,ei,t3
28054  DOUBLE PRECISION pyx2xh,pyx2xg
28055  DOUBLE PRECISION xlam(0:200)
28056  INTEGER idlam(200,3)
28057  INTEGER lknt,ix,ih,j,ij,i,iknt,fid
28058  INTEGER ith(3),kf1,kf2
28059  INTEGER ithc
28060  DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)
28061  DOUBLE PRECISION sr2
28062  DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k
28063  DOUBLE PRECISION gamcon,xmt1,xmt2
28064  DOUBLE PRECISION pyalem,pi,pyalps
28065  DOUBLE PRECISION al,bl,ar,br,alp,arp,blp,brp
28066  DOUBLE PRECISION rat1,rat2
28067  DOUBLE PRECISION t3t,ca,cb,fcol
28068  DOUBLE PRECISION alfa,beta,tanb
28069  DOUBLE PRECISION pygaus,pyxxga
28070  EXTERNAL pyxxw5,pygaus,pyxxz5
28071  DOUBLE PRECISION prec
28072  INTEGER kfnchi(4),kfcchi(2)
28073  DATA etah/1d0,1d0,-1d0/
28074  DATA ith/25,35,36/
28075  DATA ithc/37/
28076  DATA prec/1d-2/
28077  DATA pi/3.141592654d0/
28078  DATA sr2/1.4142136d0/
28079  DATA kfnchi/1000022,1000023,1000025,1000035/
28080  DATA kfcchi/1000024,1000037/
28081 
28082 C...COUNT THE NUMBER OF DECAY MODES
28083  lknt=0
28084 
28085  xmw=pmas(24,1)
28086  xmw2=xmw**2
28087  xmz=pmas(23,1)
28088  xmz2=xmz**2
28089  xw=1d0-xmw2/xmz2
28090  tanw = sqrt(xw/(1d0-xw))
28091 
28092 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
28093  kcin=pycomp(kfin)
28094  ix=1
28095  IF(kfin.EQ.kfnchi(2)) ix=2
28096  IF(kfin.EQ.kfnchi(3)) ix=3
28097  IF(kfin.EQ.kfnchi(4)) ix=4
28098 
28099  xmi=smz(ix)
28100  xmi2=xmi**2
28101  axmi=abs(xmi)
28102  aem=pyalem(xmi2)
28103  as =pyalps(xmi2)
28104  c1=aem/xw
28105  xmi3=abs(xmi**3)
28106 
28107  tanb=rmss(5)
28108  beta=atan(tanb)
28109  alfa=rmss(18)
28110  cbeta=cos(beta)
28111  sbeta=tanb*cbeta
28112  calfa=cos(alfa)
28113  salfa=sin(alfa)
28114 
28115 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28116  IF(ix.EQ.1.AND.imss(11).EQ.0) THEN
28117  RETURN
28118  ENDIF
28119 
28120 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
28121  IF(ix.EQ.2 .AND. imss(10).NE.0 ) THEN
28122  xmj=smz(1)
28123  axmj=abs(xmj)
28124  lknt=lknt+1
28125  gamcon=aem**3/8d0/pi/xmw2/xw
28126  xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
28127  xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
28128  xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
28129  idlam(lknt,1)=ksusy1+22
28130  idlam(lknt,2)=22
28131  idlam(lknt,3)=0
28132  WRITE(mstu(11),*) 'FORCED N2 -> N1 + GAMMA ',xlam(lknt)
28133  goto 290
28134  ENDIF
28135 
28136 C...GRAVITINO DECAY MODES
28137 
28138  IF(imss(11).EQ.1) THEN
28139  xmp=rmss(28)
28140  idg=39+ksusy1
28141  xmgr=pmas(pycomp(idg),1)
28142  sinw=sqrt(xw)
28143  cosw=sqrt(1d0-xw)
28144  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
28145  IF(axmi.GT.xmgr+pmas(22,1)) THEN
28146  lknt=lknt+1
28147  idlam(lknt,1)=idg
28148  idlam(lknt,2)=22
28149  idlam(lknt,3)=0
28150  xlam(lknt)=xfac*(zmix(ix,1)*cosw+zmix(ix,2)*sinw)**2
28151  ENDIF
28152  IF(axmi.GT.xmgr+xmz) THEN
28153  lknt=lknt+1
28154  idlam(lknt,1)=idg
28155  idlam(lknt,2)=23
28156  idlam(lknt,3)=0
28157  xlam(lknt)=xfac*((zmix(ix,1)*sinw-zmix(ix,2)*cosw)**2 +
28158  $ .5d0*(zmix(ix,3)*cbeta-zmix(ix,4)*sbeta)**2)*(1d0-xmz2/xmi2)**4
28159  ENDIF
28160  IF(axmi.GT.xmgr+pmas(25,1)) THEN
28161  lknt=lknt+1
28162  idlam(lknt,1)=idg
28163  idlam(lknt,2)=25
28164  idlam(lknt,3)=0
28165  xlam(lknt)=xfac*((zmix(ix,3)*salfa-zmix(ix,4)*calfa)**2)*
28166  $ .5d0*(1d0-pmas(25,1)**2/xmi2)**4
28167  ENDIF
28168  IF(axmi.GT.xmgr+pmas(35,1)) THEN
28169  lknt=lknt+1
28170  idlam(lknt,1)=idg
28171  idlam(lknt,2)=35
28172  idlam(lknt,3)=0
28173  xlam(lknt)=xfac*((zmix(ix,3)*calfa+zmix(ix,4)*salfa)**2)*
28174  $ .5d0*(1d0-pmas(35,1)**2/xmi2)**4
28175  ENDIF
28176  IF(axmi.GT.xmgr+pmas(36,1)) THEN
28177  lknt=lknt+1
28178  idlam(lknt,1)=idg
28179  idlam(lknt,2)=36
28180  idlam(lknt,3)=0
28181  xlam(lknt)=xfac*((zmix(ix,3)*sbeta+zmix(ix,4)*cbeta)**2)*
28182  $ .5d0*(1d0-pmas(36,1)**2/xmi2)**4
28183  ENDIF
28184  ENDIF
28185 
28186  DO 180 ij=1,ix-1
28187  xmj=smz(ij)
28188  axmj=abs(xmj)
28189  xmj2=xmj**2
28190 
28191 C...CHI0_I -> CHI0_J + GAMMA
28192  IF(axmi.GE.axmj.AND.sbeta/cbeta.LE.2d0) THEN
28193  rat1=zmix(ij,1)**2+zmix(ij,2)**2
28194  rat1=rat1/( 1d-6+zmix(ix,3)**2+zmix(ix,4)**2 )
28195  rat2=zmix(ix,1)**2+zmix(ix,2)**2
28196  rat2=rat2/( 1d-6+zmix(ij,3)**2+zmix(ij,4)**2 )
28197  IF((rat1.GT. 0.90d0 .AND. rat1.LT. 1.10d0) .OR.
28198  & (rat2.GT. 0.90d0 .AND. rat2.LT. 1.10d0)) THEN
28199  lknt=lknt+1
28200  idlam(lknt,1)=kfnchi(ij)
28201  idlam(lknt,2)=22
28202  idlam(lknt,3)=0
28203  gamcon=aem**3/8d0/pi/xmw2/xw
28204  xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
28205  xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
28206  xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
28207  ENDIF
28208  ENDIF
28209 
28210 C...CHI0_I -> CHI0_J + Z0
28211  IF(axmi.GE.axmj+xmz) THEN
28212  lknt=lknt+1
28213  gl=-0.5d0*(zmix(ix,3)*zmix(ij,3)-zmix(ix,4)*zmix(ij,4))
28214  gr=-gl
28215  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gl,gr)
28216  idlam(lknt,1)=kfnchi(ij)
28217  idlam(lknt,2)=23
28218  idlam(lknt,3)=0
28219  ELSEIF(axmi.GE.axmj) THEN
28220  fid=11
28221  ei=kchg(fid,1)/3d0
28222  t3=-0.5d0
28223  xxm(1)=0d0
28224  xxm(2)=xmj
28225  xxm(3)=0d0
28226  xxm(4)=xmi
28227  xxm(5)=pmas(pycomp(ksusy1+11),1)
28228  xxm(6)=pmas(pycomp(ksusy2+11),1)
28229  xxm(7)=xmz
28230  xxm(8)=pmas(23,2)
28231  xxm(9)=-0.5d0*(zmix(ix,3)*zmix(ij,3)-zmix(ix,4)*zmix(ij,4))
28232  xxm(10)=-xxm(9)
28233  xxm(11)=(t3-ei*xw)/(1d0-xw)
28234  xxm(12)=-ei*xw/(1d0-xw)
28235  xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
28236  xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
28237  xxm(15)=sr2*tanw*(ei*zmix(ix,1))
28238  xxm(16)=sr2*tanw*(ei*zmix(ij,1))
28239  s12min=0d0
28240  s12max=(axmi-axmj)**2
28241 
28242 C...CHARGED LEPTONS
28243  IF( xxm(5).LT.axmi ) THEN
28244  xxm(5)=1d6
28245  ENDIF
28246  IF(xxm(6).LT.axmi ) THEN
28247  xxm(6)=1d6
28248  ENDIF
28249  IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
28250  lknt=lknt+1
28251  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28252  & pygaus(pyxxz5,s12min,s12max,1d-3)
28253  idlam(lknt,1)=kfnchi(ij)
28254  idlam(lknt,2)=11
28255  idlam(lknt,3)=-11
28256  IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
28257  lknt=lknt+1
28258  xlam(lknt)=xlam(lknt-1)
28259  idlam(lknt,1)=kfnchi(ij)
28260  idlam(lknt,2)=13
28261  idlam(lknt,3)=-13
28262  ENDIF
28263  ENDIF
28264  100 CONTINUE
28265  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
28266  xxm(5)=pmas(pycomp(ksusy1+15),1)
28267  xxm(6)=pmas(pycomp(ksusy2+15),1)
28268  ELSE
28269  xxm(6)=pmas(pycomp(ksusy1+15),1)
28270  xxm(5)=pmas(pycomp(ksusy2+15),1)
28271  ENDIF
28272  IF( xxm(5).LT.axmi ) THEN
28273  xxm(5)=1d6
28274  ENDIF
28275  IF(xxm(6).LT.axmi ) THEN
28276  xxm(6)=1d6
28277  ENDIF
28278 
28279  IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
28280  lknt=lknt+1
28281  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28282  & pygaus(pyxxz5,s12min,s12max,1d-3)
28283  idlam(lknt,1)=kfnchi(ij)
28284  idlam(lknt,2)=15
28285  idlam(lknt,3)=-15
28286  ENDIF
28287 
28288 C...NEUTRINOS
28289  110 CONTINUE
28290  fid=12
28291  ei=kchg(fid,1)/3d0
28292  t3=0.5d0
28293  xxm(5)=pmas(pycomp(ksusy1+12),1)
28294  xxm(6)=1d6
28295  xxm(11)=(t3-ei*xw)/(1d0-xw)
28296  xxm(12)=-ei*xw/(1d0-xw)
28297  xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
28298  xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
28299  xxm(15)=sr2*tanw*(ei*zmix(ix,1))
28300  xxm(16)=sr2*tanw*(ei*zmix(ij,1))
28301 
28302  IF( xxm(5).LT.axmi ) THEN
28303  xxm(5)=1d6
28304  ENDIF
28305 
28306  lknt=lknt+1
28307  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28308  & pygaus(pyxxz5,s12min,s12max,1d-3)
28309  idlam(lknt,1)=kfnchi(ij)
28310  idlam(lknt,2)=12
28311  idlam(lknt,3)=-12
28312  lknt=lknt+1
28313  xlam(lknt)=xlam(lknt-1)
28314  idlam(lknt,1)=kfnchi(ij)
28315  idlam(lknt,2)=14
28316  idlam(lknt,3)=-14
28317  120 CONTINUE
28318  xxm(5)=pmas(pycomp(ksusy1+16),1)
28319  IF( xxm(5).LT.axmi ) THEN
28320  xxm(5)=1d6
28321  ENDIF
28322  lknt=lknt+1
28323  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28324  & pygaus(pyxxz5,s12min,s12max,1d-3)
28325  idlam(lknt,1)=kfnchi(ij)
28326  idlam(lknt,2)=16
28327  idlam(lknt,3)=-16
28328 
28329 C...D-TYPE QUARKS
28330  130 CONTINUE
28331  xxm(5)=pmas(pycomp(ksusy1+1),1)
28332  xxm(6)=pmas(pycomp(ksusy2+1),1)
28333  fid=1
28334  ei=kchg(fid,1)/3d0
28335  t3=-0.5d0
28336 
28337  xxm(11)=(t3-ei*xw)/(1d0-xw)
28338  xxm(12)=-ei*xw/(1d0-xw)
28339  xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
28340  xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
28341  xxm(15)=sr2*tanw*(ei*zmix(ix,1))
28342  xxm(16)=sr2*tanw*(ei*zmix(ij,1))
28343 
28344  IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) goto 140
28345  IF( xxm(5).LT.axmi ) THEN
28346  xxm(5)=1d6
28347  ELSEIF( xxm(6).LT.axmi ) THEN
28348  xxm(6)=1d6
28349  ENDIF
28350  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
28351  lknt=lknt+1
28352  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28353  & pygaus(pyxxz5,s12min,s12max,1d-3)*3d0
28354  idlam(lknt,1)=kfnchi(ij)
28355  idlam(lknt,2)=1
28356  idlam(lknt,3)=-1
28357  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
28358  lknt=lknt+1
28359  xlam(lknt)=xlam(lknt-1)
28360  idlam(lknt,1)=kfnchi(ij)
28361  idlam(lknt,2)=3
28362  idlam(lknt,3)=-3
28363  ENDIF
28364  ENDIF
28365  140 CONTINUE
28366  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
28367  xxm(5)=pmas(pycomp(ksusy1+5),1)
28368  xxm(6)=pmas(pycomp(ksusy2+5),1)
28369  ELSE
28370  xxm(6)=pmas(pycomp(ksusy1+5),1)
28371  xxm(5)=pmas(pycomp(ksusy2+5),1)
28372  ENDIF
28373  IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) goto 150
28374  IF(xxm(5).LT.axmi) THEN
28375  xxm(5)=1d6
28376  ELSEIF(xxm(6).LT.axmi) THEN
28377  xxm(6)=1d6
28378  ENDIF
28379  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
28380  lknt=lknt+1
28381  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28382  & pygaus(pyxxz5,s12min,s12max,1d-3)*3d0
28383  idlam(lknt,1)=kfnchi(ij)
28384  idlam(lknt,2)=5
28385  idlam(lknt,3)=-5
28386  ENDIF
28387 
28388 C...U-TYPE QUARKS
28389  150 CONTINUE
28390  xxm(5)=pmas(pycomp(ksusy1+2),1)
28391  xxm(6)=pmas(pycomp(ksusy2+2),1)
28392  fid=2
28393  ei=kchg(fid,1)/3d0
28394  t3=0.5d0
28395 
28396  xxm(11)=(t3-ei*xw)/(1d0-xw)
28397  xxm(12)=-ei*xw/(1d0-xw)
28398  xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))
28399  xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))
28400  xxm(15)=sr2*tanw*(ei*zmix(ix,1))
28401  xxm(16)=sr2*tanw*(ei*zmix(ij,1))
28402 
28403  IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) goto 160
28404  IF(xxm(5).LT.axmi) THEN
28405  xxm(5)=1d6
28406  ELSEIF(xxm(6).LT.axmi) THEN
28407  xxm(6)=1d6
28408  ENDIF
28409  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
28410  lknt=lknt+1
28411  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28412  & pygaus(pyxxz5,s12min,s12max,1d-3)*3d0
28413  idlam(lknt,1)=kfnchi(ij)
28414  idlam(lknt,2)=2
28415  idlam(lknt,3)=-2
28416  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
28417  lknt=lknt+1
28418  xlam(lknt)=xlam(lknt-1)
28419  idlam(lknt,1)=kfnchi(ij)
28420  idlam(lknt,2)=4
28421  idlam(lknt,3)=-4
28422  ENDIF
28423  ENDIF
28424  160 CONTINUE
28425  ENDIF
28426 
28427 C...CHI0_I -> CHI0_J + H0_K
28428  eh(1)=sin(alfa)
28429  eh(2)=cos(alfa)
28430  eh(3)=-sin(beta)
28431  dh(1)=cos(alfa)
28432  dh(2)=-sin(alfa)
28433  dh(3)=cos(beta)
28434 
28435  qij=zmix(ix,3)*zmix(ij,2)+zmix(ij,3)*zmix(ix,2)-
28436  & tanw*(zmix(ix,3)*zmix(ij,1)+zmix(ij,3)*zmix(ix,1))
28437  rij=zmix(ix,4)*zmix(ij,2)+zmix(ij,4)*zmix(ix,2)-
28438  & tanw*(zmix(ix,4)*zmix(ij,1)+zmix(ij,4)*zmix(ix,1))
28439 
28440  DO 170 ih=1,3
28441  xmh=pmas(ith(ih),1)
28442  xmh2=xmh**2
28443  IF(axmi.GE.axmj+xmh) THEN
28444  lknt=lknt+1
28445  xl=pylamf(xmi2,xmj2,xmh2)
28446  f21k=0.5d0*(qij*eh(ih)+rij*dh(ih))
28447  f12k=f21k
28448 C...SIGN OF MASSES I,J
28449  xmk=xmj
28450  IF(ih.EQ.3) xmk=-xmk
28451  xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,f12k,f21k)
28452  idlam(lknt,1)=kfnchi(ij)
28453  idlam(lknt,2)=ith(ih)
28454  idlam(lknt,3)=0
28455  ENDIF
28456  170 CONTINUE
28457  180 CONTINUE
28458 
28459 C...CHI0_I -> CHI+_J + W-
28460  DO 220 ij=1,2
28461  xmj=smw(ij)
28462  axmj=abs(xmj)
28463  xmj2=xmj**2
28464  IF(axmi.GE.axmj+xmw) THEN
28465  lknt=lknt+1
28466  gl=zmix(ix,2)*vmix(ij,1)-zmix(ix,4)*vmix(ij,2)/sr2
28467  gr=zmix(ix,2)*umix(ij,1)+zmix(ix,3)*umix(ij,2)/sr2
28468  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gl,gr)
28469  idlam(lknt,1)=kfcchi(ij)
28470  idlam(lknt,2)=-24
28471  idlam(lknt,3)=0
28472  lknt=lknt+1
28473  xlam(lknt)=xlam(lknt-1)
28474  idlam(lknt,1)=-kfcchi(ij)
28475  idlam(lknt,2)=24
28476  idlam(lknt,3)=0
28477  ELSEIF(axmi.GE.axmj) THEN
28478  s12min=0d0
28479  s12max=(axmi-axmj)**2
28480  xxm(5)=zmix(ix,2)*vmix(ij,1)-zmix(ix,4)*vmix(ij,2)/sr2
28481  xxm(6)=zmix(ix,2)*umix(ij,1)+zmix(ix,3)*umix(ij,2)/sr2
28482 
28483 C...LEPTONS
28484  fid=11
28485  ei=kchg(fid,1)/3d0
28486  t3=-0.5d0
28487  xxm(7)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*umix(ij,1)
28488  fid=12
28489  ei=kchg(fid,1)/3d0
28490  t3=0.5d0
28491  xxm(8)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*vmix(ij,1)
28492 
28493  xxm(1)=0d0
28494  xxm(2)=xmj
28495  xxm(3)=0d0
28496  xxm(4)=xmi
28497  xxm(9)=pmas(24,1)
28498  xxm(10)=pmas(24,2)
28499  xxm(11)=pmas(pycomp(ksusy1+11),1)
28500  xxm(12)=pmas(pycomp(ksusy1+12),1)
28501  IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) goto 190
28502  IF(xxm(11).LT.axmi) THEN
28503  xxm(11)=1d6
28504  ELSEIF(xxm(12).LT.axmi) THEN
28505  xxm(12)=1d6
28506  ENDIF
28507  IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
28508  lknt=lknt+1
28509  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28510  & pygaus(pyxxw5,s12min,s12max,prec)
28511  idlam(lknt,1)=kfcchi(ij)
28512  idlam(lknt,2)=11
28513  idlam(lknt,3)=-12
28514  lknt=lknt+1
28515  xlam(lknt)=xlam(lknt-1)
28516  idlam(lknt,1)=-idlam(lknt-1,1)
28517  idlam(lknt,2)=-idlam(lknt-1,2)
28518  idlam(lknt,3)=-idlam(lknt-1,3)
28519  IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
28520  lknt=lknt+1
28521  xlam(lknt)=xlam(lknt-1)
28522  idlam(lknt,1)=kfcchi(ij)
28523  idlam(lknt,2)=13
28524  idlam(lknt,3)=-14
28525  lknt=lknt+1
28526  xlam(lknt)=xlam(lknt-1)
28527  idlam(lknt,1)=-idlam(lknt-1,1)
28528  idlam(lknt,2)=-idlam(lknt-1,2)
28529  idlam(lknt,3)=-idlam(lknt-1,3)
28530  ENDIF
28531  ENDIF
28532  190 CONTINUE
28533  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
28534  xxm(11)=pmas(pycomp(ksusy1+15),1)
28535  xxm(12)=pmas(pycomp(ksusy1+16),1)
28536  ELSE
28537  xxm(11)=pmas(pycomp(ksusy2+15),1)
28538  xxm(12)=pmas(pycomp(ksusy1+16),1)
28539  ENDIF
28540 
28541  IF(xxm(11).LT.axmi) THEN
28542  xxm(11)=1d6
28543  ENDIF
28544  IF(xxm(12).LT.axmi) THEN
28545  xxm(12)=1d6
28546  ENDIF
28547  IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
28548  lknt=lknt+1
28549  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28550  & pygaus(pyxxw5,s12min,s12max,prec)
28551  xlam(lknt)=xlam(lknt-1)
28552  idlam(lknt,1)=kfcchi(ij)
28553  idlam(lknt,2)=15
28554  idlam(lknt,3)=-16
28555  lknt=lknt+1
28556  xlam(lknt)=xlam(lknt-1)
28557  idlam(lknt,1)=-idlam(lknt-1,1)
28558  idlam(lknt,2)=-idlam(lknt-1,2)
28559  idlam(lknt,3)=-idlam(lknt-1,3)
28560  ENDIF
28561 
28562 C...NOW, DO THE QUARKS
28563  200 CONTINUE
28564  fid=1
28565  ei=kchg(fid,1)/3d0
28566  t3=-0.5d0
28567  xxm(7)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*umix(ij,1)
28568  fid=2
28569  ei=kchg(fid,1)/3d0
28570  t3=0.5d0
28571  xxm(8)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*vmix(ij,1)
28572 
28573  xxm(11)=pmas(pycomp(ksusy1+1),1)
28574  xxm(12)=pmas(pycomp(ksusy1+2),1)
28575  IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) goto 210
28576  IF(xxm(11).LT.axmi) THEN
28577  xxm(11)=1d6
28578  ELSEIF(xxm(12).LT.axmi) THEN
28579  xxm(12)=1d6
28580  ENDIF
28581  IF(axmi.GE.axmj+pmas(2,1)+pmas(1,1)) THEN
28582  lknt=lknt+1
28583  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
28584  & pygaus(pyxxw5,s12min,s12max,prec)
28585  idlam(lknt,1)=kfcchi(ij)
28586  idlam(lknt,2)=1
28587  idlam(lknt,3)=-2
28588  lknt=lknt+1
28589  xlam(lknt)=xlam(lknt-1)
28590  idlam(lknt,1)=-idlam(lknt-1,1)
28591  idlam(lknt,2)=-idlam(lknt-1,2)
28592  idlam(lknt,3)=-idlam(lknt-1,3)
28593  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
28594  lknt=lknt+1
28595  xlam(lknt)=xlam(lknt-1)
28596  idlam(lknt,1)=kfcchi(ij)
28597  idlam(lknt,2)=3
28598  idlam(lknt,3)=-4
28599  lknt=lknt+1
28600  xlam(lknt)=xlam(lknt-1)
28601  idlam(lknt,1)=-idlam(lknt-1,1)
28602  idlam(lknt,2)=-idlam(lknt-1,2)
28603  idlam(lknt,3)=-idlam(lknt-1,3)
28604  ENDIF
28605  ENDIF
28606  210 CONTINUE
28607  ENDIF
28608  220 CONTINUE
28609  230 CONTINUE
28610 
28611 C...CHI0_I -> CHI+_I + H-
28612  DO 240 ij=1,2
28613  xmj=smw(ij)
28614  axmj=abs(xmj)
28615  xmj2=xmj**2
28616  xmhp=pmas(ithc,1)
28617  xmhp2=xmhp**2
28618  IF(axmi.GE.axmj+xmhp) THEN
28619  lknt=lknt+1
28620  gl=cbeta*(zmix(ix,4)*vmix(ij,1)+(zmix(ix,2)+
28621  & zmix(ix,1)*tanw)*vmix(ij,2)/sr2)
28622  gr=sbeta*(zmix(ix,3)*umix(ij,1)-(zmix(ix,2)+
28623  & zmix(ix,1)*tanw)*umix(ij,2)/sr2)
28624  xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gl,gr)
28625  idlam(lknt,1)=kfcchi(ij)
28626  idlam(lknt,2)=-ithc
28627  idlam(lknt,3)=0
28628  lknt=lknt+1
28629  xlam(lknt)=xlam(lknt-1)
28630  idlam(lknt,1)=-idlam(lknt-1,1)
28631  idlam(lknt,2)=-idlam(lknt-1,2)
28632  idlam(lknt,3)=-idlam(lknt-1,3)
28633  ELSE
28634 
28635  ENDIF
28636  240 CONTINUE
28637 
28638 C...2-BODY DECAYS TO FERMION SFERMION
28639  DO 250 j=1,16
28640  IF(j.GE.7.AND.j.LE.10) goto 250
28641  kf1=ksusy1+j
28642  kf2=ksusy2+j
28643  xmsf1=pmas(pycomp(kf1),1)
28644  xmsf2=pmas(pycomp(kf2),1)
28645  xmf=pmas(j,1)
28646  IF(j.LE.6) THEN
28647  fcol=3d0
28648  ELSE
28649  fcol=1d0
28650  ENDIF
28651 
28652  ei=kchg(j,1)/3d0
28653  t3t=sign(1d0,ei)
28654  IF(j.EQ.12.OR.j.EQ.14.OR.j.EQ.16) t3t=1d0
28655  IF(mod(j,2).EQ.0) THEN
28656  bl=t3t*zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-t3t)
28657  al=xmf*zmix(ix,4)/xmw/sbeta
28658  ar=-2d0*ei*tanw*zmix(ix,1)
28659  br=al
28660  ELSE
28661  bl=t3t*zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-t3t)
28662  al=xmf*zmix(ix,3)/xmw/cbeta
28663  ar=-2d0*ei*tanw*zmix(ix,1)
28664  br=al
28665  ENDIF
28666 
28667 C...D~ D_L
28668  IF(axmi.GE.xmf+xmsf1) THEN
28669  lknt=lknt+1
28670  xma2=xmsf1**2
28671  xmb2=xmf**2
28672  xl=pylamf(xmi2,xma2,xmb2)
28673  ca=al*sfmix(j,1)+ar*sfmix(j,2)
28674  cb=bl*sfmix(j,1)+br*sfmix(j,2)
28675  xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
28676  & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
28677  idlam(lknt,1)=kf1
28678  idlam(lknt,2)=-j
28679  idlam(lknt,3)=0
28680  lknt=lknt+1
28681  xlam(lknt)=xlam(lknt-1)
28682  idlam(lknt,1)=-idlam(lknt-1,1)
28683  idlam(lknt,2)=-idlam(lknt-1,2)
28684  idlam(lknt,3)=0
28685  ENDIF
28686 
28687 C...D~ D_R
28688  IF(axmi.GE.xmf+xmsf2) THEN
28689  lknt=lknt+1
28690  xma2=xmsf2**2
28691  xmb2=xmf**2
28692  ca=al*sfmix(j,3)+ar*sfmix(j,4)
28693  cb=bl*sfmix(j,3)+br*sfmix(j,4)
28694  xl=pylamf(xmi2,xma2,xmb2)
28695  xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
28696  & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
28697  idlam(lknt,1)=kf2
28698  idlam(lknt,2)=-j
28699  idlam(lknt,3)=0
28700  lknt=lknt+1
28701  xlam(lknt)=xlam(lknt-1)
28702  idlam(lknt,1)=-idlam(lknt-1,1)
28703  idlam(lknt,2)=-idlam(lknt-1,2)
28704  idlam(lknt,3)=0
28705  ENDIF
28706  250 CONTINUE
28707 
28708 C...3-BODY DECAY TO Q Q~ GLUINO
28709  xmj=pmas(pycomp(ksusy1+21),1)
28710  IF(axmi.GE.xmj) THEN
28711  axmj=abs(xmj)
28712  xxm(1)=0d0
28713  xxm(2)=xmj
28714  xxm(3)=0d0
28715  xxm(4)=xmi
28716  xxm(5)=pmas(pycomp(ksusy1+1),1)
28717  xxm(6)=pmas(pycomp(ksusy2+1),1)
28718  xxm(7)=1d6
28719  xxm(8)=0d0
28720  xxm(9)=0d0
28721  xxm(10)=0d0
28722  s12min=0d0
28723  s12max=(axmi-axmj)**2
28724 C...ALL QUARKS BUT T
28725  xxm(11)=0d0
28726  xxm(12)=0d0
28727  xxm(13)=1d0
28728  xxm(14)=-sr2*(-0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
28729  xxm(15)=1d0
28730  xxm(16)=sr2*(-tanw*zmix(ix,1)/3d0)
28731  IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 260
28732  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
28733  lknt=lknt+1
28734  xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
28735  & pygaus(pyxxz5,s12min,s12max,1d-3)
28736  idlam(lknt,1)=ksusy1+21
28737  idlam(lknt,2)=1
28738  idlam(lknt,3)=-1
28739  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
28740  lknt=lknt+1
28741  xlam(lknt)=xlam(lknt-1)
28742  idlam(lknt,1)=ksusy1+21
28743  idlam(lknt,2)=3
28744  idlam(lknt,3)=-3
28745  ENDIF
28746  ENDIF
28747  260 CONTINUE
28748  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
28749  xxm(5)=pmas(pycomp(ksusy1+5),1)
28750  xxm(6)=pmas(pycomp(ksusy2+5),1)
28751  ELSE
28752  xxm(6)=pmas(pycomp(ksusy1+5),1)
28753  xxm(5)=pmas(pycomp(ksusy2+5),1)
28754  ENDIF
28755  IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 270
28756  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
28757  lknt=lknt+1
28758  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
28759  & pygaus(pyxxz5,s12min,s12max,1d-3)
28760  idlam(lknt,1)=ksusy1+21
28761  idlam(lknt,2)=5
28762  idlam(lknt,3)=-5
28763  ENDIF
28764 C...U-TYPE QUARKS
28765  270 CONTINUE
28766  xxm(5)=pmas(pycomp(ksusy1+2),1)
28767  xxm(6)=pmas(pycomp(ksusy2+2),1)
28768  xxm(13)=1d0
28769  xxm(14)=-sr2*(0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)
28770  xxm(15)=1d0
28771  xxm(16)=sr2*(2d0*tanw*zmix(ix,1)/3d0)
28772  IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 280
28773  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
28774  lknt=lknt+1
28775  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
28776  & pygaus(pyxxz5,s12min,s12max,1d-3)
28777  idlam(lknt,1)=ksusy1+21
28778  idlam(lknt,2)=2
28779  idlam(lknt,3)=-2
28780  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
28781  lknt=lknt+1
28782  xlam(lknt)=xlam(lknt-1)
28783  idlam(lknt,1)=ksusy1+21
28784  idlam(lknt,2)=4
28785  idlam(lknt,3)=-4
28786  ENDIF
28787  ENDIF
28788  280 CONTINUE
28789  ENDIF
28790 
28791  290 iknt=lknt
28792  xlam(0)=0d0
28793  DO 300 i=1,iknt
28794  IF(xlam(i).LT.0d0) xlam(i)=0d0
28795  xlam(0)=xlam(0)+xlam(i)
28796  300 CONTINUE
28797  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
28798 
28799  RETURN
28800  END
28801 
28802 C*********************************************************************
28803 
28804 C...PYCJDC
28805 C...Calculate decay widths for the charginos (admixtures of
28806 C...charged Wino and charged Higgsino.
28807 
28808 C...Input: KCIN = KF code for particle
28809 C...Output: XLAM = widths
28810 C... IDLAM = KF codes for decay particles
28811 C... IKNT = number of decay channels defined
28812 C...AUTHOR: STEPHEN MRENNA
28813 C...Last change:
28814 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
28815 C...when CHIENU .NE. 0
28816 
28817  SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)
28818 
28819 C...Double precision and integer declarations.
28820  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28821  INTEGER pyk,pychge,pycomp
28822 C...Parameter statement to help give large particle numbers.
28823  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
28824 C...Commonblocks.
28825  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28826  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28827  common/pymssm/imss(0:99),rmss(0:99)
28828  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
28829  &sfmix(16,4)
28830  common/pyints/xxm(20)
28831  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/
28832 
28833 C...Local variables.
28834  INTEGER kfin,kcin
28835  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,
28836  &xmz,xmz2,axmj,axmi
28837  DOUBLE PRECISION xmfp,xmf1,xmf2,xmsl,xmg
28838  DOUBLE PRECISION s12min,s12max
28839  DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xmhp2,xma2,xmb2,xmk
28840  DOUBLE PRECISION pylamf,xl
28841  DOUBLE PRECISION tanw,xw,aem,c1,as,ei,t3,beta,alfa
28842  DOUBLE PRECISION pyx2xh,pyx2xg
28843  DOUBLE PRECISION xlam(0:200)
28844  INTEGER idlam(200,3)
28845  INTEGER lknt,ix,ih,j,ij,i,iknt,fid
28846  INTEGER ith(3)
28847  INTEGER ithc
28848  DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)
28849  DOUBLE PRECISION sr2
28850  DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k,tanb
28851 
28852  DOUBLE PRECISION pyalem,pi,pyalps
28853  DOUBLE PRECISION al,bl,ar,br,alp,blp,arp,brp
28854  DOUBLE PRECISION ca,cb,fcol
28855  INTEGER kf1,kf2,isf
28856  INTEGER kfnchi(4),kfcchi(2)
28857 
28858  DOUBLE PRECISION temp
28859  DOUBLE PRECISION pygaus
28860  EXTERNAL pygaus,pyxxz5,pyxxw5,pyxxz2
28861  DOUBLE PRECISION prec
28862  DATA ith/25,35,36/
28863  DATA ithc/37/
28864  DATA etah/1d0,1d0,-1d0/
28865  DATA sr2/1.4142136d0/
28866  DATA pi/3.141592654d0/
28867  DATA prec/1d-2/
28868  DATA kfnchi/1000022,1000023,1000025,1000035/
28869  DATA kfcchi/1000024,1000037/
28870 
28871 C...COUNT THE NUMBER OF DECAY MODES
28872  lknt=0
28873  xmw=pmas(24,1)
28874  xmw2=xmw**2
28875  xmz=pmas(23,1)
28876  xmz2=xmz**2
28877  xw=1d0-xmw2/xmz2
28878  tanw = sqrt(xw/(1d0-xw))
28879 
28880 C...1 OR 2 DEPENDING ON CHARGINO TYPE
28881  ix=1
28882  IF(kfin.EQ.kfcchi(2)) ix=2
28883  kcin=pycomp(kfin)
28884 
28885  xmi=smw(ix)
28886  xmi2=xmi**2
28887  axmi=abs(xmi)
28888  aem=pyalem(xmi2)
28889  as =pyalps(xmi2)
28890  c1=aem/xw
28891  xmi3=abs(xmi**3)
28892  tanb=rmss(5)
28893  beta=atan(tanb)
28894  cbeta=cos(beta)
28895  sbeta=tanb*cbeta
28896  alfa=rmss(18)
28897 
28898 C...GRAVITINO DECAY MODES
28899 
28900  IF(imss(11).EQ.1) THEN
28901  xmp=rmss(28)
28902  idg=39+ksusy1
28903  xmgr=pmas(pycomp(idg),1)
28904  sinw=sqrt(xw)
28905  cosw=sqrt(1d0-xw)
28906  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
28907  IF(axmi.GT.xmgr+xmw) THEN
28908  lknt=lknt+1
28909  idlam(lknt,1)=idg
28910  idlam(lknt,2)=24
28911  idlam(lknt,3)=0
28912  xlam(lknt)=xfac*(.5d0*(vmix(ix,1)**2+umix(ix,1)**2)+
28913  & .5d0*((vmix(ix,2)*sbeta)**2+(umix(ix,2)*cbeta)**2))*
28914  & (1d0-xmw2/xmi2)**4
28915  ENDIF
28916  IF(axmi.GT.xmgr+pmas(37,1)) THEN
28917  lknt=lknt+1
28918  idlam(lknt,1)=idg
28919  idlam(lknt,2)=37
28920  idlam(lknt,3)=0
28921  xlam(lknt)=xfac*(.5d0*((vmix(ix,2)*cbeta)**2+
28922  & (umix(ix,2)*sbeta)**2))
28923  & *(1d0-pmas(37,1)**2/xmi2)**4
28924  ENDIF
28925  ENDIF
28926 
28927 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28928  IF(ix.EQ.1) goto 150
28929  xmj=smw(1)
28930  axmj=abs(xmj)
28931  xmj2=xmj**2
28932 
28933 C...CHI_2+ -> CHI_1+ + Z0
28934  IF(axmi.GE.axmj+xmz) THEN
28935  lknt=lknt+1
28936  gl=vmix(2,1)*vmix(1,1)+0.5d0*vmix(2,2)*vmix(1,2)
28937  gr=umix(2,1)*umix(1,1)+0.5d0*umix(2,2)*umix(1,2)
28938  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gl,gr)
28939  idlam(lknt,1)=kfcchi(1)
28940  idlam(lknt,2)=23
28941  idlam(lknt,3)=0
28942 
28943 C...CHARGED LEPTONS
28944  ELSEIF(axmi.GE.axmj) THEN
28945  xxm(5)=-(vmix(2,1)*vmix(1,1)+0.5d0*vmix(2,2)*vmix(1,2))
28946  xxm(6)=-(umix(2,1)*umix(1,1)+0.5d0*umix(2,2)*umix(1,2))
28947  xxm(9)=xmz
28948  xxm(10)=pmas(23,2)
28949  xxm(1)=0d0
28950  xxm(2)=xmj
28951  xxm(3)=0d0
28952  xxm(4)=xmi
28953  s12min=0d0
28954  s12max=(axmj-axmi)**2
28955  xxm(7)= (-0.5d0+xw)/(1d0-xw)
28956  xxm(8)= xw/(1d0-xw)
28957  xxm(11)=pmas(pycomp(ksusy1+12),1)
28958  xxm(12)=vmix(2,1)*vmix(1,1)
28959  IF( xxm(11).LT.axmi ) THEN
28960  xxm(11)=1d6
28961  ENDIF
28962  IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
28963  lknt=lknt+1
28964  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28965  & pygaus(pyxxz2,s12min,s12max,prec)
28966  idlam(lknt,1)=kfcchi(1)
28967  idlam(lknt,2)=11
28968  idlam(lknt,3)=-11
28969  IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
28970  lknt=lknt+1
28971  xlam(lknt)=xlam(lknt-1)
28972  idlam(lknt,1)=kfcchi(1)
28973  idlam(lknt,2)=13
28974  idlam(lknt,3)=-13
28975  IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
28976  lknt=lknt+1
28977  xlam(lknt)=xlam(lknt-1)
28978  idlam(lknt,1)=kfcchi(1)
28979  idlam(lknt,2)=15
28980  idlam(lknt,3)=-15
28981  ENDIF
28982  ENDIF
28983  ENDIF
28984 
28985 C...NEUTRINOS
28986  100 CONTINUE
28987  xxm(7)= (0.5d0)/(1d0-xw)
28988  xxm(8)= 0d0
28989  xxm(11)=pmas(pycomp(ksusy1+11),1)
28990  xxm(12)=umix(2,1)*umix(1,1)
28991  IF( xxm(11).LT.axmi ) THEN
28992  xxm(11)=1d6
28993  ENDIF
28994  IF(axmi.GE.axmj+2d0*pmas(12,1)) THEN
28995  lknt=lknt+1
28996  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
28997  & pygaus(pyxxz2,s12min,s12max,prec)
28998  idlam(lknt,1)=kfcchi(1)
28999  idlam(lknt,2)=12
29000  idlam(lknt,3)=-12
29001  lknt=lknt+1
29002  xlam(lknt)=xlam(lknt-1)
29003  idlam(lknt,1)=kfcchi(1)
29004  idlam(lknt,2)=14
29005  idlam(lknt,3)=-14
29006  lknt=lknt+1
29007  xlam(lknt)=xlam(lknt-1)
29008  idlam(lknt,1)=kfcchi(1)
29009  idlam(lknt,2)=16
29010  idlam(lknt,3)=-16
29011  ENDIF
29012 
29013 C...D-TYPE QUARKS
29014  110 CONTINUE
29015  xxm(7)= (-0.5d0+xw/3d0)/(1d0-xw)
29016  xxm(8)= xw/3d0/(1d0-xw)
29017  xxm(11)=pmas(pycomp(ksusy1+2),1)
29018  xxm(12)=vmix(2,1)*vmix(1,1)
29019  IF( xxm(11).LT.axmi ) goto 120
29020  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
29021  lknt=lknt+1
29022  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
29023  & pygaus(pyxxz2,s12min,s12max,prec)
29024  idlam(lknt,1)=kfcchi(1)
29025  idlam(lknt,2)=1
29026  idlam(lknt,3)=-1
29027  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
29028  lknt=lknt+1
29029  xlam(lknt)=xlam(lknt-1)
29030  idlam(lknt,1)=kfcchi(1)
29031  idlam(lknt,2)=3
29032  idlam(lknt,3)=-3
29033  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
29034  lknt=lknt+1
29035  xlam(lknt)=xlam(lknt-1)
29036  idlam(lknt,1)=kfcchi(1)
29037  idlam(lknt,2)=5
29038  idlam(lknt,3)=-5
29039  ENDIF
29040  ENDIF
29041  ENDIF
29042 
29043 C...U-TYPE QUARKS
29044  120 CONTINUE
29045  xxm(7)= (0.5d0-2d0*xw/3d0)/(1d0-xw)
29046  xxm(8)= -2d0*xw/3d0/(1d0-xw)
29047  xxm(11)=pmas(pycomp(ksusy1+1),1)
29048  xxm(12)=umix(2,1)*umix(1,1)
29049  IF( xxm(11).LT.axmi ) goto 130
29050  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
29051  lknt=lknt+1
29052  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
29053  & pygaus(pyxxz2,s12min,s12max,prec)
29054  idlam(lknt,1)=kfcchi(1)
29055  idlam(lknt,2)=2
29056  idlam(lknt,3)=-2
29057  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
29058  lknt=lknt+1
29059  xlam(lknt)=xlam(lknt-1)
29060  idlam(lknt,1)=kfcchi(1)
29061  idlam(lknt,2)=4
29062  idlam(lknt,3)=-4
29063  ENDIF
29064  ENDIF
29065  130 CONTINUE
29066  ENDIF
29067 
29068 C...CHI_2+ -> CHI_1+ + H0_K
29069  eh(2)=cos(alfa)
29070  eh(1)=sin(alfa)
29071  eh(3)=-sbeta
29072  dh(2)=-sin(alfa)
29073  dh(1)=cos(alfa)
29074  dh(3)=cos(beta)
29075  DO 140 ih=1,3
29076  xmh=pmas(ith(ih),1)
29077  xmh2=xmh**2
29078 C...NO 3-BODY OPTION
29079  IF(axmi.GE.axmj+xmh) THEN
29080  lknt=lknt+1
29081  xl=pylamf(xmi2,xmj2,xmh2)
29082  f21k=(vmix(2,1)*umix(1,2)*eh(ih) -
29083  & vmix(2,2)*umix(1,1)*dh(ih))/sr2
29084  f12k=(vmix(1,1)*umix(2,2)*eh(ih) -
29085  & vmix(1,2)*umix(2,1)*dh(ih))/sr2
29086  xmk=xmj*etah(ih)
29087  xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,f12k,f21k)
29088  idlam(lknt,1)=kfcchi(1)
29089  idlam(lknt,2)=ith(ih)
29090  idlam(lknt,3)=0
29091  ENDIF
29092  140 CONTINUE
29093 
29094 C...CHI1 JUMPS TO HERE
29095  150 CONTINUE
29096 
29097 C...CHI+_I -> CHI0_J + W+
29098  DO 180 ij=1,4
29099  xmj=smz(ij)
29100  axmj=abs(xmj)
29101  xmj2=xmj**2
29102  IF(axmi.GE.axmj+xmw) THEN
29103  lknt=lknt+1
29104  gl=zmix(ij,2)*vmix(ix,1)-zmix(ij,4)*vmix(ix,2)/sr2
29105  gr=zmix(ij,2)*umix(ix,1)+zmix(ij,3)*umix(ix,2)/sr2
29106  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gl,gr)
29107  idlam(lknt,1)=kfnchi(ij)
29108  idlam(lknt,2)=24
29109  idlam(lknt,3)=0
29110 
29111 C...LEPTONS
29112  ELSEIF(axmi.GE.axmj) THEN
29113  xmf1=0d0
29114  xmf2=0d0
29115  s12min=(xmf1+xmf2)**2
29116  s12max=(axmj-axmi)**2
29117  xxm(5)=-1d0/sr2*zmix(ij,4)*vmix(ix,2)+zmix(ij,2)*vmix(ix,1)
29118  xxm(6)= 1d0/sr2*zmix(ij,3)*umix(ix,2)+zmix(ij,2)*umix(ix,1)
29119  fid=11
29120  ei=kchg(fid,1)/3d0
29121  t3=-0.5d0
29122  xxm(7)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*umix(ix,1)
29123  fid=12
29124  ei=kchg(fid,1)/3d0
29125  t3=0.5d0
29126  xxm(8)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*vmix(ix,1)
29127 
29128  xxm(4)=xmi
29129  xxm(1)=xmf1
29130  xxm(2)=xmj
29131  xxm(3)=xmf2
29132  xxm(9)=pmas(24,1)
29133  xxm(10)=pmas(24,2)
29134  xxm(11)=pmas(pycomp(ksusy1+11),1)
29135  xxm(12)=pmas(pycomp(ksusy1+12),1)
29136 
29137 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
29138 C...--> 1/(16PI)/M**3*(AEM/XW)**2
29139 
29140  IF(xxm(11).LT.axmi) THEN
29141  xxm(11)=1d6
29142  ENDIF
29143  IF(xxm(12).LT.axmi) THEN
29144  xxm(12)=1d6
29145  ENDIF
29146  IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
29147  lknt=lknt+1
29148  temp=pygaus(pyxxw5,s12min,s12max,prec)
29149  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
29150  idlam(lknt,1)=kfnchi(ij)
29151  idlam(lknt,2)=-11
29152  idlam(lknt,3)=12
29153 
29154 C...ONLY DECAY CHI+1 -> E+ NU_E
29155  IF( imss(12).NE. 0 ) goto 220
29156  IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
29157  lknt=lknt+1
29158  xxm(11)=pmas(pycomp(ksusy1+13),1)
29159  xxm(12)=pmas(pycomp(ksusy1+14),1)
29160  IF(xxm(11).LT.axmi) THEN
29161  xxm(11)=1d6
29162  ELSEIF(xxm(12).LT.axmi) THEN
29163  xxm(12)=1d6
29164  ENDIF
29165  temp=pygaus(pyxxw5,s12min,s12max,prec)
29166  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
29167  idlam(lknt,1)=kfnchi(ij)
29168  idlam(lknt,2)=-13
29169  idlam(lknt,3)=14
29170  IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
29171  lknt=lknt+1
29172  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
29173  xxm(11)=pmas(pycomp(ksusy1+15),1)
29174  ELSE
29175  xxm(11)=pmas(pycomp(ksusy2+15),1)
29176  ENDIF
29177  xxm(12)=pmas(pycomp(ksusy1+16),1)
29178  IF(xxm(11).LT.axmi) THEN
29179  xxm(11)=1d6
29180  ENDIF
29181  IF(xxm(12).LT.axmi) THEN
29182  xxm(12)=1d6
29183  ENDIF
29184  temp=pygaus(pyxxw5,s12min,s12max,prec)
29185  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
29186  idlam(lknt,1)=kfnchi(ij)
29187  idlam(lknt,2)=-15
29188  idlam(lknt,3)=16
29189  ENDIF
29190  ENDIF
29191  ENDIF
29192 
29193 C...NOW, DO THE QUARKS
29194  160 CONTINUE
29195  fid=1
29196  ei=kchg(fid,1)/3d0
29197  t3=-0.5d0
29198  xxm(7)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*umix(ix,1)
29199  fid=1
29200  ei=kchg(fid,1)/3d0
29201  t3=0.5d0
29202  xxm(8)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*vmix(ix,1)
29203 
29204  xxm(11)=pmas(pycomp(ksusy1+1),1)
29205  xxm(12)=pmas(pycomp(ksusy1+2),1)
29206  IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) goto 170
29207  IF(xxm(11).LT.axmi) THEN
29208  xxm(11)=1d6
29209  ELSEIF(xxm(12).LT.axmi) THEN
29210  xxm(12)=1d6
29211  ENDIF
29212  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
29213  lknt=lknt+1
29214  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
29215  & pygaus(pyxxw5,s12min,s12max,prec)
29216  idlam(lknt,1)=kfnchi(ij)
29217  idlam(lknt,2)=-1
29218  idlam(lknt,3)=2
29219  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
29220  lknt=lknt+1
29221  xlam(lknt)=xlam(lknt-1)
29222  idlam(lknt,1)=kfnchi(ij)
29223  idlam(lknt,2)=-3
29224  idlam(lknt,3)=4
29225  ENDIF
29226  ENDIF
29227  170 CONTINUE
29228  ENDIF
29229  180 CONTINUE
29230 
29231 C...CHI+_I -> CHI0_J + H+
29232  DO 190 ij=1,4
29233  xmj=smz(ij)
29234  axmj=abs(xmj)
29235  xmj2=xmj**2
29236  xmhp=pmas(ithc,1)
29237  xmhp2=xmhp**2
29238  IF(axmi.GE.axmj+xmhp) THEN
29239  lknt=lknt+1
29240  gl=cbeta*(zmix(ij,4)*vmix(ix,1)+(zmix(ij,2)+
29241  & zmix(ij,1)*tanw)*vmix(ix,2)/sr2)
29242  gr=sbeta*(zmix(ij,3)*umix(ix,1)-(zmix(ij,2)+
29243  & zmix(ij,1)*tanw)*umix(ix,2)/sr2)
29244  xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gl,gr)
29245  idlam(lknt,1)=kfnchi(ij)
29246  idlam(lknt,2)=ithc
29247  idlam(lknt,3)=0
29248  ELSE
29249 
29250  ENDIF
29251  190 CONTINUE
29252 
29253 C...2-BODY DECAYS TO FERMION SFERMION
29254  DO 200 j=1,16
29255  IF(j.GE.7.AND.j.LE.10) goto 200
29256  IF(mod(j,2).EQ.0) THEN
29257  kf1=ksusy1+j-1
29258  ELSE
29259  kf1=ksusy1+j+1
29260  ENDIF
29261  kf2=kf1+ksusy1
29262  xmsf1=pmas(pycomp(kf1),1)
29263  xmsf2=pmas(pycomp(kf2),1)
29264  xmf=pmas(j,1)
29265  IF(j.LE.6) THEN
29266  fcol=3d0
29267  ELSE
29268  fcol=1d0
29269  ENDIF
29270 
29271 C...U~ D_L
29272  IF(mod(j,2).EQ.0) THEN
29273  xmfp=pmas(j-1,1)
29274  al=umix(ix,1)
29275  bl=-xmf*vmix(ix,2)/xmw/sbeta/sr2
29276  ar=-xmfp*umix(ix,2)/xmw/cbeta/sr2
29277  br=0d0
29278  isf=j-1
29279  ELSE
29280  xmfp=pmas(j+1,1)
29281  al=vmix(ix,1)
29282  bl=-xmf*umix(ix,2)/xmw/cbeta/sr2
29283  br=0d0
29284  ar=-xmfp*vmix(ix,2)/xmw/sbeta/sr2
29285  isf=j+1
29286  ENDIF
29287 
29288 C...~U_L D
29289  IF(axmi.GE.xmf+xmsf1) THEN
29290  lknt=lknt+1
29291  xma2=xmsf1**2
29292  xmb2=xmf**2
29293  xl=pylamf(xmi2,xma2,xmb2)
29294  ca=al*sfmix(isf,1)+ar*sfmix(isf,2)
29295  cb=bl*sfmix(isf,1)+br*sfmix(isf,2)
29296  xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
29297  & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
29298  idlam(lknt,3)=0
29299  IF(mod(j,2).EQ.0) THEN
29300  idlam(lknt,1)=-kf1
29301  idlam(lknt,2)=j
29302  ELSE
29303  idlam(lknt,1)=kf1
29304  idlam(lknt,2)=-j
29305  ENDIF
29306  ENDIF
29307 
29308 C...U~ D_R
29309  IF(axmi.GE.xmf+xmsf2) THEN
29310  lknt=lknt+1
29311  xma2=xmsf2**2
29312  xmb2=xmf**2
29313  ca=al*sfmix(isf,3)+ar*sfmix(isf,4)
29314  cb=bl*sfmix(isf,3)+br*sfmix(isf,4)
29315  xl=pylamf(xmi2,xma2,xmb2)
29316  xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
29317  & (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)
29318  idlam(lknt,3)=0
29319  IF(mod(j,2).EQ.0) THEN
29320  idlam(lknt,1)=-kf2
29321  idlam(lknt,2)=j
29322  ELSE
29323  idlam(lknt,1)=kf2
29324  idlam(lknt,2)=-j
29325  ENDIF
29326  ENDIF
29327  200 CONTINUE
29328 
29329 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
29330 C...A 2-BODY -- 2-BODY CHAIN
29331  xmj=pmas(pycomp(ksusy1+21),1)
29332  IF(axmi.GE.xmj) THEN
29333  axmj=abs(xmj)
29334  s12min=0d0
29335  s12max=(axmi-axmj)**2
29336  xxm(1)=0d0
29337  xxm(2)=xmj
29338  xxm(3)=0d0
29339  xxm(4)=xmi
29340  xxm(5)=0d0
29341  xxm(6)=0d0
29342  xxm(9)=1d6
29343  xxm(10)=0d0
29344  xxm(7)=umix(ix,1)*sr2
29345  xxm(8)=vmix(ix,1)*sr2
29346  xxm(11)=pmas(pycomp(ksusy1+1),1)
29347  xxm(12)=pmas(pycomp(ksusy1+2),1)
29348  IF( xxm(11).LT.axmi .OR. xxm(12).LT.axmi ) goto 210
29349  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
29350  lknt=lknt+1
29351  xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
29352  & pygaus(pyxxw5,s12min,s12max,prec)
29353  idlam(lknt,1)=ksusy1+21
29354  idlam(lknt,2)=-1
29355  idlam(lknt,3)=2
29356  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
29357  lknt=lknt+1
29358  xlam(lknt)=xlam(lknt-1)
29359  idlam(lknt,1)=ksusy1+21
29360  idlam(lknt,2)=-3
29361  idlam(lknt,3)=4
29362  ENDIF
29363  ENDIF
29364  210 CONTINUE
29365  ENDIF
29366 
29367  220 iknt=lknt
29368  xlam(0)=0d0
29369  DO 230 i=1,iknt
29370  xlam(0)=xlam(0)+xlam(i)
29371  IF(xlam(i).LT.0d0) THEN
29372  WRITE(mstu(11),*) ' XLAM(I) = ',xlam(i),kcin,
29373  & (idlam(i,j),j=1,3)
29374  xlam(i)=0d0
29375  ENDIF
29376  230 CONTINUE
29377  IF(xlam(0).EQ.0d0) THEN
29378  xlam(0)=1d-6
29379  WRITE(mstu(11),*) ' XLAM(0) = ',xlam(0)
29380  WRITE(mstu(11),*) lknt
29381  WRITE(mstu(11),*) (xlam(j),j=1,lknt)
29382  ENDIF
29383 
29384  RETURN
29385  END
29386 
29387 C*********************************************************************
29388 
29389 C...PYXXZ5
29390 C...Calculates chi0 -> chi0 + f + ~f.
29391 
29392  FUNCTION pyxxz5(X)
29393 
29394 C...Double precision and integer declarations.
29395  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29396  INTEGER pyk,pychge,pycomp
29397 C...Parameter statement to help give large particle numbers.
29398  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29399 C...Commonblocks.
29400  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29401  common/pyints/xxm(20)
29402  SAVE /pydat1/,/pyints/
29403 
29404 C...Local variables.
29405  DOUBLE PRECISION pyxxz5,x
29406  DOUBLE PRECISION xm12,xm22,xm32,s,s23,s13,wprop2
29407  DOUBLE PRECISION ww,wf1,wf2,wfl1,wfl2
29408  DOUBLE PRECISION sij
29409  DOUBLE PRECISION sr2,ol,or,fld,flu,xmv,xmg,xmsu,xmsd
29410  DOUBLE PRECISION le,re,le2,re2,ol2,or2,fli,flj,fri,frj
29411  DOUBLE PRECISION s23min,s23max,s23ave,s23del
29412  INTEGER i
29413  DATA sr2/1.4142136d0/
29414 
29415 C...Statement functions.
29416 C...Integral from x to y of (t-a)(b-t) dt.
29417  tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
29418 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29419  tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
29420  &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
29421 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29422  tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
29423  &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
29424 C...Integral from x to y of (t-a)/(b-t) dt.
29425  utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
29426 C...Integral from x to y of 1/(t-a) dt.
29427  tprop(x,y,a)=log(abs((x-a)/(y-a)))
29428 
29429  xm12=xxm(1)**2
29430  xm22=xxm(2)**2
29431  xm32=xxm(3)**2
29432  s=xxm(4)**2
29433  s13=x
29434 
29435  s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
29436  s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
29437  &( (x-xm22-s)**2 -4d0*xm22*s ) )
29438 
29439  s23min=(s23ave-s23del)
29440  s23max=(s23ave+s23del)
29441 
29442  xmv=xxm(7)
29443  xmg=xxm(8)
29444  xmsd=xxm(5)**2
29445  xmsu=xxm(6)**2
29446  ol=xxm(9)
29447  or=xxm(10)
29448  ol2=ol**2
29449  or2=or**2
29450  le=xxm(11)
29451  re=xxm(12)
29452  le2=le**2
29453  re2=re**2
29454  fli=xxm(13)
29455  flj=xxm(14)
29456  fri=xxm(15)
29457  frj=xxm(16)
29458 
29459  wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
29460  sij=2d0*xxm(2)*xxm(4)*s13
29461 
29462  IF(xmv.LE.1000d0) THEN
29463  ww=2d0*(le2+re2)*(ol2)*( 2d0*tint(s23max,s23min,xm22,s)
29464  & +sij*(s23max-s23min) )/wprop2
29465  IF(xxm(5).LE.10000d0) THEN
29466  wfl1=2d0*fli*flj*ol*le*( 2d0*tint2(s23max,s23min,xm22,s,xmsd)
29467  & + sij*tprop(s23max,s23min,xmsd) )
29468  wfl1=wfl1*(s13-xmv**2)/wprop2
29469  ELSE
29470  wfl1=0d0
29471  ENDIF
29472  IF(xxm(6).LE.10000d0) THEN
29473  wfl2=2d0*fri*frj*or*re*( 2d0*tint2(s23max,s23min,xm22,s,xmsu)
29474  & + sij*tprop(s23max,s23min,xmsu) )
29475  wfl2=wfl2*(s13-xmv**2)/wprop2
29476  ELSE
29477  wfl2=0d0
29478  ENDIF
29479  ELSE
29480  ww=0d0
29481  wfl1=0d0
29482  wfl2=0d0
29483  ENDIF
29484  IF(xxm(5).LE.10000d0) THEN
29485  wf1=0.5d0*(fli*flj)**2*( 2d0*tint3(s23max,s23min,xm22,s,xmsd)
29486  & + sij*utint(s23max,s23min,xmsd,xm22+s-s13-xmsd) )
29487  ELSE
29488  wf1=0d0
29489  ENDIF
29490  IF(xxm(6).LE.10000d0) THEN
29491  wf2=0.5d0*(fri*frj)**2*( 2d0*tint3(s23max,s23min,xm22,s,xmsu)
29492  & + sij*utint(s23max,s23min,xmsu,xm22+s-s13-xmsu) )
29493  ELSE
29494  wf2=0d0
29495  ENDIF
29496 
29497 C...WFL1=0.0
29498 C...WFL2=0.0
29499  pyxxz5=(ww+wf1+wf2+wfl1+wfl2)
29500  IF(pyxxz5.LT.0d0) THEN
29501  WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ5 '
29502  WRITE(mstu(11),*) xxm(1),xxm(2),xxm(3),xxm(4)
29503  WRITE(mstu(11),*) (xxm(i),i=5,8)
29504  WRITE(mstu(11),*) (xxm(i),i=9,12)
29505  WRITE(mstu(11),*) (xxm(i),i=13,16)
29506  WRITE(mstu(11),*) ww,wf1,wf2,wfl1,wfl2
29507  WRITE(mstu(11),*) s23min,s23max
29508  pyxxz5=0d0
29509  ENDIF
29510 
29511  RETURN
29512  END
29513 
29514 C*********************************************************************
29515 
29516 C...PYXXW5
29517 C...Calculates chi0(+) -> chi+(0) + f + ~f'.
29518 
29519  FUNCTION pyxxw5(X)
29520 
29521 C...Double precision and integer declarations.
29522  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29523  INTEGER pyk,pychge,pycomp
29524 C...Parameter statement to help give large particle numbers.
29525  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29526 C...Commonblocks.
29527  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29528  common/pyints/xxm(20)
29529  SAVE /pydat1/,/pyints/
29530 
29531 C...Local variables.
29532  DOUBLE PRECISION pyxxw5,x
29533  DOUBLE PRECISION xm12,xm22,xm32,s,s23,s13,s12,wprop2
29534  DOUBLE PRECISION ww,wu,wd,wwu,wwd,wud
29535  DOUBLE PRECISION sr2,ol,or,fld,flu,xmv,xmg,xmsd,xmsu
29536  DOUBLE PRECISION sij
29537  DOUBLE PRECISION s23min,s23max,s23ave,s23del
29538  INTEGER ik
29539  SAVE ik
29540  DATA ik/0/
29541  DATA sr2/1.4142136d0/
29542 
29543 C...Statement functions.
29544 C...Integral from x to y of (t-a)(b-t) dt.
29545  tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
29546 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29547  tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
29548  &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
29549 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29550  tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
29551  &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
29552 C...Integral from x to y of (t-a)/(b-t) dt.
29553  utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
29554 C...Integral from x to y of 1/(t-a) dt.
29555  tprop(x,y,a)=log(abs((x-a)/(y-a)))
29556 
29557  xm12=xxm(1)**2
29558  xm22=xxm(2)**2
29559  xm32=xxm(3)**2
29560  s=xxm(4)**2
29561  s13=x
29562  IF(xxm(1).EQ.0.AND.xxm(3).EQ.0d0) THEN
29563  s23ave=0.5d0*(xm22+s-s13)
29564  s23del=0.5d0*sqrt( (x-xm22-s)**2-4d0*xm22*s )
29565  ELSE
29566  s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
29567  s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
29568  & ( (x-xm22-s)**2 -4d0*xm22*s ) )
29569  ENDIF
29570  s23min=(s23ave-s23del)
29571  s23max=(s23ave+s23del)
29572  IF(s23del.LT.1d-3) THEN
29573  pyxxw5=0d0
29574  RETURN
29575  ENDIF
29576  xmv=xxm(9)
29577  xmg=xxm(10)
29578  xmsd=xxm(11)**2
29579  xmsu=xxm(12)**2
29580  ol=xxm(5)
29581  or=xxm(6)
29582  fld=xxm(7)
29583  flu=xxm(8)
29584 
29585  wprop2=((s13-xmv**2)**2+(xmv*xmg)**2)
29586  sij=s13*xxm(2)*xxm(4)
29587  IF(xmv.LE.1000d0) THEN
29588  ww=(or**2+ol**2)*tint(s23max,s23min,xm22,s)
29589  & -2d0*ol*or*sij*(s23max-s23min)
29590  ww=ww/wprop2
29591  IF(xxm(11).LE.10000d0) THEN
29592  wwd=ol*sij*tprop(s23max,s23min,xmsd)
29593  & -or*tint2(s23max,s23min,xm22,s,xmsd)
29594  wwd=-wwd*sr2*fld
29595  wwd=wwd*(s13-xmv**2)/wprop2
29596  ELSE
29597  wwd=0d0
29598  ENDIF
29599  IF(xxm(12).LE.10000d0) THEN
29600  wwu=or*sij*tprop(s23max,s23min,xmsu)
29601  & -ol*tint2(s23max,s23min,xm22,s,xmsu)
29602  wwu=wwu*sr2*flu
29603  wwu=wwu*(s13-xmv**2)/wprop2
29604  ELSE
29605  wwu=0d0
29606  ENDIF
29607  ELSE
29608  ww=0d0
29609  wwd=0d0
29610  wwu=0d0
29611  ENDIF
29612  IF(xxm(12).LE.10000d0) THEN
29613  wu=0.5d0*flu**2*tint3(s23max,s23min,xm22,s,xmsu)
29614  ELSE
29615  wu=0d0
29616  ENDIF
29617  IF(xxm(11).LE.10000d0) THEN
29618  wd=0.5d0*fld**2*tint3(s23max,s23min,xm22,s,xmsd)
29619  ELSE
29620  wd=0d0
29621  ENDIF
29622  IF(xxm(11).LE.10000d0.AND.xxm(12).LE.10000d0) THEN
29623  wud=flu*fld*sij*utint(s23max,s23min,xmsd,xm22+s-s13-xmsu)
29624  ELSE
29625  wud=0d0
29626  ENDIF
29627 
29628  pyxxw5=ww+wu+wd+wwu+wwd+wud
29629 
29630  IF(pyxxw5.LT.0d0) THEN
29631  IF(ik.EQ.0) THEN
29632  WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXW5 '
29633  WRITE(mstu(11),*) ww,wu,wd
29634  WRITE(mstu(11),*) wwd,wwu,wud
29635  WRITE(mstu(11),*) sqrt(s13)
29636  WRITE(mstu(11),*) tint(s23max,s23min,xm22,s)
29637  ik=1
29638  ENDIF
29639  pyxxw5=0d0
29640  ENDIF
29641 
29642  RETURN
29643  END
29644 
29645 C*********************************************************************
29646 
29647 C...PYXXGA
29648 C...Calculates chi0_i -> chi0_j + gamma.
29649 
29650  FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)
29651 
29652 C...Double precision and integer declarations.
29653  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29654  INTEGER pyk,pychge,pycomp
29655 
29656 C...Local variables.
29657  DOUBLE PRECISION pyxxga,c0,xm1,xm2,xmtr,xmtl
29658  DOUBLE PRECISION f1,f2
29659 
29660  f1=(1d0+xmtr/(1d0-xmtr)*log(xmtr))/(1d0-xmtr)
29661  f2=(1d0+xmtl/(1d0-xmtl)*log(xmtl))/(1d0-xmtl)
29662  pyxxga=c0*((xm1**2-xm2**2)/xm1)**3
29663  pyxxga=pyxxga*(2d0/3d0*(f1+f2)-13d0/12d0)**2
29664 
29665  RETURN
29666  END
29667 
29668 C*********************************************************************
29669 
29670 C...PYX2XG
29671 C...Calculates the decay rate for ino -> ino + gauge boson.
29672 
29673  FUNCTION pyx2xg(C1,XM1,XM2,XM3,GL,GR)
29674 
29675 C...Double precision and integer declarations.
29676  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29677  INTEGER pyk,pychge,pycomp
29678 
29679 C...Local variables.
29680  DOUBLE PRECISION pyx2xg,xm1,xm2,xm3,gl,gr
29681  DOUBLE PRECISION xl,pylamf,c1
29682  DOUBLE PRECISION xmi2,xmj2,xmv2,xmi3
29683 
29684  xmi2=xm1**2
29685  xmi3=abs(xm1**3)
29686  xmj2=xm2**2
29687  xmv2=xm3**2
29688  xl=pylamf(xmi2,xmj2,xmv2)
29689  pyx2xg=c1/8d0/xmi3*sqrt(xl)
29690  &*((gl**2+gr**2)*(xl+3d0*xmv2*(xmi2+xmj2-xmv2))-
29691  &12d0*gl*gr*xm1*xm2*xmv2)
29692 
29693  RETURN
29694  END
29695 
29696 C*********************************************************************
29697 
29698 C...PYX2XH
29699 C...Calculates the decay rate for ino -> ino + H.
29700 
29701  FUNCTION pyx2xh(C1,XM1,XM2,XM3,GL,GR)
29702 
29703 C...Double precision and integer declarations.
29704  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29705  INTEGER pyk,pychge,pycomp
29706 
29707 C...Local variables.
29708  DOUBLE PRECISION pyx2xh,xm1,xm2,xm3,gl,gr
29709  DOUBLE PRECISION xl,pylamf,c1
29710  DOUBLE PRECISION xmi2,xmj2,xmv2,xmi3
29711 
29712  xmi2=xm1**2
29713  xmi3=abs(xm1**3)
29714  xmj2=xm2**2
29715  xmv2=xm3**2
29716  xl=pylamf(xmi2,xmj2,xmv2)
29717  pyx2xh=c1/8d0/xmi3*sqrt(xl)
29718  &*((gl**2+gr**2)*(xmi2+xmj2-xmv2)+
29719  &4d0*gl*gr*xm1*xm2)
29720 
29721  RETURN
29722  END
29723 
29724 C*********************************************************************
29725 
29726 C...PYXXZ2
29727 C...Calculates chi+ -> chi+ + f + ~f.
29728 
29729  FUNCTION pyxxz2(X)
29730 
29731 C...Double precision and integer declarations.
29732  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29733  INTEGER pyk,pychge,pycomp
29734 C...Parameter statement to help give large particle numbers.
29735  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29736 C...Commonblocks.
29737  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29738  common/pyints/xxm(20)
29739  SAVE /pydat1/,/pyints/
29740 
29741 C...Local variables.
29742  DOUBLE PRECISION pyxxz2,x
29743  DOUBLE PRECISION xm12,xm22,xm32,s,s23,s13,s12,wprop2
29744  DOUBLE PRECISION ww,wu,wd,wwu,wwd,wud
29745  DOUBLE PRECISION sr2,ol,or,fld,flu,xmv,xmg,xmsl
29746  DOUBLE PRECISION sij
29747  DOUBLE PRECISION le,re,le2,re2,ol2,or2,ct
29748  DOUBLE PRECISION s23min,s23max,s23ave,s23del
29749  INTEGER i
29750  DATA sr2/1.4142136d0/
29751 
29752 C...Statement functions.
29753 C...Integral from x to y of (t-a)(b-t) dt.
29754  tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
29755 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29756  tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
29757  &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
29758 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29759  tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
29760  &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
29761 C...Integral from x to y of 1/(t-a) dt.
29762  tprop(x,y,a)=log(abs((x-a)/(y-a)))
29763 
29764  xm12=xxm(1)**2
29765  xm22=xxm(2)**2
29766  xm32=xxm(3)**2
29767  s=xxm(4)**2
29768  s13=x
29769  IF(xxm(1).EQ.0.AND.xxm(3).EQ.0d0) THEN
29770  s23ave=0.5d0*(xm22+s-s13)
29771  s23del=0.5d0*sqrt( (x-xm22-s)**2-4d0*xm22*s )
29772  ELSE
29773  s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
29774  s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
29775  & ( (x-xm22-s)**2 -4d0*xm22*s ) )
29776  ENDIF
29777  s23min=(s23ave-s23del)
29778  s23max=(s23ave+s23del)
29779  IF(s23del.LT.1d-3) THEN
29780  pyxxz2=0d0
29781  RETURN
29782  ENDIF
29783 
29784  xmv=xxm(9)
29785  xmg=xxm(10)
29786  xmsl=xxm(11)**2
29787  ol=xxm(5)
29788  or=xxm(6)
29789  ol2=ol**2
29790  or2=or**2
29791  le=xxm(7)
29792  re=xxm(8)
29793  le2=le**2
29794  re2=re**2
29795  ct=xxm(12)
29796 
29797  wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
29798  sij=xxm(2)*xxm(4)*s13
29799  ww=(le2+re2)*(or2+ol2)*2d0*tint(s23max,s23min,xm22,s)
29800  &- 4d0*(le2+re2)*ol*or*sij*(s23max-s23min)
29801  ww=ww/wprop2
29802  IF(xmsl.GT.1d4*s) THEN
29803  wd=0d0
29804  wwd=0d0
29805  ELSE
29806  wd=0.5d0*ct**2*tint3(s23max,s23min,xm22,s,xmsl)
29807  wwd=ol*tint2(s23max,s23min,xm22,s,xmsl)-
29808  & or*sij*tprop(s23max,s23min,xmsl)
29809  wwd=2d0*wwd*le*ct*(s13-xmv**2)/wprop2
29810  ENDIF
29811 
29812  pyxxz2=(ww+wd+wwd)
29813  IF(pyxxz2.LT.0d0) THEN
29814  WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ2 '
29815  WRITE(mstu(11),*) ww,wd,wwd
29816  WRITE(mstu(11),*) s23min,s23max
29817  WRITE(mstu(11),*) (xxm(i),i=1,4)
29818  WRITE(mstu(11),*) (xxm(i),i=5,8)
29819  WRITE(mstu(11),*) (xxm(i),i=9,12)
29820  pyxxz2=0d0
29821  ENDIF
29822 
29823  RETURN
29824  END
29825 
29826 C*********************************************************************
29827 
29828 C...PYHEXT
29829 C...Calculates the non-standard decay modes of the Higgs boson.
29830 
29831  SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)
29832 
29833 C...Double precision and integer declarations.
29834  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29835  INTEGER pyk,pychge,pycomp
29836 C...Parameter statement to help give large particle numbers.
29837  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
29838 C...Commonblocks.
29839  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29840  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29841  common/pypars/mstp(200),parp(200),msti(200),pari(200)
29842  common/pymssm/imss(0:99),rmss(0:99)
29843  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
29844  &sfmix(16,4)
29845  SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/,/pyssmt/
29846 
29847 C...Local variables.
29848  INTEGER kfin
29849  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,
29850  &xmz,xmz2,axmj,axmi
29851  DOUBLE PRECISION xmfp,xmf1,xmf2,xmsl,xmg
29852  DOUBLE PRECISION s12min,s12max
29853  DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xmhp2,xma2,xmb2
29854  DOUBLE PRECISION pylamf,xl,cf,ei
29855  INTEGER idu,ic,ilr,ifl
29856  DOUBLE PRECISION tanw,xw,aem,c1,as
29857  DOUBLE PRECISION pyh2xx,ghll,ghrr,ghlr
29858  DOUBLE PRECISION xlam(0:200)
29859  INTEGER idlam(200,3)
29860  INTEGER lknt,ix,ih,j,ij,i,iknt,ik
29861  INTEGER ith(4)
29862  INTEGER kfnchi(4),kfcchi(2)
29863  DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)
29864  DOUBLE PRECISION sr2
29865  DOUBLE PRECISION beta,alfa
29866  DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k,tanb
29867  DOUBLE PRECISION pyalem,pi,pyalps
29868  DOUBLE PRECISION al,bl,ar,br,alp,arp,blp,brp,alr
29869  DOUBLE PRECISION xmk,axmk,xmk2,cosa,sina,cw,xml
29870  DOUBLE PRECISION xmuz,atrit,atrib,atril
29871  DOUBLE PRECISION xmjl,xmjr,xm1,xm2
29872  DATA ith/25,35,36,37/
29873  DATA etah/1d0,1d0,-1d0/
29874  DATA sr2/1.4142136d0/
29875  DATA pi/3.141592654d0/
29876  DATA kfnchi/1000022,1000023,1000025,1000035/
29877  DATA kfcchi/1000024,1000037/
29878 
29879 C...COUNT THE NUMBER OF DECAY MODES
29880  lknt=iknt
29881 
29882  xmw=pmas(24,1)
29883  xmw2=xmw**2
29884  xmz=pmas(23,1)
29885  xmz2=xmz**2
29886  xw=paru(102)
29887  tanw = sqrt(xw/(1d0-xw))
29888  cw=sqrt(1d0-xw)
29889 
29890 C...1 - 4 DEPENDING ON Higgs species.
29891  ih=1
29892  IF(kfin.EQ.ith(2)) ih=2
29893  IF(kfin.EQ.ith(3)) ih=3
29894  IF(kfin.EQ.ith(4)) ih=4
29895 
29896  xmi=pmas(kfin,1)
29897  xmi2=xmi**2
29898  axmi=abs(xmi)
29899  aem=pyalem(xmi2)
29900  as =pyalps(xmi2)
29901  c1=aem/xw
29902  xmi3=abs(xmi**3)
29903 
29904  tanb=rmss(5)
29905  beta=atan(tanb)
29906  cbeta=cos(beta)
29907  sbeta=tanb*cbeta
29908  alfa=rmss(18)
29909  cosa=cos(alfa)
29910  sina=sin(alfa)
29911  atrit=rmss(16)
29912  atrib=rmss(15)
29913  atril=rmss(17)
29914  xmuz=-rmss(4)
29915 
29916  IF(ih.EQ.4) goto 180
29917 
29918 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
29919 C...H0_K -> CHI0_I + CHI0_J
29920  eh(1)=sina
29921  eh(2)=cosa
29922  eh(3)=-sbeta
29923  dh(1)=cosa
29924  dh(2)=-sina
29925  dh(3)=cbeta
29926  DO 110 ij=1,4
29927  xmj=smz(ij)
29928  axmj=abs(xmj)
29929  DO 100 ik=1,ij
29930  xmk=smz(ik)
29931  axmk=abs(xmk)
29932  IF(axmi.GE.axmj+axmk) THEN
29933  lknt=lknt+1
29934  f21k=0.5d0*
29935  & eh(ih)*( zmix(ik,3)*zmix(ij,2)+zmix(ij,3)*zmix(ik,2)
29936  & -tanw*(zmix(ik,3)*zmix(ij,1)+zmix(ij,3)*zmix(ik,1)) )+
29937  & 0.5d0*dh(ih)*( zmix(ik,4)*zmix(ij,2)+zmix(ij,4)*zmix(ik,2)
29938  & -tanw*(zmix(ik,4)*zmix(ij,1)+zmix(ij,4)*zmix(ik,1)) )
29939  f12k=0.5d0*
29940  & eh(ih)*(zmix(ij,3)*zmix(ik,2)+zmix(ik,3)*zmix(ij,2)
29941  & -tanw*(zmix(ij,3)*zmix(ik,1)+zmix(ik,3)*zmix(ij,1)))+
29942  & 0.5d0*dh(ih)*( zmix(ij,4)*zmix(ik,2)+zmix(ik,4)*zmix(ij,2)
29943  & -tanw*(zmix(ij,4)*zmix(ik,1)+zmix(ik,4)*zmix(ij,1)) )
29944 C...SIGN OF MASSES I,J
29945  xml=xmk*etah(ih)
29946  xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,f12k,f21k)
29947  IF(ij.EQ.ik) xlam(lknt)=xlam(lknt)*0.5d0
29948  idlam(lknt,1)=kfnchi(ij)
29949  idlam(lknt,2)=kfnchi(ik)
29950  idlam(lknt,3)=0
29951  ENDIF
29952  100 CONTINUE
29953  110 CONTINUE
29954 
29955 C...H0_K -> CHI+_I CHI-_J
29956  DO 130 ij=1,2
29957  xmj=smw(ij)
29958  axmj=abs(xmj)
29959  DO 120 ik=1,2
29960  xmk=smw(ik)
29961  axmk=abs(xmk)
29962  IF(axmi.GE.axmj+axmk) THEN
29963  lknt=lknt+1
29964  f21k=(vmix(ij,1)*umix(ik,2)*eh(ih) -
29965  & vmix(ij,2)*umix(ik,1)*dh(ih))/sr2
29966  f12k=(vmix(ik,1)*umix(ij,2)*eh(ih) -
29967  & vmix(ik,2)*umix(ij,1)*dh(ih))/sr2
29968  xml=-xmk*etah(ih)
29969  xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,f12k,f21k)
29970  idlam(lknt,1)=kfcchi(ij)
29971  idlam(lknt,2)=-kfcchi(ik)
29972  idlam(lknt,3)=0
29973  ENDIF
29974  120 CONTINUE
29975  130 CONTINUE
29976 
29977 C...HIGGS TO SFERMION SFERMION
29978  DO 160 ifl=1,16
29979  IF(ifl.GE.7.AND.ifl.LE.10) goto 160
29980  ij=ksusy1+ifl
29981  xmjl=pmas(pycomp(ij),1)
29982  xmjr=pmas(pycomp(ij+ksusy1),1)
29983  IF(axmi.GE.2d0*min(xmjl,xmjr)) THEN
29984  xmj=xmjl
29985  xmj2=xmj**2
29986  xl=pylamf(xmi2,xmj2,xmj2)
29987  xmf=pmas(ifl,1)
29988  ei=kchg(ifl,1)/3d0
29989  idu=2-mod(ifl,2)
29990 
29991  IF(ih.EQ.1) THEN
29992  IF(idu.EQ.1) THEN
29993  ghll=-xmz/cw*(0.5d0+ei*xw)*sin(alfa+beta)+
29994  & xmf**2/xmw*sina/cbeta
29995  ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)+
29996  & xmf**2/xmw*sina/cbeta
29997  IF(ifl.EQ.5) THEN
29998  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
29999  & atrib*sina)
30000  ELSEIF(ifl.EQ.15) THEN
30001  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
30002  & atril*sina)
30003  ELSE
30004  ghlr=0d0
30005  ENDIF
30006  ELSE
30007  ghll=xmz/cw*(0.5d0-ei*xw)*sin(alfa+beta)-
30008  & xmf**2/xmw*cosa/sbeta
30009  ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)-
30010  & xmf**2/xmw*cosa/sbeta
30011  IF(ifl.EQ.6) THEN
30012  ghlr=xmf/2d0/xmw/sbeta*(xmuz*sina-
30013  & atrit*cosa)
30014  ELSE
30015  ghlr=0d0
30016  ENDIF
30017  ENDIF
30018 
30019  ELSEIF(ih.EQ.2) THEN
30020  IF(idu.EQ.1) THEN
30021  ghll=xmz/cw*(0.5d0+ei*xw)*cos(alfa+beta)-
30022  & xmf**2/xmw*cosa/cbeta
30023  ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
30024  & xmf**2/xmw*cosa/cbeta
30025  IF(ifl.EQ.5) THEN
30026  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
30027  & atrib*cosa)
30028  ELSEIF(ifl.EQ.15) THEN
30029  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
30030  & atril*cosa)
30031  ELSE
30032  ghlr=0d0
30033  ENDIF
30034  ELSE
30035  ghll=-xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)-
30036  & xmf**2/xmw*sina/sbeta
30037  ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
30038  & xmf**2/xmw*sina/sbeta
30039  IF(ifl.EQ.6) THEN
30040  ghlr=-xmf/2d0/xmw/sbeta*(xmuz*cosa+
30041  & atrit*sina)
30042  ELSE
30043  ghlr=0d0
30044  ENDIF
30045  ENDIF
30046 
30047  ELSEIF(ih.EQ.3) THEN
30048  ghll=0d0
30049  ghrr=0d0
30050  ghlr=0d0
30051  IF(idu.EQ.1) THEN
30052  IF(ifl.EQ.5) THEN
30053  ghlr=xmf/2d0/xmw*(atrib*tanb-xmuz)
30054  ELSEIF(ifl.EQ.15) THEN
30055  ghlr=xmf/2d0/xmw*(atril*tanb-xmuz)
30056  ENDIF
30057  ELSE
30058  IF(ifl.EQ.6) THEN
30059  ghlr=xmf/2d0/xmw*(atrit/tanb-xmuz)
30060  ENDIF
30061  ENDIF
30062  ENDIF
30063  IF(ih.EQ.3) goto 140
30064 
30065  al=sfmix(ifl,1)**2
30066  ar=sfmix(ifl,2)**2
30067  alr=sfmix(ifl,1)*sfmix(ifl,2)
30068  IF(ifl.LE.6) THEN
30069  cf=3d0
30070  ELSE
30071  cf=1d0
30072  ENDIF
30073 
30074  IF(axmi.GE.2d0*xmj) THEN
30075  lknt=lknt+1
30076  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30077  & (ghll*al+ghrr*ar
30078  & +2d0*ghlr*alr)**2
30079  idlam(lknt,1)=ij
30080  idlam(lknt,2)=-ij
30081  idlam(lknt,3)=0
30082  ENDIF
30083 
30084  IF(axmi.GE.2d0*xmjr) THEN
30085  lknt=lknt+1
30086  al=sfmix(ifl,3)**2
30087  ar=sfmix(ifl,4)**2
30088  alr=sfmix(ifl,3)*sfmix(ifl,4)
30089  xmj=xmjr
30090  xmj2=xmj**2
30091  xl=pylamf(xmi2,xmj2,xmj2)
30092  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30093  & (ghll*al+ghrr*ar
30094  & +2d0*ghlr*alr)**2
30095  idlam(lknt,1)=ij+ksusy1
30096  idlam(lknt,2)=-(ij+ksusy1)
30097  idlam(lknt,3)=0
30098  ENDIF
30099  140 CONTINUE
30100 
30101  IF(axmi.GE.xmjl+xmjr) THEN
30102  lknt=lknt+1
30103  al=sfmix(ifl,1)*sfmix(ifl,3)
30104  ar=sfmix(ifl,2)*sfmix(ifl,4)
30105  alr=sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,2)*sfmix(ifl,3)
30106  xmj=xmjr
30107  xmj2=xmj**2
30108  xl=pylamf(xmi2,xmj2,xmjl**2)
30109  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30110  & (ghll*al+ghrr*ar)**2
30111  idlam(lknt,1)=ij
30112  idlam(lknt,2)=-(ij+ksusy1)
30113  idlam(lknt,3)=0
30114  lknt=lknt+1
30115  idlam(lknt,1)=-ij
30116  idlam(lknt,2)=ij+ksusy1
30117  idlam(lknt,3)=0
30118  xlam(lknt)=xlam(lknt-1)
30119  ENDIF
30120  ENDIF
30121  150 CONTINUE
30122  160 CONTINUE
30123  170 CONTINUE
30124 
30125  goto 230
30126  180 CONTINUE
30127 
30128 C...H+ -> CHI+_I + CHI0_J
30129  DO 200 ij=1,4
30130  xmj=smz(ij)
30131  axmj=abs(xmj)
30132  xmj2=xmj**2
30133  DO 190 ik=1,2
30134  xmk=smw(ik)
30135  axmk=abs(xmk)
30136  xmk2=xmk**2
30137  IF(axmi.GE.axmj+axmk) THEN
30138  lknt=lknt+1
30139  gl=cbeta*(zmix(ij,4)*vmix(ik,1)+(zmix(ij,2)+zmix(ij,1)*
30140  & tanw)*vmix(ik,2)/sr2)
30141  gr=sbeta*(zmix(ij,3)*umix(ik,1)-(zmix(ij,2)+zmix(ij,1)*
30142  & tanw)*umix(ik,2)/sr2)
30143  xlam(lknt)=pyh2xx(c1,xmi,xmj,-xmk,gl,gr)
30144  idlam(lknt,1)=kfnchi(ij)
30145  idlam(lknt,2)=kfcchi(ik)
30146  idlam(lknt,3)=0
30147  ENDIF
30148  190 CONTINUE
30149  200 CONTINUE
30150 
30151  gl=-xmw/sr2*(sin(2d0*beta)-pmas(6,1)**2/tanb/xmw2)
30152  gr=-pmas(6,1)/sr2/xmw*(xmuz-atrit/tanb)
30153  al=0d0
30154  ar=0d0
30155  cf=3d0
30156 
30157 C...H+ -> T_1 B_1~
30158  xm1=pmas(pycomp(ksusy1+6),1)
30159  xm2=pmas(pycomp(ksusy1+5),1)
30160  IF(xmi.GE.xm1+xm2) THEN
30161  xl=pylamf(xmi2,xm1**2,xm2**2)
30162  lknt=lknt+1
30163  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30164  & (gl*sfmix(6,1)*sfmix(5,1)+gr*sfmix(6,2)*sfmix(5,1))**2
30165  idlam(lknt,1)=ksusy1+6
30166  idlam(lknt,2)=-(ksusy1+5)
30167  idlam(lknt,3)=0
30168  ENDIF
30169 
30170 C...H+ -> T_2 B_1~
30171  xm1=pmas(pycomp(ksusy2+6),1)
30172  xm2=pmas(pycomp(ksusy1+5),1)
30173  IF(xmi.GE.xm1+xm2) THEN
30174  xl=pylamf(xmi2,xm1**2,xm2**2)
30175  lknt=lknt+1
30176  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30177  & (gl*sfmix(6,3)*sfmix(5,1)+gr*sfmix(6,4)*sfmix(5,1))**2
30178  idlam(lknt,1)=ksusy2+6
30179  idlam(lknt,2)=-(ksusy1+5)
30180  idlam(lknt,3)=0
30181  ENDIF
30182 
30183 C...H+ -> T_1 B_2~
30184  xm1=pmas(pycomp(ksusy1+6),1)
30185  xm2=pmas(pycomp(ksusy2+5),1)
30186  IF(xmi.GE.xm1+xm2) THEN
30187  xl=pylamf(xmi2,xm1**2,xm2**2)
30188  lknt=lknt+1
30189  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30190  & (gl*sfmix(6,1)*sfmix(5,3)+gr*sfmix(6,2)*sfmix(5,3))**2
30191  idlam(lknt,1)=ksusy1+6
30192  idlam(lknt,2)=-(ksusy2+5)
30193  idlam(lknt,3)=0
30194  ENDIF
30195 
30196 C...H+ -> T_2 B_2~
30197  xm1=pmas(pycomp(ksusy2+6),1)
30198  xm2=pmas(pycomp(ksusy2+5),1)
30199  IF(xmi.GE.xm1+xm2) THEN
30200  xl=pylamf(xmi2,xm1**2,xm2**2)
30201  lknt=lknt+1
30202  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
30203  & (gl*sfmix(6,3)*sfmix(5,3)+gr*sfmix(6,4)*sfmix(5,3))**2
30204  idlam(lknt,1)=ksusy2+6
30205  idlam(lknt,2)=-(ksusy2+5)
30206  idlam(lknt,3)=0
30207  ENDIF
30208 
30209 C...H+ -> UL DL~
30210  gl=-xmw/sr2*sin(2d0*beta)
30211  DO 210 ij=1,3,2
30212  xm1=pmas(pycomp(ksusy1+ij),1)
30213  xm2=pmas(pycomp(ksusy1+ij+1),1)
30214  IF(xmi.GE.xm1+xm2) THEN
30215  xl=pylamf(xmi2,xm1**2,xm2**2)
30216  lknt=lknt+1
30217  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2
30218  idlam(lknt,1)=-(ksusy1+ij)
30219  idlam(lknt,2)=ksusy1+ij+1
30220  idlam(lknt,3)=0
30221  ENDIF
30222  210 CONTINUE
30223 
30224 C...H+ -> EL~ NUL
30225  cf=1d0
30226  DO 220 ij=11,13,2
30227  xm1=pmas(pycomp(ksusy1+ij),1)
30228  xm2=pmas(pycomp(ksusy1+ij+1),1)
30229  IF(xmi.GE.xm1+xm2) THEN
30230  xl=pylamf(xmi2,xm1**2,xm2**2)
30231  lknt=lknt+1
30232  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2
30233  idlam(lknt,1)=-(ksusy1+ij)
30234  idlam(lknt,2)=ksusy1+ij+1
30235  idlam(lknt,3)=0
30236  ENDIF
30237  220 CONTINUE
30238 
30239 C...H+ -> TAU1 NUTAUL
30240  xm1=pmas(pycomp(ksusy1+15),1)
30241  xm2=pmas(pycomp(ksusy1+16),1)
30242  IF(xmi.GE.xm1+xm2) THEN
30243  xl=pylamf(xmi2,xm1**2,xm2**2)
30244  lknt=lknt+1
30245  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2*sfmix(15,1)**2
30246  idlam(lknt,1)=-(ksusy1+15)
30247  idlam(lknt,2)= ksusy1+16
30248  idlam(lknt,3)=0
30249  ENDIF
30250 
30251 C...H+ -> TAU2 NUTAUL
30252  xm1=pmas(pycomp(ksusy2+15),1)
30253  xm2=pmas(pycomp(ksusy1+16),1)
30254  IF(xmi.GE.xm1+xm2) THEN
30255  xl=pylamf(xmi2,xm1**2,xm2**2)
30256  lknt=lknt+1
30257  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2*sfmix(15,3)**2
30258  idlam(lknt,1)=-(ksusy2+15)
30259  idlam(lknt,2)= ksusy1+16
30260  idlam(lknt,3)=0
30261  ENDIF
30262 
30263  230 CONTINUE
30264  iknt=lknt
30265  xlam(0)=0d0
30266  DO 240 i=1,iknt
30267  IF(xlam(i).LE.0d0) xlam(i)=0d0
30268  xlam(0)=xlam(0)+xlam(i)
30269  240 CONTINUE
30270  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
30271 
30272  RETURN
30273  END
30274 
30275 C*********************************************************************
30276 
30277 C...PYH2XX
30278 C...Calculates the decay rate for a Higgs to an ino pair.
30279 
30280  FUNCTION pyh2xx(C1,XM1,XM2,XM3,GL,GR)
30281 
30282 C...Double precision and integer declarations.
30283  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30284  INTEGER pyk,pychge,pycomp
30285 C...Commonblocks.
30286  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30287  SAVE /pydat1/
30288 
30289 C...Local variables.
30290  DOUBLE PRECISION pyh2xx,xm1,xm2,xm3,gl,gr
30291  DOUBLE PRECISION xl,pylamf,c1
30292  DOUBLE PRECISION xmi2,xmj2,xmk2,xmi3
30293 
30294  xmi2=xm1**2
30295  xmi3=abs(xm1**3)
30296  xmj2=xm2**2
30297  xmk2=xm3**2
30298  xl=pylamf(xmi2,xmj2,xmk2)
30299  pyh2xx=c1/4d0/xmi3*sqrt(xl)
30300  &*((gl**2+gr**2)*(xmi2-xmj2-xmk2)-
30301  &4d0*gl*gr*xm3*xm2)
30302  IF(pyh2xx.LT.0d0) THEN
30303  WRITE(mstu(11),*) ' NEGATIVE WIDTH IN PYH2XX '
30304  WRITE(mstu(11),*) xmi2,xmj2,xmk2,gl,gr,xm1,xm2,xm3
30305  stop
30306  ENDIF
30307 
30308  RETURN
30309  END
30310 
30311 C*********************************************************************
30312 
30313 C...PYGAUS
30314 C...Integration by adaptive Gaussian quadrature.
30315 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
30316 
30317  FUNCTION pygaus(F, A, B, EPS)
30318 
30319 C...Double precision and integer declarations.
30320  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30321  INTEGER pyk,pychge,pycomp
30322 
30323 C...Local declarations.
30324  EXTERNAL f
30325  DOUBLE PRECISION w(12), x(12)
30326  DATA x( 1) /9.6028985649753623d-1/, w( 1) /1.0122853629037626d-1/
30327  DATA x( 2) /7.9666647741362674d-1/, w( 2) /2.2238103445337447d-1/
30328  DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
30329  DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
30330  DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
30331  DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
30332  DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
30333  DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
30334  DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
30335  DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
30336  DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
30337  DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
30338 
30339 C...The Gaussian quadrature algorithm.
30340  h = 0d0
30341  IF(b .EQ. a) go to 140
30342  const = 5d-3 / abs(b-a)
30343  bb = a
30344  100 CONTINUE
30345  aa = bb
30346  bb = b
30347  110 CONTINUE
30348  c1 = 0.5d0*(bb+aa)
30349  c2 = 0.5d0*(bb-aa)
30350  s8 = 0d0
30351  DO 120 i = 1, 4
30352  u = c2*x(i)
30353  s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
30354  120 CONTINUE
30355  s16 = 0d0
30356  DO 130 i = 5, 12
30357  u = c2*x(i)
30358  s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
30359  130 CONTINUE
30360  s16 = c2*s16
30361  IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
30362  h = h + s16
30363  IF(bb .NE. b) go to 100
30364  ELSE
30365  bb = c1
30366  IF(1d0 + const*abs(c2) .NE. 1d0) go to 110
30367  h = 0d0
30368  CALL pyerrm(18,'(PYGAUS:) too high accuracy required')
30369  go to 140
30370  ENDIF
30371  140 CONTINUE
30372  pygaus = h
30373 
30374  RETURN
30375  END
30376 
30377 C*********************************************************************
30378 
30379 C...PYSIMP
30380 C...Simpson formula for an integral.
30381 
30382  FUNCTION pysimp(Y,X0,X1,N)
30383 
30384 C...Double precision and integer declarations.
30385  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30386  INTEGER pyk,pychge,pycomp
30387 
30388 C...Local variables.
30389  DOUBLE PRECISION y,x0,x1,h,s
30390  dimension y(0:n)
30391 
30392  s=0d0
30393  h=(x1-x0)/n
30394  DO 100 i=0,n-2,2
30395  s=s+y(i)+4d0*y(i+1)+y(i+2)
30396  100 CONTINUE
30397  pysimp=s*h/3d0
30398 
30399  RETURN
30400  END
30401 
30402 C*********************************************************************
30403 
30404 C...PYLAMF
30405 C...The standard lambda function.
30406 
30407  FUNCTION pylamf(X,Y,Z)
30408 
30409 C...Double precision and integer declarations.
30410  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30411  INTEGER pyk,pychge,pycomp
30412 
30413 C...Local variables.
30414  DOUBLE PRECISION pylamf,x,y,z
30415 
30416  pylamf=(x-(y+z))**2-4d0*y*z
30417  IF(pylamf.LT.0d0) pylamf=0d0
30418 
30419  RETURN
30420  END
30421 
30422 C*********************************************************************
30423 
30424 C...PYTBDY
30425 C...Generates 3-body decays of gauginos.
30426 
30427  SUBROUTINE pytbdy(XM)
30428 
30429 C...Double precision and integer declarations.
30430  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30431  INTEGER pyk,pychge,pycomp
30432 C...Parameter statement to help give large particle numbers.
30433  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
30434 C...Commonblocks.
30435  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
30436  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30437  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30438  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
30439  common/pypars/mstp(200),parp(200),msti(200),pari(200)
30440  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pypars/
30441 
30442 C...Local variables.
30443  DOUBLE PRECISION xm(5)
30444  DOUBLE PRECISION s12min,s12max,yjaco1,s23ave,s23df1,s23df2
30445  DOUBLE PRECISION d1,d2,d3,p1,p2,p3,cthe1,sthe1,cthe3,sthe3
30446  DOUBLE PRECISION cphi1,sphi1
30447  DOUBLE PRECISION s23del,eps
30448  DOUBLE PRECISION golden,ax,bx,cx,tol,xmin,r,c
30449  parameter(r=0.61803399d0,c=1d0-r,tol=1d-3)
30450  DOUBLE PRECISION f1,f2,x0,x1,x2,x3
30451  DATA eps/1d-6/
30452 
30453 C...GENERATE S12
30454  s12min=(xm(1)+xm(2))**2
30455  s12max=(xm(5)-xm(3))**2
30456  yjaco1=s12max-s12min
30457 
30458 C...FIND S12*
30459  ax=s12min
30460  cx=s12max
30461  bx=s12min+0.5d0*yjaco1
30462  x0=ax
30463  x3=cx
30464  IF(abs(cx-bx).GT.abs(bx-ax))THEN
30465  x1=bx
30466  x2=bx+c*(cx-bx)
30467  ELSE
30468  x2=bx
30469  x1=bx-c*(bx-ax)
30470  ENDIF
30471 
30472 C...SOLVE FOR F1 AND F2
30473  s23df1=(x1-xm(2)**2-xm(1)**2)**2
30474  &-(2d0*xm(1)*xm(2))**2
30475  s23df2=(x1-xm(3)**2-xm(5)**2)**2
30476  &-(2d0*xm(3)*xm(5))**2
30477  s23df1=s23df1*eps
30478  s23df2=s23df2*eps
30479  s23del=sqrt(s23df1*s23df2)/(2d0*x1)
30480  f1=-2d0*s23del/eps
30481  s23df1=(x2-xm(2)**2-xm(1)**2)**2
30482  &-(2d0*xm(1)*xm(2))**2
30483  s23df2=(x2-xm(3)**2-xm(5)**2)**2
30484  &-(2d0*xm(3)*xm(5))**2
30485  s23df1=s23df1*eps
30486  s23df2=s23df2*eps
30487  s23del=sqrt(s23df1*s23df2)/(2d0*x2)
30488  f2=-2d0*s23del/eps
30489 
30490  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2)))THEN
30491  IF(f2.LT.f1)THEN
30492  x0=x1
30493  x1=x2
30494  x2=r*x1+c*x3
30495  f1=f2
30496  s23df1=(x2-xm(2)**2-xm(1)**2)**2
30497  & -(2d0*xm(1)*xm(2))**2
30498  s23df2=(x2-xm(3)**2-xm(5)**2)**2
30499  & -(2d0*xm(3)*xm(5))**2
30500  s23df1=s23df1*eps
30501  s23df2=s23df2*eps
30502  s23del=sqrt(s23df1*s23df2)/(2d0*x2)
30503  f2=-2d0*s23del/eps
30504  ELSE
30505  x3=x2
30506  x2=x1
30507  x1=r*x2+c*x0
30508  f2=f1
30509  s23df1=(x1-xm(2)**2-xm(1)**2)**2
30510  & -(2d0*xm(1)*xm(2))**2
30511  s23df2=(x1-xm(3)**2-xm(5)**2)**2
30512  & -(2d0*xm(3)*xm(5))**2
30513  s23df1=s23df1*eps
30514  s23df2=s23df2*eps
30515  s23del=sqrt(s23df1*s23df2)/(2d0*x1)
30516  f1=-2d0*s23del/eps
30517  ENDIF
30518  goto 100
30519  ENDIF
30520 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
30521  IF(f1.LT.f2)THEN
30522  golden=-f1
30523  xmin=x1
30524  ELSE
30525  golden=-f2
30526  xmin=x2
30527  ENDIF
30528 
30529  iknt=0
30530  110 s12=s12min+pyr(0)*yjaco1
30531  iknt=iknt+1
30532 C...GENERATE S23
30533  s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
30534  &*(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
30535  s23df1=(s12-xm(2)**2-xm(1)**2)**2
30536  &-(2d0*xm(1)*xm(2))**2
30537  s23df2=(s12-xm(3)**2-xm(5)**2)**2
30538  &-(2d0*xm(3)*xm(5))**2
30539  s23df1=s23df1*eps
30540  s23df2=s23df2*eps
30541  s23del=sqrt(s23df1*s23df2)/(2d0*s12)
30542  s23del=s23del/eps
30543  s23min=s23ave-s23del
30544  s23max=s23ave+s23del
30545  yjaco2=s23max-s23min
30546  s23=s23min+pyr(0)*yjaco2
30547 
30548 C...CHECK THE SAMPLING
30549  IF(iknt.GT.100) THEN
30550  WRITE(mstu(11),*) ' IKNT > 100 IN PYTBDY '
30551  goto 120
30552  ENDIF
30553  IF(yjaco2.LT.pyr(0)*golden) goto 110
30554  120 d3=(xm(5)**2+xm(3)**2-s12)/(2d0*xm(5))
30555  d1=(xm(5)**2+xm(1)**2-s23)/(2d0*xm(5))
30556  d2=xm(5)-d1-d3
30557  p1=sqrt(d1*d1-xm(1)**2)
30558  p2=sqrt(d2*d2-xm(2)**2)
30559  p3=sqrt(d3*d3-xm(3)**2)
30560  cthe1=2d0*pyr(0)-1d0
30561  ang1=2d0*pyr(0)*paru(1)
30562  cphi1=cos(ang1)
30563  sphi1=sin(ang1)
30564  arg=1d0-cthe1**2
30565  IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
30566  sthe1=sqrt(arg)
30567  p(n+1,1)=p1*sthe1*cphi1
30568  p(n+1,2)=p1*sthe1*sphi1
30569  p(n+1,3)=p1*cthe1
30570  p(n+1,4)=d1
30571 
30572 C...GET CPHI3
30573  ang3=2d0*pyr(0)*paru(1)
30574  cphi3=cos(ang3)
30575  sphi3=sin(ang3)
30576  cthe3=(p2**2-p1**2-p3**2)/2d0/p1/p3
30577  arg=1d0-cthe3**2
30578  IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
30579  sthe3=sqrt(arg)
30580  p(n+3,1)=-p3*sthe3*cphi3*cthe1*cphi1
30581  &+p3*sthe3*sphi3*sphi1
30582  &+p3*cthe3*sthe1*cphi1
30583  p(n+3,2)=-p3*sthe3*cphi3*cthe1*sphi1
30584  &-p3*sthe3*sphi3*cphi1
30585  &+p3*cthe3*sthe1*sphi1
30586  p(n+3,3)=p3*sthe3*cphi3*sthe1
30587  &+p3*cthe3*cthe1
30588  p(n+3,4)=d3
30589 
30590  DO 130 i=1,3
30591  p(n+2,i)=-p(n+1,i)-p(n+3,i)
30592  130 CONTINUE
30593  p(n+2,4)=d2
30594 
30595  RETURN
30596  END
30597 
30598 C*********************************************************************
30599 
30600 C...PY1ENT
30601 C...Stores one parton/particle in commonblock PYJETS.
30602 
30603  SUBROUTINE py1ent(IP,KF,PE,THE,PHI)
30604 
30605 C...Double precision and integer declarations.
30606  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30607  INTEGER pyk,pychge,pycomp
30608 C...Commonblocks.
30609  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
30610  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30611  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30612  SAVE /pyjets/,/pydat1/,/pydat2/
30613 
30614 C...Standard checks.
30615  mstu(28)=0
30616  IF(mstu(12).GE.1) CALL pylist(0)
30617  ipa=max(1,iabs(ip))
30618  IF(ipa.GT.mstu(4)) CALL pyerrm(21,
30619  &'(PY1ENT:) writing outside PYJETS memory')
30620  kc=pycomp(kf)
30621  IF(kc.EQ.0) CALL pyerrm(12,'(PY1ENT:) unknown flavour code')
30622 
30623 C...Find mass. Reset K, P and V vectors.
30624  pm=0d0
30625  IF(mstu(10).EQ.1) pm=p(ipa,5)
30626  IF(mstu(10).GE.2) pm=pymass(kf)
30627  DO 100 j=1,5
30628  k(ipa,j)=0
30629  p(ipa,j)=0d0
30630  v(ipa,j)=0d0
30631  100 CONTINUE
30632 
30633 C...Store parton/particle in K and P vectors.
30634  k(ipa,1)=1
30635  IF(ip.LT.0) k(ipa,1)=2
30636  k(ipa,2)=kf
30637  p(ipa,5)=pm
30638  p(ipa,4)=max(pe,pm)
30639  pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
30640  p(ipa,1)=pa*sin(the)*cos(phi)
30641  p(ipa,2)=pa*sin(the)*sin(phi)
30642  p(ipa,3)=pa*cos(the)
30643 
30644 C...Set N. Optionally fragment/decay.
30645  n=ipa
30646  IF(ip.EQ.0) CALL pyexec
30647 
30648  RETURN
30649  END
30650 
30651 C*********************************************************************
30652 
30653 C...PY2ENT
30654 C...Stores two partons/particles in their CM frame,
30655 C...with the first along the +z axis.
30656 
30657  SUBROUTINE py2ent(IP,KF1,KF2,PECM)
30658 
30659 C...Double precision and integer declarations.
30660  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30661  INTEGER pyk,pychge,pycomp
30662 C...Commonblocks.
30663  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
30664  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30665  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30666  SAVE /pyjets/,/pydat1/,/pydat2/
30667 
30668 C...Standard checks.
30669  mstu(28)=0
30670  IF(mstu(12).GE.1) CALL pylist(0)
30671  ipa=max(1,iabs(ip))
30672  IF(ipa.GT.mstu(4)-1) CALL pyerrm(21,
30673  &'(PY2ENT:) writing outside PYJETS memory')
30674  kc1=pycomp(kf1)
30675  kc2=pycomp(kf2)
30676  IF(kc1.EQ.0.OR.kc2.EQ.0) CALL pyerrm(12,
30677  &'(PY2ENT:) unknown flavour code')
30678 
30679 C...Find masses. Reset K, P and V vectors.
30680  pm1=0d0
30681  IF(mstu(10).EQ.1) pm1=p(ipa,5)
30682  IF(mstu(10).GE.2) pm1=pymass(kf1)
30683  pm2=0d0
30684  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
30685  IF(mstu(10).GE.2) pm2=pymass(kf2)
30686  DO 110 i=ipa,ipa+1
30687  DO 100 j=1,5
30688  k(i,j)=0
30689  p(i,j)=0d0
30690  v(i,j)=0d0
30691  100 CONTINUE
30692  110 CONTINUE
30693 
30694 C...Check flavours.
30695  kq1=kchg(kc1,2)*isign(1,kf1)
30696  kq2=kchg(kc2,2)*isign(1,kf2)
30697  IF(mstu(19).EQ.1) THEN
30698  mstu(19)=0
30699  ELSE
30700  IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL pyerrm(2,
30701  & '(PY2ENT:) unphysical flavour combination')
30702  ENDIF
30703  k(ipa,2)=kf1
30704  k(ipa+1,2)=kf2
30705 
30706 C...Store partons/particles in K vectors for normal case.
30707  IF(ip.GE.0) THEN
30708  k(ipa,1)=1
30709  IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
30710  k(ipa+1,1)=1
30711 
30712 C...Store partons in K vectors for parton shower evolution.
30713  ELSE
30714  k(ipa,1)=3
30715  k(ipa+1,1)=3
30716  k(ipa,4)=mstu(5)*(ipa+1)
30717  k(ipa,5)=k(ipa,4)
30718  k(ipa+1,4)=mstu(5)*ipa
30719  k(ipa+1,5)=k(ipa+1,4)
30720  ENDIF
30721 
30722 C...Check kinematics and store partons/particles in P vectors.
30723  IF(pecm.LE.pm1+pm2) CALL pyerrm(13,
30724  &'(PY2ENT:) energy smaller than sum of masses')
30725  pa=sqrt(max(0d0,(pecm**2-pm1**2-pm2**2)**2-(2d0*pm1*pm2)**2))/
30726  &(2d0*pecm)
30727  p(ipa,3)=pa
30728  p(ipa,4)=sqrt(pm1**2+pa**2)
30729  p(ipa,5)=pm1
30730  p(ipa+1,3)=-pa
30731  p(ipa+1,4)=sqrt(pm2**2+pa**2)
30732  p(ipa+1,5)=pm2
30733 
30734 C...Set N. Optionally fragment/decay.
30735  n=ipa+1
30736  IF(ip.EQ.0) CALL pyexec
30737 
30738  RETURN
30739  END
30740 
30741 C*********************************************************************
30742 
30743 C...PY3ENT
30744 C...Stores three partons or particles in their CM frame,
30745 C...with the first along the +z axis and the third in the (x,z)
30746 C...plane with x > 0.
30747 
30748  SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
30749 
30750 C...Double precision and integer declarations.
30751  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30752  INTEGER pyk,pychge,pycomp
30753 C...Commonblocks.
30754  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
30755  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30756  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30757  SAVE /pyjets/,/pydat1/,/pydat2/
30758 
30759 C...Standard checks.
30760  mstu(28)=0
30761  IF(mstu(12).GE.1) CALL pylist(0)
30762  ipa=max(1,iabs(ip))
30763  IF(ipa.GT.mstu(4)-2) CALL pyerrm(21,
30764  &'(PY3ENT:) writing outside PYJETS memory')
30765  kc1=pycomp(kf1)
30766  kc2=pycomp(kf2)
30767  kc3=pycomp(kf3)
30768  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL pyerrm(12,
30769  &'(PY3ENT:) unknown flavour code')
30770 
30771 C...Find masses. Reset K, P and V vectors.
30772  pm1=0d0
30773  IF(mstu(10).EQ.1) pm1=p(ipa,5)
30774  IF(mstu(10).GE.2) pm1=pymass(kf1)
30775  pm2=0d0
30776  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
30777  IF(mstu(10).GE.2) pm2=pymass(kf2)
30778  pm3=0d0
30779  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
30780  IF(mstu(10).GE.2) pm3=pymass(kf3)
30781  DO 110 i=ipa,ipa+2
30782  DO 100 j=1,5
30783  k(i,j)=0
30784  p(i,j)=0d0
30785  v(i,j)=0d0
30786  100 CONTINUE
30787  110 CONTINUE
30788 
30789 C...Check flavours.
30790  kq1=kchg(kc1,2)*isign(1,kf1)
30791  kq2=kchg(kc2,2)*isign(1,kf2)
30792  kq3=kchg(kc3,2)*isign(1,kf3)
30793  IF(mstu(19).EQ.1) THEN
30794  mstu(19)=0
30795  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
30796  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
30797  & kq1+kq3.EQ.4)) THEN
30798  ELSE
30799  CALL pyerrm(2,'(PY3ENT:) unphysical flavour combination')
30800  ENDIF
30801  k(ipa,2)=kf1
30802  k(ipa+1,2)=kf2
30803  k(ipa+2,2)=kf3
30804 
30805 C...Store partons/particles in K vectors for normal case.
30806  IF(ip.GE.0) THEN
30807  k(ipa,1)=1
30808  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
30809  k(ipa+1,1)=1
30810  IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
30811  k(ipa+2,1)=1
30812 
30813 C...Store partons in K vectors for parton shower evolution.
30814  ELSE
30815  k(ipa,1)=3
30816  k(ipa+1,1)=3
30817  k(ipa+2,1)=3
30818  kcs=4
30819  IF(kq1.EQ.-1) kcs=5
30820  k(ipa,kcs)=mstu(5)*(ipa+1)
30821  k(ipa,9-kcs)=mstu(5)*(ipa+2)
30822  k(ipa+1,kcs)=mstu(5)*(ipa+2)
30823  k(ipa+1,9-kcs)=mstu(5)*ipa
30824  k(ipa+2,kcs)=mstu(5)*ipa
30825  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
30826  ENDIF
30827 
30828 C...Check kinematics.
30829  mkerr=0
30830  IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*(2d0-x1-x3)*pecm.LE.pm2.OR.
30831  &0.5d0*x3*pecm.LE.pm3) mkerr=1
30832  pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
30833  pa2=sqrt(max(1d-10,(0.5d0*(2d0-x1-x3)*pecm)**2-pm2**2))
30834  pa3=sqrt(max(1d-10,(0.5d0*x3*pecm)**2-pm3**2))
30835  cthe2=(pa3**2-pa1**2-pa2**2)/(2d0*pa1*pa2)
30836  cthe3=(pa2**2-pa1**2-pa3**2)/(2d0*pa1*pa3)
30837  IF(abs(cthe2).GE.1.001d0.OR.abs(cthe3).GE.1.001d0) mkerr=1
30838  cthe3=max(-1d0,min(1d0,cthe3))
30839  IF(mkerr.NE.0) CALL pyerrm(13,
30840  &'(PY3ENT:) unphysical kinematical variable setup')
30841 
30842 C...Store partons/particles in P vectors.
30843  p(ipa,3)=pa1
30844  p(ipa,4)=sqrt(pa1**2+pm1**2)
30845  p(ipa,5)=pm1
30846  p(ipa+2,1)=pa3*sqrt(1d0-cthe3**2)
30847  p(ipa+2,3)=pa3*cthe3
30848  p(ipa+2,4)=sqrt(pa3**2+pm3**2)
30849  p(ipa+2,5)=pm3
30850  p(ipa+1,1)=-p(ipa+2,1)
30851  p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
30852  p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
30853  p(ipa+1,5)=pm2
30854 
30855 C...Set N. Optionally fragment/decay.
30856  n=ipa+2
30857  IF(ip.EQ.0) CALL pyexec
30858 
30859  RETURN
30860  END
30861 
30862 C*********************************************************************
30863 
30864 C...PY4ENT
30865 C...Stores four partons or particles in their CM frame, with
30866 C...the first along the +z axis, the last in the xz plane with x > 0
30867 C...and the second having y < 0 and y > 0 with equal probability.
30868 
30869  SUBROUTINE py4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
30870 
30871 C...Double precision and integer declarations.
30872  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30873  INTEGER pyk,pychge,pycomp
30874 C...Commonblocks.
30875  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
30876  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30877  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30878  SAVE /pyjets/,/pydat1/,/pydat2/
30879 
30880 C...Standard checks.
30881  mstu(28)=0
30882  IF(mstu(12).GE.1) CALL pylist(0)
30883  ipa=max(1,iabs(ip))
30884  IF(ipa.GT.mstu(4)-3) CALL pyerrm(21,
30885  &'(PY4ENT:) writing outside PYJETS momory')
30886  kc1=pycomp(kf1)
30887  kc2=pycomp(kf2)
30888  kc3=pycomp(kf3)
30889  kc4=pycomp(kf4)
30890  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL pyerrm(12,
30891  &'(PY4ENT:) unknown flavour code')
30892 
30893 C...Find masses. Reset K, P and V vectors.
30894  pm1=0d0
30895  IF(mstu(10).EQ.1) pm1=p(ipa,5)
30896  IF(mstu(10).GE.2) pm1=pymass(kf1)
30897  pm2=0d0
30898  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
30899  IF(mstu(10).GE.2) pm2=pymass(kf2)
30900  pm3=0d0
30901  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
30902  IF(mstu(10).GE.2) pm3=pymass(kf3)
30903  pm4=0d0
30904  IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
30905  IF(mstu(10).GE.2) pm4=pymass(kf4)
30906  DO 110 i=ipa,ipa+3
30907  DO 100 j=1,5
30908  k(i,j)=0
30909  p(i,j)=0d0
30910  v(i,j)=0d0
30911  100 CONTINUE
30912  110 CONTINUE
30913 
30914 C...Check flavours.
30915  kq1=kchg(kc1,2)*isign(1,kf1)
30916  kq2=kchg(kc2,2)*isign(1,kf2)
30917  kq3=kchg(kc3,2)*isign(1,kf3)
30918  kq4=kchg(kc4,2)*isign(1,kf4)
30919  IF(mstu(19).EQ.1) THEN
30920  mstu(19)=0
30921  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
30922  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
30923  & kq1+kq4.EQ.4)) THEN
30924  ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0d0)
30925  & THEN
30926  ELSE
30927  CALL pyerrm(2,'(PY4ENT:) unphysical flavour combination')
30928  ENDIF
30929  k(ipa,2)=kf1
30930  k(ipa+1,2)=kf2
30931  k(ipa+2,2)=kf3
30932  k(ipa+3,2)=kf4
30933 
30934 C...Store partons/particles in K vectors for normal case.
30935  IF(ip.GE.0) THEN
30936  k(ipa,1)=1
30937  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
30938  k(ipa+1,1)=1
30939  IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
30940  & k(ipa+1,1)=2
30941  k(ipa+2,1)=1
30942  IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
30943  k(ipa+3,1)=1
30944 
30945 C...Store partons for parton shower evolution from q-g-g-qbar or
30946 C...g-g-g-g event.
30947  ELSEIF(kq1+kq2.NE.0) THEN
30948  k(ipa,1)=3
30949  k(ipa+1,1)=3
30950  k(ipa+2,1)=3
30951  k(ipa+3,1)=3
30952  kcs=4
30953  IF(kq1.EQ.-1) kcs=5
30954  k(ipa,kcs)=mstu(5)*(ipa+1)
30955  k(ipa,9-kcs)=mstu(5)*(ipa+3)
30956  k(ipa+1,kcs)=mstu(5)*(ipa+2)
30957  k(ipa+1,9-kcs)=mstu(5)*ipa
30958  k(ipa+2,kcs)=mstu(5)*(ipa+3)
30959  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
30960  k(ipa+3,kcs)=mstu(5)*ipa
30961  k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
30962 
30963 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
30964  ELSE
30965  k(ipa,1)=3
30966  k(ipa+1,1)=3
30967  k(ipa+2,1)=3
30968  k(ipa+3,1)=3
30969  k(ipa,4)=mstu(5)*(ipa+1)
30970  k(ipa,5)=k(ipa,4)
30971  k(ipa+1,4)=mstu(5)*ipa
30972  k(ipa+1,5)=k(ipa+1,4)
30973  k(ipa+2,4)=mstu(5)*(ipa+3)
30974  k(ipa+2,5)=k(ipa+2,4)
30975  k(ipa+3,4)=mstu(5)*(ipa+2)
30976  k(ipa+3,5)=k(ipa+3,4)
30977  ENDIF
30978 
30979 C...Check kinematics.
30980  mkerr=0
30981  IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*x2*pecm.LE.pm2.OR.
30982  &0.5d0*(2d0-x1-x2-x4)*pecm.LE.pm3.OR.0.5d0*x4*pecm.LE.pm4)
30983  &mkerr=1
30984  pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
30985  pa2=sqrt(max(1d-10,(0.5d0*x2*pecm)**2-pm2**2))
30986  pa4=sqrt(max(1d-10,(0.5d0*x4*pecm)**2-pm4**2))
30987  x24=x1+x2+x4-1d0-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
30988  cthe4=(x1*x4-2d0*x14)*pecm**2/(4d0*pa1*pa4)
30989  IF(abs(cthe4).GE.1.002d0) mkerr=1
30990  cthe4=max(-1d0,min(1d0,cthe4))
30991  sthe4=sqrt(1d0-cthe4**2)
30992  cthe2=(x1*x2-2d0*x12)*pecm**2/(4d0*pa1*pa2)
30993  IF(abs(cthe2).GE.1.002d0) mkerr=1
30994  cthe2=max(-1d0,min(1d0,cthe2))
30995  sthe2=sqrt(1d0-cthe2**2)
30996  cphi2=((x2*x4-2d0*x24)*pecm**2-4d0*pa2*cthe2*pa4*cthe4)/
30997  &max(1d-8*pecm**2,4d0*pa2*sthe2*pa4*sthe4)
30998  IF(abs(cphi2).GE.1.05d0) mkerr=1
30999  cphi2=max(-1d0,min(1d0,cphi2))
31000  IF(mkerr.EQ.1) CALL pyerrm(13,
31001  &'(PY4ENT:) unphysical kinematical variable setup')
31002 
31003 C...Store partons/particles in P vectors.
31004  p(ipa,3)=pa1
31005  p(ipa,4)=sqrt(pa1**2+pm1**2)
31006  p(ipa,5)=pm1
31007  p(ipa+3,1)=pa4*sthe4
31008  p(ipa+3,3)=pa4*cthe4
31009  p(ipa+3,4)=sqrt(pa4**2+pm4**2)
31010  p(ipa+3,5)=pm4
31011  p(ipa+1,1)=pa2*sthe2*cphi2
31012  p(ipa+1,2)=pa2*sthe2*sqrt(1d0-cphi2**2)*(-1d0)**int(pyr(0)+0.5d0)
31013  p(ipa+1,3)=pa2*cthe2
31014  p(ipa+1,4)=sqrt(pa2**2+pm2**2)
31015  p(ipa+1,5)=pm2
31016  p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
31017  p(ipa+2,2)=-p(ipa+1,2)
31018  p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
31019  p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
31020  p(ipa+2,5)=pm3
31021 
31022 C...Set N. Optionally fragment/decay.
31023  n=ipa+3
31024  IF(ip.EQ.0) CALL pyexec
31025 
31026  RETURN
31027  END
31028 
31029 C*********************************************************************
31030 
31031 C...PYJOIN
31032 C...Connects a sequence of partons with colour flow indices,
31033 C...as required for subsequent shower evolution (or other operations).
31034 
31035  SUBROUTINE pyjoin(NJOIN,IJOIN)
31036 
31037 C...Double precision and integer declarations.
31038  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31039  INTEGER pyk,pychge,pycomp
31040 C...Commonblocks.
31041  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
31042  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31043  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
31044  SAVE /pyjets/,/pydat1/,/pydat2/
31045 C...Local array.
31046  dimension ijoin(*)
31047 
31048 C...Check that partons are of right types to be connected.
31049  IF(njoin.LT.2) goto 120
31050  kqsum=0
31051  DO 100 ijn=1,njoin
31052  i=ijoin(ijn)
31053  IF(i.LE.0.OR.i.GT.n) goto 120
31054  IF(k(i,1).LT.1.OR.k(i,1).GT.3) goto 120
31055  kc=pycomp(k(i,2))
31056  IF(kc.EQ.0) goto 120
31057  kq=kchg(kc,2)*isign(1,k(i,2))
31058  IF(kq.EQ.0) goto 120
31059  IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) goto 120
31060  IF(kq.NE.2) kqsum=kqsum+kq
31061  IF(ijn.EQ.1) kqs=kq
31062  100 CONTINUE
31063  IF(kqsum.NE.0) goto 120
31064 
31065 C...Connect the partons sequentially (closing for gluon loop).
31066  kcs=(9-kqs)/2
31067  IF(kqs.EQ.2) kcs=int(4.5d0+pyr(0))
31068  DO 110 ijn=1,njoin
31069  i=ijoin(ijn)
31070  k(i,1)=3
31071  IF(ijn.NE.1) ip=ijoin(ijn-1)
31072  IF(ijn.EQ.1) ip=ijoin(njoin)
31073  IF(ijn.NE.njoin) in=ijoin(ijn+1)
31074  IF(ijn.EQ.njoin) in=ijoin(1)
31075  k(i,kcs)=mstu(5)*in
31076  k(i,9-kcs)=mstu(5)*ip
31077  IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
31078  IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
31079  110 CONTINUE
31080 
31081 C...Error exit: no action taken.
31082  RETURN
31083  120 CALL pyerrm(12,
31084  &'(PYJOIN:) given entries can not be joined by one string')
31085 
31086  RETURN
31087  END
31088 
31089 C*********************************************************************
31090 
31091 C...PYGIVE
31092 C...Sets values of commonblock variables.
31093 
31094  SUBROUTINE pygive(CHIN)
31095 
31096 C...Double precision and integer declarations.
31097  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31098  INTEGER pyk,pychge,pycomp
31099 C...Commonblocks.
31100  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
31101  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31102  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
31103  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
31104  common/pydat4/chaf(500,2)
31105  CHARACTER chaf*16
31106  common/pydatr/mrpy(6),rrpy(100)
31107  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
31108  common/pypars/mstp(200),parp(200),msti(200),pari(200)
31109  common/pyint1/mint(400),vint(400)
31110  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
31111  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
31112  common/pyint4/mwid(500),wids(500,5)
31113  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
31114  common/pyint6/proc(0:500)
31115  CHARACTER proc*28
31116  common/pyint7/sigt(0:6,0:6,0:5)
31117  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
31118  &xpdir(-6:6)
31119  common/pymssm/imss(0:99),rmss(0:99)
31120  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,
31121  &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,
31122  &/pyint5/,/pyint6/,/pyint7/,/pyint8/,/pymssm/
31123 C...Local arrays and character variables.
31124  CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,chold2*28,
31125  &chnew2*28,chnam*6,chvar(49)*6,chalp(2)*26,chind*8,chini*10,
31126  &chinr*16
31127  dimension msvar(49,8)
31128 
31129 C...For each variable to be translated give: name,
31130 C...integer/real/character, no. of indices, lower&upper index bounds.
31131  DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
31132  &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
31133  &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
31134  &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
31135  &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
31136  &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
31137  DATA ((msvar(i,j),j=1,8),i=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
31138  &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
31139  &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31140  &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
31141  &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
31142  &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
31143  &1,1,1,6,4*0, 2,1,1,100,4*0,
31144  &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
31145  &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31146  &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
31147  &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
31148  &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
31149  &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
31150  &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
31151  &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
31152  &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
31153  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
31154  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
31155 
31156 C...Length of character variable. Subdivide it into instructions.
31157  IF(mstu(12).GE.1) CALL pylist(0)
31158  chbit=chin//' '
31159  lbit=101
31160  100 lbit=lbit-1
31161  IF(chbit(lbit:lbit).EQ.' ') goto 100
31162  ltot=0
31163  DO 110 lcom=1,lbit
31164  IF(chbit(lcom:lcom).EQ.' ') goto 110
31165  ltot=ltot+1
31166  chfix(ltot:ltot)=chbit(lcom:lcom)
31167  110 CONTINUE
31168  llow=0
31169  120 lhig=llow+1
31170  130 lhig=lhig+1
31171  IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') goto 130
31172  lbit=lhig-llow-1
31173  chbit(1:lbit)=chfix(llow+1:lhig-1)
31174 
31175 C...Identify commonblock variable.
31176  lnam=1
31177  140 lnam=lnam+1
31178  IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
31179  &lnam.LE.6) goto 140
31180  chnam=chbit(1:lnam-1)//' '
31181  DO 160 lcom=1,lnam-1
31182  DO 150 lalp=1,26
31183  IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
31184  & chalp(2)(lalp:lalp)
31185  150 CONTINUE
31186  160 CONTINUE
31187  ivar=0
31188  DO 170 iv=1,49
31189  IF(chnam.EQ.chvar(iv)) ivar=iv
31190  170 CONTINUE
31191  IF(ivar.EQ.0) THEN
31192  CALL pyerrm(18,'(PYGIVE:) do not recognize variable '//chnam)
31193  llow=lhig
31194  IF(llow.LT.ltot) goto 120
31195  RETURN
31196  ENDIF
31197 
31198 C...Identify any indices.
31199  i1=0
31200  i2=0
31201  i3=0
31202  nindx=0
31203  IF(chbit(lnam:lnam).EQ.'(') THEN
31204  lind=lnam
31205  180 lind=lind+1
31206  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 180
31207  chind=' '
31208  IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c')
31209  & .AND.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17))
31210  & THEN
31211  chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
31212  READ(chind,'(I8)') kf
31213  i1=pycomp(kf)
31214  ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
31215  & 'c') THEN
31216  CALL pyerrm(18,'(PYGIVE:) not allowed to use C index for '//
31217  & chnam)
31218  llow=lhig
31219  IF(llow.LT.ltot) goto 120
31220  RETURN
31221  ELSE
31222  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
31223  READ(chind,'(I8)') i1
31224  ENDIF
31225  lnam=lind
31226  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
31227  nindx=1
31228  ENDIF
31229  IF(chbit(lnam:lnam).EQ.',') THEN
31230  lind=lnam
31231  190 lind=lind+1
31232  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 190
31233  chind=' '
31234  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
31235  READ(chind,'(I8)') i2
31236  lnam=lind
31237  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
31238  nindx=2
31239  ENDIF
31240  IF(chbit(lnam:lnam).EQ.',') THEN
31241  lind=lnam
31242  200 lind=lind+1
31243  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 200
31244  chind=' '
31245  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
31246  READ(chind,'(I8)') i3
31247  lnam=lind+1
31248  nindx=3
31249  ENDIF
31250 
31251 C...Check that indices allowed.
31252  ierr=0
31253  IF(nindx.NE.msvar(ivar,2)) ierr=1
31254  IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
31255  &ierr=2
31256  IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
31257  &ierr=3
31258  IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
31259  &ierr=4
31260  IF(chbit(lnam:lnam).NE.'=') ierr=5
31261  IF(ierr.GE.1) THEN
31262  CALL pyerrm(18,'(PYGIVE:) unallowed indices for '//
31263  & chbit(1:lnam-1))
31264  llow=lhig
31265  IF(llow.LT.ltot) goto 120
31266  RETURN
31267  ENDIF
31268 
31269 C...Save old value of variable.
31270  IF(ivar.EQ.1) THEN
31271  iold=n
31272  ELSEIF(ivar.EQ.2) THEN
31273  iold=k(i1,i2)
31274  ELSEIF(ivar.EQ.3) THEN
31275  rold=p(i1,i2)
31276  ELSEIF(ivar.EQ.4) THEN
31277  rold=v(i1,i2)
31278  ELSEIF(ivar.EQ.5) THEN
31279  iold=mstu(i1)
31280  ELSEIF(ivar.EQ.6) THEN
31281  rold=paru(i1)
31282  ELSEIF(ivar.EQ.7) THEN
31283  iold=mstj(i1)
31284  ELSEIF(ivar.EQ.8) THEN
31285  rold=parj(i1)
31286  ELSEIF(ivar.EQ.9) THEN
31287  iold=kchg(i1,i2)
31288  ELSEIF(ivar.EQ.10) THEN
31289  rold=pmas(i1,i2)
31290  ELSEIF(ivar.EQ.11) THEN
31291  rold=parf(i1)
31292  ELSEIF(ivar.EQ.12) THEN
31293  rold=vckm(i1,i2)
31294  ELSEIF(ivar.EQ.13) THEN
31295  iold=mdcy(i1,i2)
31296  ELSEIF(ivar.EQ.14) THEN
31297  iold=mdme(i1,i2)
31298  ELSEIF(ivar.EQ.15) THEN
31299  rold=brat(i1)
31300  ELSEIF(ivar.EQ.16) THEN
31301  iold=kfdp(i1,i2)
31302  ELSEIF(ivar.EQ.17) THEN
31303  chold=chaf(i1,i2)
31304  ELSEIF(ivar.EQ.18) THEN
31305  iold=mrpy(i1)
31306  ELSEIF(ivar.EQ.19) THEN
31307  rold=rrpy(i1)
31308  ELSEIF(ivar.EQ.20) THEN
31309  iold=msel
31310  ELSEIF(ivar.EQ.21) THEN
31311  iold=msub(i1)
31312  ELSEIF(ivar.EQ.22) THEN
31313  iold=kfin(i1,i2)
31314  ELSEIF(ivar.EQ.23) THEN
31315  rold=ckin(i1)
31316  ELSEIF(ivar.EQ.24) THEN
31317  iold=mstp(i1)
31318  ELSEIF(ivar.EQ.25) THEN
31319  rold=parp(i1)
31320  ELSEIF(ivar.EQ.26) THEN
31321  iold=msti(i1)
31322  ELSEIF(ivar.EQ.27) THEN
31323  rold=pari(i1)
31324  ELSEIF(ivar.EQ.28) THEN
31325  iold=mint(i1)
31326  ELSEIF(ivar.EQ.29) THEN
31327  rold=vint(i1)
31328  ELSEIF(ivar.EQ.30) THEN
31329  iold=iset(i1)
31330  ELSEIF(ivar.EQ.31) THEN
31331  iold=kfpr(i1,i2)
31332  ELSEIF(ivar.EQ.32) THEN
31333  rold=coef(i1,i2)
31334  ELSEIF(ivar.EQ.33) THEN
31335  iold=icol(i1,i2,i3)
31336  ELSEIF(ivar.EQ.34) THEN
31337  rold=xsfx(i1,i2)
31338  ELSEIF(ivar.EQ.35) THEN
31339  iold=isig(i1,i2)
31340  ELSEIF(ivar.EQ.36) THEN
31341  rold=sigh(i1)
31342  ELSEIF(ivar.EQ.37) THEN
31343  iold=mwid(i1)
31344  ELSEIF(ivar.EQ.38) THEN
31345  rold=wids(i1,i2)
31346  ELSEIF(ivar.EQ.39) THEN
31347  iold=ngen(i1,i2)
31348  ELSEIF(ivar.EQ.40) THEN
31349  rold=xsec(i1,i2)
31350  ELSEIF(ivar.EQ.41) THEN
31351  chold2=proc(i1)
31352  ELSEIF(ivar.EQ.42) THEN
31353  rold=sigt(i1,i2,i3)
31354  ELSEIF(ivar.EQ.43) THEN
31355  rold=xpvmd(i1)
31356  ELSEIF(ivar.EQ.44) THEN
31357  rold=xpanl(i1)
31358  ELSEIF(ivar.EQ.45) THEN
31359  rold=xpanh(i1)
31360  ELSEIF(ivar.EQ.46) THEN
31361  rold=xpbeh(i1)
31362  ELSEIF(ivar.EQ.47) THEN
31363  rold=xpdir(i1)
31364  ELSEIF(ivar.EQ.48) THEN
31365  iold=imss(i1)
31366  ELSEIF(ivar.EQ.49) THEN
31367  rold=rmss(i1)
31368  ENDIF
31369 
31370 C...Print current value of variable. Loop back.
31371  IF(lnam.GE.lbit) THEN
31372  chbit(lnam:14)=' '
31373  chbit(15:60)=' has the value '
31374  IF(msvar(ivar,1).EQ.1) THEN
31375  WRITE(chbit(51:60),'(I10)') iold
31376  ELSEIF(msvar(ivar,1).EQ.2) THEN
31377  WRITE(chbit(47:60),'(F14.5)') rold
31378  ELSEIF(msvar(ivar,1).EQ.3) THEN
31379  chbit(53:60)=chold
31380  ELSE
31381  chbit(33:60)=chold
31382  ENDIF
31383  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
31384  llow=lhig
31385  IF(llow.LT.ltot) goto 120
31386  RETURN
31387  ENDIF
31388 
31389 C...Read in new variable value.
31390  IF(msvar(ivar,1).EQ.1) THEN
31391  chini=' '
31392  chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
31393  READ(chini,'(I10)') inew
31394  ELSEIF(msvar(ivar,1).EQ.2) THEN
31395  chinr=' '
31396  chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
31397  READ(chinr,*) rnew
31398  ELSEIF(msvar(ivar,1).EQ.3) THEN
31399  chnew=chbit(lnam+1:lbit)//' '
31400  ELSE
31401  chnew2=chbit(lnam+1:lbit)//' '
31402  ENDIF
31403 
31404 C...Store new variable value.
31405  IF(ivar.EQ.1) THEN
31406  n=inew
31407  ELSEIF(ivar.EQ.2) THEN
31408  k(i1,i2)=inew
31409  ELSEIF(ivar.EQ.3) THEN
31410  p(i1,i2)=rnew
31411  ELSEIF(ivar.EQ.4) THEN
31412  v(i1,i2)=rnew
31413  ELSEIF(ivar.EQ.5) THEN
31414  mstu(i1)=inew
31415  ELSEIF(ivar.EQ.6) THEN
31416  paru(i1)=rnew
31417  ELSEIF(ivar.EQ.7) THEN
31418  mstj(i1)=inew
31419  ELSEIF(ivar.EQ.8) THEN
31420  parj(i1)=rnew
31421  ELSEIF(ivar.EQ.9) THEN
31422  kchg(i1,i2)=inew
31423  ELSEIF(ivar.EQ.10) THEN
31424  pmas(i1,i2)=rnew
31425  ELSEIF(ivar.EQ.11) THEN
31426  parf(i1)=rnew
31427  ELSEIF(ivar.EQ.12) THEN
31428  vckm(i1,i2)=rnew
31429  ELSEIF(ivar.EQ.13) THEN
31430  mdcy(i1,i2)=inew
31431  ELSEIF(ivar.EQ.14) THEN
31432  mdme(i1,i2)=inew
31433  ELSEIF(ivar.EQ.15) THEN
31434  brat(i1)=rnew
31435  ELSEIF(ivar.EQ.16) THEN
31436  kfdp(i1,i2)=inew
31437  ELSEIF(ivar.EQ.17) THEN
31438  chaf(i1,i2)=chnew
31439  ELSEIF(ivar.EQ.18) THEN
31440  mrpy(i1)=inew
31441  ELSEIF(ivar.EQ.19) THEN
31442  rrpy(i1)=rnew
31443  ELSEIF(ivar.EQ.20) THEN
31444  msel=inew
31445  ELSEIF(ivar.EQ.21) THEN
31446  msub(i1)=inew
31447  ELSEIF(ivar.EQ.22) THEN
31448  kfin(i1,i2)=inew
31449  ELSEIF(ivar.EQ.23) THEN
31450  ckin(i1)=rnew
31451  ELSEIF(ivar.EQ.24) THEN
31452  mstp(i1)=inew
31453  ELSEIF(ivar.EQ.25) THEN
31454  parp(i1)=rnew
31455  ELSEIF(ivar.EQ.26) THEN
31456  msti(i1)=inew
31457  ELSEIF(ivar.EQ.27) THEN
31458  pari(i1)=rnew
31459  ELSEIF(ivar.EQ.28) THEN
31460  mint(i1)=inew
31461  ELSEIF(ivar.EQ.29) THEN
31462  vint(i1)=rnew
31463  ELSEIF(ivar.EQ.30) THEN
31464  iset(i1)=inew
31465  ELSEIF(ivar.EQ.31) THEN
31466  kfpr(i1,i2)=inew
31467  ELSEIF(ivar.EQ.32) THEN
31468  coef(i1,i2)=rnew
31469  ELSEIF(ivar.EQ.33) THEN
31470  icol(i1,i2,i3)=inew
31471  ELSEIF(ivar.EQ.34) THEN
31472  xsfx(i1,i2)=rnew
31473  ELSEIF(ivar.EQ.35) THEN
31474  isig(i1,i2)=inew
31475  ELSEIF(ivar.EQ.36) THEN
31476  sigh(i1)=rnew
31477  ELSEIF(ivar.EQ.37) THEN
31478  mwid(i1)=inew
31479  ELSEIF(ivar.EQ.38) THEN
31480  wids(i1,i2)=rnew
31481  ELSEIF(ivar.EQ.39) THEN
31482  ngen(i1,i2)=inew
31483  ELSEIF(ivar.EQ.40) THEN
31484  xsec(i1,i2)=rnew
31485  ELSEIF(ivar.EQ.41) THEN
31486  proc(i1)=chnew2
31487  ELSEIF(ivar.EQ.42) THEN
31488  sigt(i1,i2,i3)=rnew
31489  ELSEIF(ivar.EQ.43) THEN
31490  xpvmd(i1)=rnew
31491  ELSEIF(ivar.EQ.44) THEN
31492  xpanl(i1)=rnew
31493  ELSEIF(ivar.EQ.45) THEN
31494  xpanh(i1)=rnew
31495  ELSEIF(ivar.EQ.46) THEN
31496  xpbeh(i1)=rnew
31497  ELSEIF(ivar.EQ.47) THEN
31498  xpdir(i1)=rnew
31499  ELSEIF(ivar.EQ.48) THEN
31500  imss(i1)=inew
31501  ELSEIF(ivar.EQ.49) THEN
31502  rmss(i1)=rnew
31503  ENDIF
31504 
31505 C...Write old and new value. Loop back.
31506  chbit(lnam:14)=' '
31507  chbit(15:60)=' changed from to '
31508  IF(msvar(ivar,1).EQ.1) THEN
31509  WRITE(chbit(33:42),'(I10)') iold
31510  WRITE(chbit(51:60),'(I10)') inew
31511  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
31512  ELSEIF(msvar(ivar,1).EQ.2) THEN
31513  WRITE(chbit(29:42),'(F14.5)') rold
31514  WRITE(chbit(47:60),'(F14.5)') rnew
31515  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
31516  ELSEIF(msvar(ivar,1).EQ.3) THEN
31517  chbit(35:42)=chold
31518  chbit(53:60)=chnew
31519  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
31520  ELSE
31521  chbit(15:88)=' changed from '//chold2//' to '//chnew2
31522  IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
31523  ENDIF
31524  llow=lhig
31525  IF(llow.LT.ltot) goto 120
31526 
31527 C...Format statement for output on unit MSTU(11) (by default 6).
31528  5000 FORMAT(5x,a60)
31529  5100 FORMAT(5x,a88)
31530 
31531  RETURN
31532  END
31533 
31534 C*********************************************************************
31535 
31536 C...PYEXEC
31537 C...Administrates the fragmentation and decay chain.
31538 
31539  SUBROUTINE pyexec
31540 
31541 C...Double precision and integer declarations.
31542  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31543  INTEGER pyk,pychge,pycomp
31544 C...Commonblocks.
31545  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
31546  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31547  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
31548  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
31549  common/pyint4/mwid(500),wids(500,5)
31550  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint4/
31551 C...Local array.
31552  dimension ps(2,6),ijoin(100)
31553 
31554 C...Initialize and reset.
31555  mstu(24)=0
31556  IF(mstu(12).GE.1) CALL pylist(0)
31557  mstu(31)=mstu(31)+1
31558  mstu(1)=0
31559  mstu(2)=0
31560  mstu(3)=0
31561  IF(mstu(17).LE.0) mstu(90)=0
31562  mcons=1
31563 
31564 C...Sum up momentum, energy and charge for starting entries.
31565  nsav=n
31566  DO 110 i=1,2
31567  DO 100 j=1,6
31568  ps(i,j)=0d0
31569  100 CONTINUE
31570  110 CONTINUE
31571  DO 130 i=1,n
31572  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 130
31573  DO 120 j=1,4
31574  ps(1,j)=ps(1,j)+p(i,j)
31575  120 CONTINUE
31576  ps(1,6)=ps(1,6)+pychge(k(i,2))
31577  130 CONTINUE
31578  paru(21)=ps(1,4)
31579 
31580 C...Prepare system for subsequent fragmentation/decay.
31581  CALL pyprep(0)
31582 
31583 C...Loop through jet fragmentation and particle decays.
31584  mbe=0
31585  140 mbe=mbe+1
31586  ip=0
31587  150 ip=ip+1
31588  kc=0
31589  IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=pycomp(k(ip,2))
31590  IF(kc.EQ.0) THEN
31591 
31592 C...Deal with any remaining undecayed resonance
31593 C...(normally the task of PYEVNT, so seldom used).
31594  ELSEIF(mwid(kc).NE.0) THEN
31595  ibeg=ip
31596  IF(kchg(kc,2).NE.0.AND.k(i,1).NE.3) THEN
31597  ibeg=ip+1
31598  160 ibeg=ibeg-1
31599  IF(ibeg.GE.2.AND.k(ibeg,1).EQ.2) goto 160
31600  IF(k(ibeg,1).NE.2) ibeg=ibeg+1
31601  iend=ip-1
31602  170 iend=iend+1
31603  IF(iend.LT.n.AND.k(iend,1).EQ.2) goto 170
31604  IF(iend.LT.n.AND.kchg(pycomp(k(iend,2)),2).EQ.0) goto 170
31605  njoin=0
31606  DO 180 i=ibeg,iend
31607  IF(kchg(pycomp(k(iend,2)),2).NE.0) THEN
31608  njoin=njoin+1
31609  ijoin(njoin)=i
31610  ENDIF
31611  180 CONTINUE
31612  ENDIF
31613  CALL pyresd(ip)
31614  CALL pyprep(ibeg)
31615 
31616 C...Particle decay if unstable and allowed. Save long-lived particle
31617 C...decays until second pass after Bose-Einstein effects.
31618  ELSEIF(kchg(kc,2).EQ.0) THEN
31619  IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe
31620  & .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
31621  & CALL pydecy(ip)
31622 
31623 C...Decay products may develop a shower.
31624  IF(mstj(92).GT.0) THEN
31625  ip1=mstj(92)
31626  qmax=sqrt(max(0d0,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
31627  & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
31628  CALL pyshow(ip1,ip1+1,qmax)
31629  CALL pyprep(ip1)
31630  mstj(92)=0
31631  ELSEIF(mstj(92).LT.0) THEN
31632  ip1=-mstj(92)
31633  CALL pyshow(ip1,-3,p(ip,5))
31634  CALL pyprep(ip1)
31635  mstj(92)=0
31636  ENDIF
31637 
31638 C...Jet fragmentation: string or independent fragmentation.
31639  ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
31640  mfrag=mstj(1)
31641  IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
31642  IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
31643  IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
31644  & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
31645  IF(kchg(pycomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
31646  ENDIF
31647  ENDIF
31648  IF(mfrag.EQ.1) CALL pystrf(ip)
31649  IF(mfrag.EQ.2) CALL pyindf(ip)
31650  IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
31651  IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
31652  ENDIF
31653 
31654 C...Loop back if enough space left in PYJETS and no error abort.
31655  IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
31656  ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
31657  goto 150
31658  ELSEIF(ip.LT.n) THEN
31659  CALL pyerrm(11,'(PYEXEC:) no more memory left in PYJETS')
31660  ENDIF
31661 
31662 C...Include simple Bose-Einstein effect parametrization if desired.
31663  IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
31664  CALL pyboei(nsav)
31665  goto 140
31666  ENDIF
31667 
31668 C...Check that momentum, energy and charge were conserved.
31669  DO 200 i=1,n
31670  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 200
31671  DO 190 j=1,4
31672  ps(2,j)=ps(2,j)+p(i,j)
31673  190 CONTINUE
31674  ps(2,6)=ps(2,6)+pychge(k(i,2))
31675  200 CONTINUE
31676  pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
31677  &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1d0+abs(ps(2,4))+abs(ps(1,4)))
31678  IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL pyerrm(15,
31679  &'(PYEXEC:) four-momentum was not conserved')
31680  IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1d0) CALL pyerrm(15,
31681  &'(PYEXEC:) charge was not conserved')
31682 
31683  RETURN
31684  END
31685 
31686 C*********************************************************************
31687 
31688 C...PYPREP
31689 C...Rearranges partons along strings. Allows small systems
31690 C...to collapse into one or two particles and checks flavours.
31691 
31692  SUBROUTINE pyprep(IP)
31693 
31694 C...Double precision and integer declarations.
31695  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31696  INTEGER pyk,pychge,pycomp
31697 C...Commonblocks.
31698  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
31699  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31700  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
31701  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
31702  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
31703 C...Local arrays.
31704  dimension dps(5),dpc(5),ue(3)
31705 
31706 C...Rearrange parton shower product listing along strings: begin loop.
31707  i1=n
31708  DO 130 mqgst=1,2
31709  DO 120 i=max(1,ip),n
31710  IF(k(i,1).NE.3) goto 120
31711  kc=pycomp(k(i,2))
31712  IF(kc.EQ.0) goto 120
31713  kq=kchg(kc,2)
31714  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 120
31715 
31716 C...Pick up loose string end.
31717  kcs=4
31718  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
31719  ia=i
31720  nstp=0
31721  100 nstp=nstp+1
31722  IF(nstp.GT.4*n) THEN
31723  CALL pyerrm(14,'(PYPREP:) caught in infinite loop')
31724  RETURN
31725  ENDIF
31726 
31727 C...Copy undecayed parton.
31728  IF(k(ia,1).EQ.3) THEN
31729  IF(i1.GE.mstu(4)-mstu(32)-5) THEN
31730  CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
31731  RETURN
31732  ENDIF
31733  i1=i1+1
31734  k(i1,1)=2
31735  IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) k(i1,1)=1
31736  k(i1,2)=k(ia,2)
31737  k(i1,3)=ia
31738  k(i1,4)=0
31739  k(i1,5)=0
31740  DO 110 j=1,5
31741  p(i1,j)=p(ia,j)
31742  v(i1,j)=v(ia,j)
31743  110 CONTINUE
31744  k(ia,1)=k(ia,1)+10
31745  IF(k(i1,1).EQ.1) goto 120
31746  ENDIF
31747 
31748 C...Go to next parton in colour space.
31749  ib=ia
31750  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
31751  & .NE.0) THEN
31752  ia=mod(k(ib,kcs),mstu(5))
31753  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
31754  mrev=0
31755  ELSE
31756  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
31757  & mstu(5)).EQ.0) kcs=9-kcs
31758  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
31759  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
31760  mrev=1
31761  ENDIF
31762  IF(ia.LE.0.OR.ia.GT.n) THEN
31763  CALL pyerrm(12,'(PYPREP:) colour rearrangement failed')
31764  RETURN
31765  ENDIF
31766  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
31767  & mstu(5)).EQ.ib) THEN
31768  IF(mrev.EQ.1) kcs=9-kcs
31769  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
31770  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
31771  ELSE
31772  IF(mrev.EQ.0) kcs=9-kcs
31773  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
31774  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
31775  ENDIF
31776  IF(ia.NE.i) goto 100
31777  k(i1,1)=1
31778  120 CONTINUE
31779  130 CONTINUE
31780  n=i1
31781  IF(mstj(14).LT.0) RETURN
31782 
31783 C...Find lowest-mass colour singlet jet system, OK if above threshold.
31784  IF(mstj(14).EQ.0) goto 320
31785  ns=n
31786  140 nsin=n-ns
31787  pdm=1d0+parj(32)
31788  ic=0
31789  DO 190 i=max(1,ip),ns
31790  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
31791  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
31792  nsin=nsin+1
31793  ic=i
31794  DO 150 j=1,4
31795  dps(j)=p(i,j)
31796  150 CONTINUE
31797  mstj(93)=1
31798  dps(5)=pymass(k(i,2))
31799  ELSEIF(k(i,1).EQ.2) THEN
31800  DO 160 j=1,4
31801  dps(j)=dps(j)+p(i,j)
31802  160 CONTINUE
31803  ELSEIF(ic.NE.0.AND.kchg(pycomp(k(i,2)),2).NE.0) THEN
31804  DO 170 j=1,4
31805  dps(j)=dps(j)+p(i,j)
31806  170 CONTINUE
31807  mstj(93)=1
31808  dps(5)=dps(5)+pymass(k(i,2))
31809  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-
31810  & dps(5)
31811  IF(pd.LT.pdm) THEN
31812  pdm=pd
31813  DO 180 j=1,5
31814  dpc(j)=dps(j)
31815  180 CONTINUE
31816  ic1=ic
31817  ic2=i
31818  ENDIF
31819  ic=0
31820  ELSE
31821  nsin=nsin+1
31822  ENDIF
31823  190 CONTINUE
31824  IF(pdm.GE.parj(32)) goto 320
31825 
31826 C...Fill small-mass system as cluster.
31827  nsav=n
31828  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
31829  k(n+1,1)=11
31830  k(n+1,2)=91
31831  k(n+1,3)=ic1
31832  k(n+1,4)=n+2
31833  k(n+1,5)=n+3
31834  p(n+1,1)=dpc(1)
31835  p(n+1,2)=dpc(2)
31836  p(n+1,3)=dpc(3)
31837  p(n+1,4)=dpc(4)
31838  p(n+1,5)=pecm
31839 
31840 C...Form two particles from flavours of lowest-mass system, if feasible.
31841  k(n+2,1)=1
31842  k(n+3,1)=1
31843  IF(mstu(16).NE.2) THEN
31844  k(n+2,3)=n+1
31845  k(n+3,3)=n+1
31846  ELSE
31847  k(n+2,3)=ic1
31848  k(n+3,3)=ic2
31849  ENDIF
31850  k(n+2,4)=0
31851  k(n+3,4)=0
31852  k(n+2,5)=0
31853  k(n+3,5)=0
31854  IF(iabs(k(ic1,2)).NE.21) THEN
31855  kc1=pycomp(k(ic1,2))
31856  kc2=pycomp(k(ic2,2))
31857  IF(kc1.EQ.0.OR.kc2.EQ.0) goto 320
31858  kq1=kchg(kc1,2)*isign(1,k(ic1,2))
31859  kq2=kchg(kc2,2)*isign(1,k(ic2,2))
31860  IF(kq1+kq2.NE.0) goto 320
31861  200 CALL pykfdi(k(ic1,2),0,kfln,k(n+2,2))
31862  CALL pykfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2))
31863  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 200
31864  ELSE
31865  IF(iabs(k(ic2,2)).NE.21) goto 320
31866  210 CALL pykfdi(1+int((2d0+parj(2))*pyr(0)),0,kfln,kfdmp)
31867  CALL pykfdi(kfln,0,kflm,k(n+2,2))
31868  CALL pykfdi(-kfln,-kflm,kfldmp,k(n+3,2))
31869  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 210
31870  ENDIF
31871  p(n+2,5)=pymass(k(n+2,2))
31872  p(n+3,5)=pymass(k(n+3,2))
31873  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) goto 320
31874  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) goto 260
31875 
31876 C...Perform two-particle decay of jet system, if possible.
31877  IF(pecm.GE.0.02d0*dpc(4)) THEN
31878  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
31879  & (p(n+2,5)-p(n+3,5))**2))/(2d0*pecm)
31880  ue(3)=2d0*pyr(0)-1d0
31881  phi=paru(2)*pyr(0)
31882  ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
31883  ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
31884  DO 220 j=1,3
31885  p(n+2,j)=pa*ue(j)
31886  p(n+3,j)=-pa*ue(j)
31887  220 CONTINUE
31888  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
31889  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
31890  mstu(33)=1
31891  CALL pyrobo(n+2,n+3,0d0,0d0,dpc(1)/dpc(4),dpc(2)/dpc(4),
31892  & dpc(3)/dpc(4))
31893  ELSE
31894  np=0
31895  DO 230 i=ic1,ic2
31896  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1
31897  230 CONTINUE
31898  ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-
31899  & p(ic1,3)*p(ic2,3)
31900  IF(np.GE.3.OR.ha.LE.1.25d0*p(ic1,5)*p(ic2,5)) goto 260
31901  hd1=0.5d0*(p(n+2,5)**2-p(ic1,5)**2)
31902  hd2=0.5d0*(p(n+3,5)**2-p(ic2,5)**2)
31903  hr=sqrt(max(0d0,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/
31904  & (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1d0
31905  hc=p(ic1,5)**2+2d0*ha+p(ic2,5)**2
31906  hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc
31907  hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc
31908  DO 240 j=1,4
31909  p(n+2,j)=(1d0+hk1)*p(ic1,j)-hk2*p(ic2,j)
31910  p(n+3,j)=(1d0+hk2)*p(ic2,j)-hk1*p(ic1,j)
31911  240 CONTINUE
31912  ENDIF
31913  DO 250 j=1,4
31914  v(n+1,j)=v(ic1,j)
31915  v(n+2,j)=v(ic1,j)
31916  v(n+3,j)=v(ic2,j)
31917  250 CONTINUE
31918  v(n+1,5)=0d0
31919  v(n+2,5)=0d0
31920  v(n+3,5)=0d0
31921  n=n+3
31922  goto 300
31923 
31924 C...Else form one particle from the flavours available, if possible.
31925  260 k(n+1,5)=n+2
31926  IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
31927  goto 320
31928  ELSEIF(iabs(k(ic1,2)).NE.21) THEN
31929  CALL pykfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
31930  ELSE
31931  kfln=1+int((2d0+parj(2))*pyr(0))
31932  CALL pykfdi(kfln,-kfln,kfldmp,k(n+2,2))
31933  ENDIF
31934  IF(k(n+2,2).EQ.0) goto 260
31935  p(n+2,5)=pymass(k(n+2,2))
31936 
31937 C...Find parton/particle which combines to largest extra mass.
31938  ir=0
31939  ha=0d0
31940  hsm=0d0
31941  DO 280 mcomb=1,3
31942  IF(ir.NE.0) goto 280
31943  DO 270 i=max(1,ip),n
31944  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
31945  & .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 270
31946  IF(mcomb.EQ.1) kci=pycomp(k(i,2))
31947  IF(mcomb.EQ.1.AND.kci.EQ.0) goto 270
31948  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 270
31949  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
31950  & goto 270
31951  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
31952  hsr=2d0*hcr+pecm**2-p(n+2,5)**2-2d0*p(n+2,5)*p(i,5)
31953  IF(hsr.GT.hsm) THEN
31954  ir=i
31955  ha=hcr
31956  hsm=hsr
31957  ENDIF
31958  270 CONTINUE
31959  280 CONTINUE
31960 
31961 C...Shuffle energy and momentum to put new particle on mass shell.
31962  IF(ir.NE.0) THEN
31963  hb=pecm**2+ha
31964  hc=p(n+2,5)**2+ha
31965  hd=p(ir,5)**2+ha
31966  hk2=0.5d0*(hb*sqrt(max(0d0,((hb+hc)**2-4d0*(hb+hd)*p(n+2,5)**2)/
31967  & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
31968  hk1=(0.5d0*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
31969  DO 290 j=1,4
31970  p(n+2,j)=(1d0+hk1)*dpc(j)-hk2*p(ir,j)
31971  p(ir,j)=(1d0+hk2)*p(ir,j)-hk1*dpc(j)
31972  v(n+1,j)=v(ic1,j)
31973  v(n+2,j)=v(ic1,j)
31974  290 CONTINUE
31975  v(n+1,5)=0d0
31976  v(n+2,5)=0d0
31977  n=n+2
31978  ELSE
31979  CALL pyerrm(3,'(PYPREP:) no match for collapsing cluster')
31980  RETURN
31981  ENDIF
31982 
31983 C...Mark collapsed system and store daughter pointers. Iterate.
31984  300 DO 310 i=ic1,ic2
31985  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(pycomp(k(i,2)),2).NE.0)
31986  & THEN
31987  k(i,1)=k(i,1)+10
31988  IF(mstu(16).NE.2) THEN
31989  k(i,4)=nsav+1
31990  k(i,5)=nsav+1
31991  ELSE
31992  k(i,4)=nsav+2
31993  k(i,5)=n
31994  ENDIF
31995  ENDIF
31996  310 CONTINUE
31997  IF(n.LT.mstu(4)-mstu(32)-5) goto 140
31998 
31999 C...Check flavours and invariant masses in parton systems.
32000  320 np=0
32001  kfn=0
32002  kqs=0
32003  DO 330 j=1,5
32004  dps(j)=0d0
32005  330 CONTINUE
32006  DO 360 i=max(1,ip),n
32007  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 360
32008  kc=pycomp(k(i,2))
32009  IF(kc.EQ.0) goto 360
32010  kq=kchg(kc,2)*isign(1,k(i,2))
32011  IF(kq.EQ.0) goto 360
32012  np=np+1
32013  IF(kq.NE.2) THEN
32014  kfn=kfn+1
32015  kqs=kqs+kq
32016  mstj(93)=1
32017  dps(5)=dps(5)+pymass(k(i,2))
32018  ENDIF
32019  DO 340 j=1,4
32020  dps(j)=dps(j)+p(i,j)
32021  340 CONTINUE
32022  IF(k(i,1).EQ.1) THEN
32023  IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL
32024  & pyerrm(2,'(PYPREP:) unphysical flavour combination')
32025  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
32026  & (0.9d0*parj(32)+dps(5))**2) CALL pyerrm(3,
32027  & '(PYPREP:) too small mass in jet system')
32028  np=0
32029  kfn=0
32030  kqs=0
32031  DO 350 j=1,5
32032  dps(j)=0d0
32033  350 CONTINUE
32034  ENDIF
32035  360 CONTINUE
32036 
32037  RETURN
32038  END
32039 
32040 C*********************************************************************
32041 
32042 C...PYSTRF
32043 C...Handles the fragmentation of an arbitrary colour singlet
32044 C...jet system according to the Lund string fragmentation model.
32045 
32046  SUBROUTINE pystrf(IP)
32047 
32048 C...Double precision and integer declarations.
32049  IMPLICIT DOUBLE PRECISION(a-h, o-z)
32050  INTEGER pyk,pychge,pycomp
32051 C...Commonblocks.
32052  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
32053  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
32054  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
32055  SAVE /pyjets/,/pydat1/,/pydat2/
32056 C...Local arrays.
32057  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
32058  &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
32059  &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8)
32060 
32061 C...Function: four-product of two vectors.
32062  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)
32063  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
32064  &dp(i,3)*dp(j,3)
32065 
32066 C...Reset counters. Identify parton system.
32067  mstj(91)=0
32068  nsav=n
32069  mstu90=mstu(90)
32070  np=0
32071  kqsum=0
32072  DO 100 j=1,5
32073  dps(j)=0d0
32074  100 CONTINUE
32075  mju(1)=0
32076  mju(2)=0
32077  i=ip-1
32078  110 i=i+1
32079  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
32080  CALL pyerrm(12,'(PYSTRF:) failed to reconstruct jet system')
32081  IF(mstu(21).GE.1) RETURN
32082  ENDIF
32083  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110
32084  kc=pycomp(k(i,2))
32085  IF(kc.EQ.0) goto 110
32086  kq=kchg(kc,2)*isign(1,k(i,2))
32087  IF(kq.EQ.0) goto 110
32088  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
32089  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
32090  IF(mstu(21).GE.1) RETURN
32091  ENDIF
32092 
32093 C...Take copy of partons to be considered. Check flavour sum.
32094  np=np+1
32095  DO 120 j=1,5
32096  k(n+np,j)=k(i,j)
32097  p(n+np,j)=p(i,j)
32098  IF(j.NE.4) dps(j)=dps(j)+p(i,j)
32099  120 CONTINUE
32100  dps(4)=dps(4)+sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
32101  k(n+np,3)=i
32102  IF(kq.NE.2) kqsum=kqsum+kq
32103  IF(k(i,1).EQ.41) THEN
32104  kqsum=kqsum+2*kq
32105  IF(kqsum.EQ.kq) mju(1)=n+np
32106  IF(kqsum.NE.kq) mju(2)=n+np
32107  ENDIF
32108  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110
32109  IF(kqsum.NE.0) THEN
32110  CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
32111  IF(mstu(21).GE.1) RETURN
32112  ENDIF
32113 
32114 C...Boost copied system to CM frame (for better numerical precision).
32115  IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
32116  mbst=0
32117  mstu(33)=1
32118  CALL pyrobo(n+1,n+np,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
32119  & -dps(3)/dps(4))
32120  ELSE
32121  mbst=1
32122  hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
32123  DO 130 i=n+1,n+np
32124  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
32125  IF(p(i,3).GT.0d0) THEN
32126  hhpez=(p(i,4)+p(i,3))/hhbz
32127  p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
32128  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
32129  ELSE
32130  hhpez=(p(i,4)-p(i,3))*hhbz
32131  p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
32132  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
32133  ENDIF
32134  130 CONTINUE
32135  ENDIF
32136 
32137 C...Search for very nearby partons that may be recombined.
32138  ntryr=0
32139  paru12=paru(12)
32140  paru13=paru(13)
32141  mju(3)=mju(1)
32142  mju(4)=mju(2)
32143  nr=np
32144  140 IF(nr.GE.3) THEN
32145  pdrmin=2d0*paru12
32146  DO 150 i=n+1,n+nr
32147  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 150
32148  i1=i+1
32149  IF(i.EQ.n+nr) i1=n+1
32150  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 150
32151  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
32152  & goto 150
32153  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21)
32154  & goto 150
32155  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
32156  & p(i1,2)**2+p(i1,3)**2))
32157  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
32158  pdr=4d0*(pap-pvp)**2/max(1d-6,paru13**2*pap+2d0*(pap-pvp))
32159  IF(pdr.LT.pdrmin) THEN
32160  ir=i
32161  pdrmin=pdr
32162  ENDIF
32163  150 CONTINUE
32164 
32165 C...Recombine very nearby partons to avoid machine precision problems.
32166  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
32167  DO 160 j=1,4
32168  p(n+1,j)=p(n+1,j)+p(n+nr,j)
32169  160 CONTINUE
32170  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
32171  & p(n+1,3)**2))
32172  nr=nr-1
32173  goto 140
32174  ELSEIF(pdrmin.LT.paru12) THEN
32175  DO 170 j=1,4
32176  p(ir,j)=p(ir,j)+p(ir+1,j)
32177  170 CONTINUE
32178  p(ir,5)=sqrt(max(0d0,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
32179  & p(ir,3)**2))
32180  DO 190 i=ir+1,n+nr-1
32181  k(i,2)=k(i+1,2)
32182  DO 180 j=1,5
32183  p(i,j)=p(i+1,j)
32184  180 CONTINUE
32185  190 CONTINUE
32186  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
32187  nr=nr-1
32188  IF(mju(1).GT.ir) mju(1)=mju(1)-1
32189  IF(mju(2).GT.ir) mju(2)=mju(2)-1
32190  goto 140
32191  ENDIF
32192  ENDIF
32193  ntryr=ntryr+1
32194 
32195 C...Reset particle counter. Skip ahead if no junctions are present;
32196 C...this is usually the case!
32197  nrs=max(5*nr+11,np)
32198  ntry=0
32199  200 ntry=ntry+1
32200  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
32201  paru12=4d0*paru12
32202  paru13=2d0*paru13
32203  goto 140
32204  ELSEIF(ntry.GT.100) THEN
32205  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
32206  IF(mstu(21).GE.1) RETURN
32207  ENDIF
32208  i=n+nrs
32209  mstu(90)=mstu90
32210  IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 580
32211  DO 570 jt=1,2
32212  njs(jt)=0
32213  IF(mju(jt).EQ.0) goto 570
32214  js=3-2*jt
32215 
32216 C...Find and sum up momentum on three sides of junction. Check flavours.
32217  DO 220 iu=1,3
32218  iju(iu)=0
32219  DO 210 j=1,5
32220  pju(iu,j)=0d0
32221  210 CONTINUE
32222  220 CONTINUE
32223  iu=0
32224  DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
32225  IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
32226  iu=iu+1
32227  iju(iu)=i1
32228  ENDIF
32229  DO 230 j=1,4
32230  pju(iu,j)=pju(iu,j)+p(i1,j)
32231  230 CONTINUE
32232  240 CONTINUE
32233  DO 250 iu=1,3
32234  pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
32235  250 CONTINUE
32236  IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.
32237  & k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
32238  CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
32239  IF(mstu(21).GE.1) RETURN
32240  ENDIF
32241 
32242 C...Calculate (approximate) boost to rest frame of junction.
32243  t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
32244  & (pju(1,5)*pju(2,5))
32245  t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
32246  & (pju(1,5)*pju(3,5))
32247  t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
32248  & (pju(2,5)*pju(3,5))
32249  t11=sqrt((2d0/3d0)*(1d0-t12)*(1d0-t13)/(1d0-t23))
32250  t22=sqrt((2d0/3d0)*(1d0-t12)*(1d0-t23)/(1d0-t13))
32251  tsq=sqrt((2d0*t11*t22+t12-1d0)*(1d0+t12))
32252  t1f=(tsq-t22*(1d0+t12))/(1d0-t12**2)
32253  t2f=(tsq-t11*(1d0+t12))/(1d0-t12**2)
32254  DO 260 j=1,3
32255  tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
32256  260 CONTINUE
32257  tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
32258  DO 270 iu=1,3
32259  pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
32260  & tju(3)*pju(iu,3)
32261  270 CONTINUE
32262 
32263 C...Put junction at rest if motion could give inconsistencies.
32264  IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
32265  DO 280 j=1,3
32266  tju(j)=0d0
32267  280 CONTINUE
32268  tju(4)=1d0
32269  pju(1,5)=pju(1,4)
32270  pju(2,5)=pju(2,4)
32271  pju(3,5)=pju(3,4)
32272  ENDIF
32273 
32274 C...Start preparing for fragmentation of two strings from junction.
32275  ista=i
32276  DO 550 iu=1,2
32277  ns=iju(iu+1)-iju(iu)
32278 
32279 C...Junction strings: find longitudinal string directions.
32280  DO 310 is=1,ns
32281  is1=iju(iu)+is-1
32282  is2=iju(iu)+is
32283  DO 290 j=1,5
32284  dp(1,j)=0.5d0*p(is1,j)
32285  IF(is.EQ.1) dp(1,j)=p(is1,j)
32286  dp(2,j)=0.5d0*p(is2,j)
32287  IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
32288  290 CONTINUE
32289  IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+
32290  & pju(iu,3)**2)
32291  IF(is.EQ.ns) dp(2,5)=0d0
32292  dp(3,5)=dfour(1,1)
32293  dp(4,5)=dfour(2,2)
32294  dhkc=dfour(1,2)
32295  IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
32296  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
32297  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
32298  dp(3,5)=0d0
32299  dp(4,5)=0d0
32300  dhkc=dfour(1,2)
32301  ENDIF
32302  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
32303  dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
32304  dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
32305  in1=n+nr+4*is-3
32306  p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
32307  DO 300 j=1,4
32308  p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
32309  p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
32310  300 CONTINUE
32311  310 CONTINUE
32312 
32313 C...Junction strings: initialize flavour, momentum and starting pos.
32314  isav=i
32315  mstu91=mstu(90)
32316  320 ntry=ntry+1
32317  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
32318  paru12=4d0*paru12
32319  paru13=2d0*paru13
32320  goto 140
32321  ELSEIF(ntry.GT.100) THEN
32322  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
32323  IF(mstu(21).GE.1) RETURN
32324  ENDIF
32325  i=isav
32326  mstu(90)=mstu91
32327  irankj=0
32328  ie(1)=k(n+1+(jt/2)*(np-1),3)
32329  in(4)=n+nr+1
32330  in(5)=in(4)+1
32331  in(6)=n+nr+4*ns+1
32332  DO 340 jq=1,2
32333  DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
32334  p(in1,1)=2-jq
32335  p(in1,2)=jq-1
32336  p(in1,3)=1d0
32337  330 CONTINUE
32338  340 CONTINUE
32339  kfl(1)=k(iju(iu),2)
32340  px(1)=0d0
32341  py(1)=0d0
32342  gam(1)=0d0
32343  DO 350 j=1,5
32344  pju(iu+3,j)=0d0
32345  350 CONTINUE
32346 
32347 C...Junction strings: find initial transverse directions.
32348  DO 360 j=1,4
32349  dp(1,j)=p(in(4),j)
32350  dp(2,j)=p(in(4)+1,j)
32351  dp(3,j)=0d0
32352  dp(4,j)=0d0
32353  360 CONTINUE
32354  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
32355  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
32356  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
32357  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
32358  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
32359  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
32360  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
32361  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
32362  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
32363  dhc12=dfour(1,2)
32364  dhcx1=dfour(3,1)/dhc12
32365  dhcx2=dfour(3,2)/dhc12
32366  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
32367  dhcy1=dfour(4,1)/dhc12
32368  dhcy2=dfour(4,2)/dhc12
32369  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
32370  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
32371  DO 370 j=1,4
32372  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
32373  p(in(6),j)=dp(3,j)
32374  p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
32375  & dhcyx*dp(3,j))
32376  370 CONTINUE
32377 
32378 C...Junction strings: produce new particle, origin.
32379  380 i=i+1
32380  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
32381  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
32382  IF(mstu(21).GE.1) RETURN
32383  ENDIF
32384  irankj=irankj+1
32385  k(i,1)=1
32386  k(i,3)=ie(1)
32387  k(i,4)=0
32388  k(i,5)=0
32389 
32390 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
32391  390 CALL pykfdi(kfl(1),0,kfl(3),k(i,2))
32392  IF(k(i,2).EQ.0) goto 320
32393  IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
32394  & iabs(kfl(3)).GT.10) THEN
32395  IF(pyr(0).GT.parj(19)) goto 390
32396  ENDIF
32397  p(i,5)=pymass(k(i,2))
32398  CALL pyptdi(kfl(1),px(3),py(3))
32399  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
32400  CALL pyzdis(kfl(1),kfl(3),pr(1),z)
32401  IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
32402  & mstu(90).LT.8) THEN
32403  mstu(90)=mstu(90)+1
32404  mstu(90+mstu(90))=i
32405  paru(90+mstu(90))=z
32406  ENDIF
32407  gam(3)=(1d0-z)*(gam(1)+pr(1)/z)
32408  DO 400 j=1,3
32409  in(j)=in(3+j)
32410  400 CONTINUE
32411 
32412 C...Junction strings: stepping within or from 'low' string region easy.
32413  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
32414  & p(in(1),5)**2.GE.pr(1)) THEN
32415  p(in(1)+2,4)=z*p(in(1)+2,3)
32416  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
32417  DO 410 j=1,4
32418  p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
32419  410 CONTINUE
32420  goto 500
32421  ELSEIF(in(1)+1.EQ.in(2)) THEN
32422  p(in(2)+2,4)=p(in(2)+2,3)
32423  p(in(2)+2,1)=1d0
32424  in(2)=in(2)+4
32425  IF(in(2).GT.n+nr+4*ns) goto 320
32426  IF(four(in(1),in(2)).LE.1d-2) THEN
32427  p(in(1)+2,4)=p(in(1)+2,3)
32428  p(in(1)+2,1)=0d0
32429  in(1)=in(1)+4
32430  ENDIF
32431  ENDIF
32432 
32433 C...Junction strings: find new transverse directions.
32434  420 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
32435  & in(1).GT.in(2)) goto 320
32436  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
32437  DO 430 j=1,4
32438  dp(1,j)=p(in(1),j)
32439  dp(2,j)=p(in(2),j)
32440  dp(3,j)=0d0
32441  dp(4,j)=0d0
32442  430 CONTINUE
32443  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
32444  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
32445  dhc12=dfour(1,2)
32446  IF(dhc12.LE.1d-2) THEN
32447  p(in(1)+2,4)=p(in(1)+2,3)
32448  p(in(1)+2,1)=0d0
32449  in(1)=in(1)+4
32450  goto 420
32451  ENDIF
32452  in(3)=n+nr+4*ns+5
32453  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
32454  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
32455  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
32456  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
32457  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
32458  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
32459  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
32460  dhcx1=dfour(3,1)/dhc12
32461  dhcx2=dfour(3,2)/dhc12
32462  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
32463  dhcy1=dfour(4,1)/dhc12
32464  dhcy2=dfour(4,2)/dhc12
32465  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
32466  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
32467  DO 440 j=1,4
32468  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
32469  p(in(3),j)=dp(3,j)
32470  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
32471  & dhcyx*dp(3,j))
32472  440 CONTINUE
32473 C...Express pT with respect to new axes, if sensible.
32474  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
32475  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
32476  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
32477  px(3)=pxp
32478  py(3)=pyp
32479  ENDIF
32480  ENDIF
32481 
32482 C...Junction strings: sum up known four-momentum, coefficients for m2.
32483  DO 470 j=1,4
32484  dhg(j)=0d0
32485  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
32486  & py(3)*p(in(3)+1,j)
32487  DO 450 in1=in(4),in(1)-4,4
32488  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
32489  450 CONTINUE
32490  DO 460 in2=in(5),in(2)-4,4
32491  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
32492  460 CONTINUE
32493  470 CONTINUE
32494  dhm(1)=four(i,i)
32495  dhm(2)=2d0*four(i,in(1))
32496  dhm(3)=2d0*four(i,in(2))
32497  dhm(4)=2d0*four(in(1),in(2))
32498 
32499 C...Junction strings: find coefficients for Gamma expression.
32500  DO 490 in2=in(1)+1,in(2),4
32501  DO 480 in1=in(1),in2-1,4
32502  dhc=2d0*four(in1,in2)
32503  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
32504  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
32505  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
32506  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
32507  480 CONTINUE
32508  490 CONTINUE
32509 
32510 C...Junction strings: solve (m2, Gamma) equation system for energies.
32511  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
32512  IF(abs(dhs1).LT.1d-4) goto 320
32513  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
32514  & (p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
32515  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
32516  p(in(2)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
32517  & abs(dhs1)-dhs2/dhs1)
32518  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0d0) goto 320
32519  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
32520  & (dhm(2)+dhm(4)*p(in(2)+2,4))
32521 
32522 C...Junction strings: step to new region if necessary.
32523  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
32524  p(in(2)+2,4)=p(in(2)+2,3)
32525  p(in(2)+2,1)=1d0
32526  in(2)=in(2)+4
32527  IF(in(2).GT.n+nr+4*ns) goto 320
32528  IF(four(in(1),in(2)).LE.1d-2) THEN
32529  p(in(1)+2,4)=p(in(1)+2,3)
32530  p(in(1)+2,1)=0d0
32531  in(1)=in(1)+4
32532  ENDIF
32533  goto 420
32534  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
32535  p(in(1)+2,4)=p(in(1)+2,3)
32536  p(in(1)+2,1)=0d0
32537  in(1)=in(1)+js
32538  goto 820
32539  ENDIF
32540 
32541 C...Junction strings: particle four-momentum, remainder, loop back.
32542  500 DO 510 j=1,4
32543  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+
32544  & p(in(2)+2,4)*p(in(2),j)
32545  pju(iu+3,j)=pju(iu+3,j)+p(i,j)
32546  510 CONTINUE
32547  IF(p(i,4).LT.p(i,5)) goto 320
32548  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
32549  & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
32550  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
32551  kfl(1)=-kfl(3)
32552  px(1)=-px(3)
32553  py(1)=-py(3)
32554  gam(1)=gam(3)
32555  IF(in(3).NE.in(6)) THEN
32556  DO 520 j=1,4
32557  p(in(6),j)=p(in(3),j)
32558  p(in(6)+1,j)=p(in(3)+1,j)
32559  520 CONTINUE
32560  ENDIF
32561  DO 530 jq=1,2
32562  in(3+jq)=in(jq)
32563  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
32564  p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
32565  530 CONTINUE
32566  goto 380
32567  ENDIF
32568 
32569 C...Junction strings: save quantities left after each string.
32570  IF(iabs(kfl(1)).GT.10) goto 320
32571  i=i-1
32572  kfjh(iu)=kfl(1)
32573  DO 540 j=1,4
32574  pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
32575  540 CONTINUE
32576  550 CONTINUE
32577 
32578 C...Junction strings: put together to new effective string endpoint.
32579  njs(jt)=i-ista
32580  kfjs(jt)=k(k(mju(jt+2),3),2)
32581  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
32582  IF(kfjh(1).EQ.kfjh(2)) kfls=3
32583  IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),
32584  & iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+
32585  & kfls,kfjh(1))
32586  DO 560 j=1,4
32587  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
32588  pjs(jt+2,j)=pju(4,j)+pju(5,j)
32589  560 CONTINUE
32590  pjs(jt,5)=sqrt(max(0d0,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
32591  & pjs(jt,3)**2))
32592  570 CONTINUE
32593 
32594 C...Open versus closed strings. Choose breakup region for latter.
32595  580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
32596  ns=mju(2)-mju(1)
32597  nb=mju(1)-n
32598  ELSEIF(mju(1).NE.0) THEN
32599  ns=n+nr-mju(1)
32600  nb=mju(1)-n
32601  ELSEIF(mju(2).NE.0) THEN
32602  ns=mju(2)-n
32603  nb=1
32604  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
32605  ns=nr-1
32606  nb=1
32607  ELSE
32608  ns=nr+1
32609  w2sum=0d0
32610  DO 590 is=1,nr
32611  p(n+nr+is,1)=0.5d0*four(n+is,n+is+1-nr*(is/nr))
32612  w2sum=w2sum+p(n+nr+is,1)
32613  590 CONTINUE
32614  w2ran=pyr(0)*w2sum
32615  nb=0
32616  600 nb=nb+1
32617  w2sum=w2sum-p(n+nr+nb,1)
32618  IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 600
32619  ENDIF
32620 
32621 C...Find longitudinal string directions (i.e. lightlike four-vectors).
32622  DO 630 is=1,ns
32623  is1=n+is+nb-1-nr*((is+nb-2)/nr)
32624  is2=n+is+nb-nr*((is+nb-1)/nr)
32625  DO 610 j=1,5
32626  dp(1,j)=p(is1,j)
32627  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5d0*dp(1,j)
32628  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
32629  dp(2,j)=p(is2,j)
32630  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5d0*dp(2,j)
32631  IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
32632  610 CONTINUE
32633  dp(3,5)=dfour(1,1)
32634  dp(4,5)=dfour(2,2)
32635  dhkc=dfour(1,2)
32636  IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
32637  dp(3,5)=dp(1,5)**2
32638  dp(4,5)=dp(2,5)**2
32639  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
32640  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
32641  dhkc=dfour(1,2)
32642  ENDIF
32643  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
32644  dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
32645  dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
32646  in1=n+nr+4*is-3
32647  p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
32648  DO 620 j=1,4
32649  p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
32650  p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
32651  620 CONTINUE
32652  630 CONTINUE
32653 
32654 C...Begin initialization: sum up energy, set starting position.
32655  isav=i
32656  mstu91=mstu(90)
32657  640 ntry=ntry+1
32658  IF(ntry.GT.100.AND.ntryr.LE.4) THEN
32659  paru12=4d0*paru12
32660  paru13=2d0*paru13
32661  goto 140
32662  ELSEIF(ntry.GT.100) THEN
32663  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
32664  IF(mstu(21).GE.1) RETURN
32665  ENDIF
32666  i=isav
32667  mstu(90)=mstu91
32668  DO 660 j=1,4
32669  p(n+nrs,j)=0d0
32670  DO 650 is=1,nr
32671  p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
32672  650 CONTINUE
32673  660 CONTINUE
32674  DO 680 jt=1,2
32675  irank(jt)=0
32676  IF(mju(jt).NE.0) irank(jt)=njs(jt)
32677  IF(ns.GT.nr) irank(jt)=1
32678  ie(jt)=k(n+1+(jt/2)*(np-1),3)
32679  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
32680  in(3*jt+2)=in(3*jt+1)+1
32681  in(3*jt+3)=n+nr+4*ns+2*jt-1
32682  DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
32683  p(in1,1)=2-jt
32684  p(in1,2)=jt-1
32685  p(in1,3)=1d0
32686  670 CONTINUE
32687  680 CONTINUE
32688 
32689 C...Initialize flavour and pT variables for open string.
32690  IF(ns.LT.nr) THEN
32691  px(1)=0d0
32692  py(1)=0d0
32693  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL pyptdi(0,px(1),py(1))
32694  px(2)=-px(1)
32695  py(2)=-py(1)
32696  DO 690 jt=1,2
32697  kfl(jt)=k(ie(jt),2)
32698  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
32699  mstj(93)=1
32700  pmq(jt)=pymass(kfl(jt))
32701  gam(jt)=0d0
32702  690 CONTINUE
32703 
32704 C...Closed string: random initial breakup flavour, pT and vertex.
32705  ELSE
32706  kfl(3)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
32707  CALL pykfdi(kfl(3),0,kfl(1),kdump)
32708  kfl(2)=-kfl(1)
32709  IF(iabs(kfl(1)).GT.10.AND.pyr(0).GT.0.5d0) THEN
32710  kfl(2)=-(kfl(1)+isign(10000,kfl(1)))
32711  ELSEIF(iabs(kfl(1)).GT.10) THEN
32712  kfl(1)=-(kfl(2)+isign(10000,kfl(2)))
32713  ENDIF
32714  CALL pyptdi(kfl(1),px(1),py(1))
32715  px(2)=-px(1)
32716  py(2)=-py(1)
32717  pr3=min(25d0,0.1d0*p(n+nr+1,5)**2)
32718  700 CALL pyzdis(kfl(1),kfl(2),pr3,z)
32719  zr=pr3/(z*p(n+nr+1,5)**2)
32720  IF(zr.GE.1d0) goto 700
32721  DO 710 jt=1,2
32722  mstj(93)=1
32723  pmq(jt)=pymass(kfl(jt))
32724  gam(jt)=pr3*(1d0-z)/z
32725  in1=n+nr+3+4*(jt/2)*(ns-1)
32726  p(in1,jt)=1d0-z
32727  p(in1,3-jt)=jt-1
32728  p(in1,3)=(2-jt)*(1d0-z)+(jt-1)*z
32729  p(in1+1,jt)=zr
32730  p(in1+1,3-jt)=2-jt
32731  p(in1+1,3)=(2-jt)*(1d0-zr)+(jt-1)*zr
32732  710 CONTINUE
32733  ENDIF
32734 
32735 C...Find initial transverse directions (i.e. spacelike four-vectors).
32736  DO 750 jt=1,2
32737  IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
32738  in1=in(3*jt+1)
32739  in3=in(3*jt+3)
32740  DO 720 j=1,4
32741  dp(1,j)=p(in1,j)
32742  dp(2,j)=p(in1+1,j)
32743  dp(3,j)=0d0
32744  dp(4,j)=0d0
32745  720 CONTINUE
32746  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
32747  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
32748  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
32749  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
32750  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
32751  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
32752  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
32753  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
32754  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
32755  dhc12=dfour(1,2)
32756  dhcx1=dfour(3,1)/dhc12
32757  dhcx2=dfour(3,2)/dhc12
32758  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
32759  dhcy1=dfour(4,1)/dhc12
32760  dhcy2=dfour(4,2)/dhc12
32761  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
32762  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
32763  DO 730 j=1,4
32764  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
32765  p(in3,j)=dp(3,j)
32766  p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
32767  & dhcyx*dp(3,j))
32768  730 CONTINUE
32769  ELSE
32770  DO 740 j=1,4
32771  p(in3+2,j)=p(in3,j)
32772  p(in3+3,j)=p(in3+1,j)
32773  740 CONTINUE
32774  ENDIF
32775  750 CONTINUE
32776 
32777 C...Remove energy used up in junction string fragmentation.
32778  IF(mju(1)+mju(2).GT.0) THEN
32779  DO 770 jt=1,2
32780  IF(njs(jt).EQ.0) goto 770
32781  DO 760 j=1,4
32782  p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
32783  760 CONTINUE
32784  770 CONTINUE
32785  ENDIF
32786 
32787 C...Produce new particle: side, origin.
32788  780 i=i+1
32789  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
32790  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
32791  IF(mstu(21).GE.1) RETURN
32792  ENDIF
32793  jt=1.5d0+pyr(0)
32794  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
32795  IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
32796  jr=3-jt
32797  js=3-2*jt
32798  irank(jt)=irank(jt)+1
32799  k(i,1)=1
32800  k(i,3)=ie(jt)
32801  k(i,4)=0
32802  k(i,5)=0
32803 
32804 C...Generate flavour, hadron and pT.
32805  790 CALL pykfdi(kfl(jt),0,kfl(3),k(i,2))
32806  IF(k(i,2).EQ.0) goto 640
32807  IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
32808  &iabs(kfl(3)).GT.10) THEN
32809  IF(pyr(0).GT.parj(19)) goto 790
32810  ENDIF
32811  p(i,5)=pymass(k(i,2))
32812  CALL pyptdi(kfl(jt),px(3),py(3))
32813  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
32814 
32815 C...Final hadrons for small invariant mass.
32816  mstj(93)=1
32817  pmq(3)=pymass(kfl(3))
32818  parjst=parj(33)
32819  IF(mstj(11).EQ.2) parjst=parj(34)
32820  wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
32821  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
32822  &wmin-0.5d0*parj(36)*pmq(3)
32823  wrem2=four(n+nrs,n+nrs)
32824  IF(wrem2.LT.0.10d0) goto 640
32825  IF(wrem2.LT.max(wmin*(1d0+(2d0*pyr(0)-1d0)*parj(37)),
32826  &parj(32)+pmq(1)+pmq(2))**2) goto 940
32827 
32828 C...Choose z, which gives Gamma. Shift z for heavy flavours.
32829  CALL pyzdis(kfl(jt),kfl(3),pr(jt),z)
32830  IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
32831  &mstu(90).LT.8) THEN
32832  mstu(90)=mstu(90)+1
32833  mstu(90+mstu(90))=i
32834  paru(90+mstu(90))=z
32835  ENDIF
32836  kfl1a=iabs(kfl(1))
32837  kfl2a=iabs(kfl(2))
32838  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
32839  &mod(kfl2a/1000,10)).GE.4) THEN
32840  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
32841  pw12=sqrt(max(0d0,(wrem2-pr(1)-pr(2))**2-4d0*pr(1)*pr(2)))
32842  z=(wrem2+pr(jt)-pr(jr)+pw12*(2d0*z-1d0))/(2d0*wrem2)
32843  pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
32844  IF((1d0-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 940
32845  ENDIF
32846  gam(3)=(1d0-z)*(gam(jt)+pr(jt)/z)
32847  DO 800 j=1,3
32848  in(j)=in(3*jt+j)
32849  800 CONTINUE
32850 
32851 C...Stepping within or from 'low' string region easy.
32852  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
32853  &p(in(1),5)**2.GE.pr(jt)) THEN
32854  p(in(jt)+2,4)=z*p(in(jt)+2,3)
32855  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
32856  DO 810 j=1,4
32857  p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
32858  810 CONTINUE
32859  goto 900
32860  ELSEIF(in(1)+1.EQ.in(2)) THEN
32861  p(in(jr)+2,4)=p(in(jr)+2,3)
32862  p(in(jr)+2,jt)=1d0
32863  in(jr)=in(jr)+4*js
32864  IF(js*in(jr).GT.js*in(4*jr)) goto 640
32865  IF(four(in(1),in(2)).LE.1d-2) THEN
32866  p(in(jt)+2,4)=p(in(jt)+2,3)
32867  p(in(jt)+2,jt)=0d0
32868  in(jt)=in(jt)+4*js
32869  ENDIF
32870  ENDIF
32871 
32872 C...Find new transverse directions (i.e. spacelike string vectors).
32873  820 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
32874  &in(1).GT.in(2)) goto 640
32875  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
32876  DO 830 j=1,4
32877  dp(1,j)=p(in(1),j)
32878  dp(2,j)=p(in(2),j)
32879  dp(3,j)=0d0
32880  dp(4,j)=0d0
32881  830 CONTINUE
32882  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
32883  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
32884  dhc12=dfour(1,2)
32885  IF(dhc12.LE.1d-2) THEN
32886  p(in(jt)+2,4)=p(in(jt)+2,3)
32887  p(in(jt)+2,jt)=0d0
32888  in(jt)=in(jt)+4*js
32889  goto 820
32890  ENDIF
32891  in(3)=n+nr+4*ns+5
32892  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
32893  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
32894  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
32895  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
32896  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
32897  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
32898  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
32899  dhcx1=dfour(3,1)/dhc12
32900  dhcx2=dfour(3,2)/dhc12
32901  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
32902  dhcy1=dfour(4,1)/dhc12
32903  dhcy2=dfour(4,2)/dhc12
32904  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
32905  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
32906  DO 840 j=1,4
32907  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
32908  p(in(3),j)=dp(3,j)
32909  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
32910  & dhcyx*dp(3,j))
32911  840 CONTINUE
32912 C...Express pT with respect to new axes, if sensible.
32913  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
32914  & four(in(3*jt+3)+1,in(3)))
32915  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
32916  & four(in(3*jt+3)+1,in(3)+1))
32917  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
32918  px(3)=pxp
32919  py(3)=pyp
32920  ENDIF
32921  ENDIF
32922 
32923 C...Sum up known four-momentum. Gives coefficients for m2 expression.
32924  DO 870 j=1,4
32925  dhg(j)=0d0
32926  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
32927  & px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
32928  DO 850 in1=in(3*jt+1),in(1)-4*js,4*js
32929  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
32930  850 CONTINUE
32931  DO 860 in2=in(3*jt+2),in(2)-4*js,4*js
32932  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
32933  860 CONTINUE
32934  870 CONTINUE
32935  dhm(1)=four(i,i)
32936  dhm(2)=2d0*four(i,in(1))
32937  dhm(3)=2d0*four(i,in(2))
32938  dhm(4)=2d0*four(in(1),in(2))
32939 
32940 C...Find coefficients for Gamma expression.
32941  DO 890 in2=in(1)+1,in(2),4
32942  DO 880 in1=in(1),in2-1,4
32943  dhc=2d0*four(in1,in2)
32944  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
32945  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
32946  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
32947  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
32948  880 CONTINUE
32949  890 CONTINUE
32950 
32951 C...Solve (m2, Gamma) equation system for energies taken.
32952  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
32953  IF(abs(dhs1).LT.1d-4) goto 640
32954  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
32955  &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
32956  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
32957  p(in(jr)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
32958  &abs(dhs1)-dhs2/dhs1)
32959  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0d0) goto 640
32960  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
32961  &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
32962 
32963 C...Step to new region if necessary.
32964  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
32965  p(in(jr)+2,4)=p(in(jr)+2,3)
32966  p(in(jr)+2,jt)=1d0
32967  in(jr)=in(jr)+4*js
32968  IF(js*in(jr).GT.js*in(4*jr)) goto 640
32969  IF(four(in(1),in(2)).LE.1d-2) THEN
32970  p(in(jt)+2,4)=p(in(jt)+2,3)
32971  p(in(jt)+2,jt)=0d0
32972  in(jt)=in(jt)+4*js
32973  ENDIF
32974  goto 820
32975  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
32976  p(in(jt)+2,4)=p(in(jt)+2,3)
32977  p(in(jt)+2,jt)=0d0
32978  in(jt)=in(jt)+4*js
32979  goto 820
32980  ENDIF
32981 
32982 C...Four-momentum of particle. Remaining quantities. Loop back.
32983  900 DO 910 j=1,4
32984  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
32985  p(n+nrs,j)=p(n+nrs,j)-p(i,j)
32986  910 CONTINUE
32987  IF(p(i,4).LT.p(i,5)) goto 640
32988  kfl(jt)=-kfl(3)
32989  pmq(jt)=pmq(3)
32990  px(jt)=-px(3)
32991  py(jt)=-py(3)
32992  gam(jt)=gam(3)
32993  IF(in(3).NE.in(3*jt+3)) THEN
32994  DO 920 j=1,4
32995  p(in(3*jt+3),j)=p(in(3),j)
32996  p(in(3*jt+3)+1,j)=p(in(3)+1,j)
32997  920 CONTINUE
32998  ENDIF
32999  DO 930 jq=1,2
33000  in(3*jt+jq)=in(jq)
33001  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
33002  p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
33003  930 CONTINUE
33004  goto 780
33005 
33006 C...Final hadron: side, flavour, hadron, mass.
33007  940 i=i+1
33008  k(i,1)=1
33009  k(i,3)=ie(jr)
33010  k(i,4)=0
33011  k(i,5)=0
33012  CALL pykfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
33013  IF(k(i,2).EQ.0) goto 640
33014  p(i,5)=pymass(k(i,2))
33015  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
33016 
33017 C...Final two hadrons: find common setup of four-vectors.
33018  jq=1
33019  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*
33020  &p(in(8),3)*four(in(7),in(8))) jq=2
33021  dhc12=four(in(3*jq+1),in(3*jq+2))
33022  dhr1=four(n+nrs,in(3*jq+2))/dhc12
33023  dhr2=four(n+nrs,in(3*jq+1))/dhc12
33024  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
33025  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
33026  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
33027  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
33028  & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
33029  ENDIF
33030 
33031 C...Solve kinematics for final two hadrons, if possible.
33032  wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
33033  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
33034  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1d0) goto 200
33035  IF(fd.GE.1d0) goto 640
33036  fa=wrem2+pr(jt)-pr(jr)
33037  IF(mstj(11).NE.2) prev=0.5d0*exp(max(-50d0,log(fd)*parj(38)*
33038  &(pr(1)+pr(2))**2))
33039  IF(mstj(11).EQ.2) prev=0.5d0*fd**parj(39)
33040  fb=sign(sqrt(max(0d0,fa**2-4d0*wrem2*pr(jt))),js*(pyr(0)-prev))
33041  kfl1a=iabs(kfl(1))
33042  kfl2a=iabs(kfl(2))
33043  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
33044  &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0d0,fa**2-
33045  &4d0*wrem2*pr(jt))),dble(js))
33046  DO 950 j=1,4
33047  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
33048  & p(in(3*jq+3)+1,j)+0.5d0*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
33049  & dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
33050  p(i,j)=p(n+nrs,j)-p(i-1,j)
33051  950 CONTINUE
33052  IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) goto 640
33053 
33054 C...Mark jets as fragmented and give daughter pointers.
33055  n=i-nrs+1
33056  DO 960 i=nsav+1,nsav+np
33057  im=k(i,3)
33058  k(im,1)=k(im,1)+10
33059  IF(mstu(16).NE.2) THEN
33060  k(im,4)=nsav+1
33061  k(im,5)=nsav+1
33062  ELSE
33063  k(im,4)=nsav+2
33064  k(im,5)=n
33065  ENDIF
33066  960 CONTINUE
33067 
33068 C...Document string system. Move up particles.
33069  nsav=nsav+1
33070  k(nsav,1)=11
33071  k(nsav,2)=92
33072  k(nsav,3)=ip
33073  k(nsav,4)=nsav+1
33074  k(nsav,5)=n
33075  DO 970 j=1,4
33076  p(nsav,j)=dps(j)
33077  v(nsav,j)=v(ip,j)
33078  970 CONTINUE
33079  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
33080  v(nsav,5)=0d0
33081  DO 990 i=nsav+1,n
33082  DO 980 j=1,5
33083  k(i,j)=k(i+nrs-1,j)
33084  p(i,j)=p(i+nrs-1,j)
33085  v(i,j)=0d0
33086  980 CONTINUE
33087  990 CONTINUE
33088  mstu91=mstu(90)
33089  DO 1000 iz=mstu90+1,mstu91
33090  mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
33091  paru9t(iz)=paru(90+iz)
33092  1000 CONTINUE
33093  mstu(90)=mstu90
33094 
33095 C...Order particles in rank along the chain. Update mother pointer.
33096  DO 1020 i=nsav+1,n
33097  DO 1010 j=1,5
33098  k(i-nsav+n,j)=k(i,j)
33099  p(i-nsav+n,j)=p(i,j)
33100  1010 CONTINUE
33101  1020 CONTINUE
33102  i1=nsav
33103  DO 1050 i=n+1,2*n-nsav
33104  IF(k(i,3).NE.ie(1)) goto 1050
33105  i1=i1+1
33106  DO 1030 j=1,5
33107  k(i1,j)=k(i,j)
33108  p(i1,j)=p(i,j)
33109  1030 CONTINUE
33110  IF(mstu(16).NE.2) k(i1,3)=nsav
33111  DO 1040 iz=mstu90+1,mstu91
33112  IF(mstu9t(iz).EQ.i) THEN
33113  mstu(90)=mstu(90)+1
33114  mstu(90+mstu(90))=i1
33115  paru(90+mstu(90))=paru9t(iz)
33116  ENDIF
33117  1040 CONTINUE
33118  1050 CONTINUE
33119  DO 1080 i=2*n-nsav,n+1,-1
33120  IF(k(i,3).EQ.ie(1)) goto 1080
33121  i1=i1+1
33122  DO 1060 j=1,5
33123  k(i1,j)=k(i,j)
33124  p(i1,j)=p(i,j)
33125  1060 CONTINUE
33126  IF(mstu(16).NE.2) k(i1,3)=nsav
33127  DO 1070 iz=mstu90+1,mstu91
33128  IF(mstu9t(iz).EQ.i) THEN
33129  mstu(90)=mstu(90)+1
33130  mstu(90+mstu(90))=i1
33131  paru(90+mstu(90))=paru9t(iz)
33132  ENDIF
33133  1070 CONTINUE
33134  1080 CONTINUE
33135 
33136 C...Boost back particle system. Set production vertices.
33137  IF(mbst.EQ.0) THEN
33138  mstu(33)=1
33139  CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),
33140  & dps(3)/dps(4))
33141  ELSE
33142  DO 1090 i=nsav+1,n
33143  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
33144  IF(p(i,3).GT.0d0) THEN
33145  hhpez=(p(i,4)+p(i,3))*hhbz
33146  p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
33147  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
33148  ELSE
33149  hhpez=(p(i,4)-p(i,3))/hhbz
33150  p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
33151  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
33152  ENDIF
33153  1090 CONTINUE
33154  ENDIF
33155  DO 1110 i=nsav+1,n
33156  DO 1100 j=1,4
33157  v(i,j)=v(ip,j)
33158  1100 CONTINUE
33159  1110 CONTINUE
33160 
33161  RETURN
33162  END
33163 
33164 C*********************************************************************
33165 
33166 C...PYINDF
33167 C...Handles the fragmentation of a jet system (or a single
33168 C...jet) according to independent fragmentation models.
33169 
33170  SUBROUTINE pyindf(IP)
33171 
33172 C...Double precision and integer declarations.
33173  IMPLICIT DOUBLE PRECISION(a-h, o-z)
33174  INTEGER pyk,pychge,pycomp
33175 C...Commonblocks.
33176  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
33177  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
33178  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
33179  SAVE /pyjets/,/pydat1/,/pydat2/
33180 C...Local arrays.
33181  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
33182  &kflo(2),pxo(2),pyo(2),wo(2)
33183 
33184 C...Reset counters. Identify parton system and take copy. Check flavour.
33185  nsav=n
33186  mstu90=mstu(90)
33187  njet=0
33188  kqsum=0
33189  DO 100 j=1,5
33190  dps(j)=0d0
33191  100 CONTINUE
33192  i=ip-1
33193  110 i=i+1
33194  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
33195  CALL pyerrm(12,'(PYINDF:) failed to reconstruct jet system')
33196  IF(mstu(21).GE.1) RETURN
33197  ENDIF
33198  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110
33199  kc=pycomp(k(i,2))
33200  IF(kc.EQ.0) goto 110
33201  kq=kchg(kc,2)*isign(1,k(i,2))
33202  IF(kq.EQ.0) goto 110
33203  njet=njet+1
33204  IF(kq.NE.2) kqsum=kqsum+kq
33205  DO 120 j=1,5
33206  k(nsav+njet,j)=k(i,j)
33207  p(nsav+njet,j)=p(i,j)
33208  dps(j)=dps(j)+p(i,j)
33209  120 CONTINUE
33210  k(nsav+njet,3)=i
33211  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
33212  &k(i+1,1).EQ.2)) goto 110
33213  IF(njet.NE.1.AND.kqsum.NE.0) THEN
33214  CALL pyerrm(12,'(PYINDF:) unphysical flavour combination')
33215  IF(mstu(21).GE.1) RETURN
33216  ENDIF
33217 
33218 C...Boost copied system to CM frame. Find CM energy and sum flavours.
33219  IF(njet.NE.1) THEN
33220  mstu(33)=1
33221  CALL pyrobo(nsav+1,nsav+njet,0d0,0d0,-dps(1)/dps(4),
33222  & -dps(2)/dps(4),-dps(3)/dps(4))
33223  ENDIF
33224  pecm=0d0
33225  DO 130 j=1,3
33226  nfi(j)=0
33227  130 CONTINUE
33228  DO 140 i=nsav+1,nsav+njet
33229  pecm=pecm+p(i,4)
33230  kfa=iabs(k(i,2))
33231  IF(kfa.LE.3) THEN
33232  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
33233  ELSEIF(kfa.GT.1000) THEN
33234  kfla=mod(kfa/1000,10)
33235  kflb=mod(kfa/100,10)
33236  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
33237  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
33238  ENDIF
33239  140 CONTINUE
33240 
33241 C...Loop over attempts made. Reset counters.
33242  ntry=0
33243  150 ntry=ntry+1
33244  IF(ntry.GT.200) THEN
33245  CALL pyerrm(14,'(PYINDF:) caught in infinite loop')
33246  IF(mstu(21).GE.1) RETURN
33247  ENDIF
33248  n=nsav+njet
33249  mstu(90)=mstu90
33250  DO 160 j=1,3
33251  nfl(j)=nfi(j)
33252  ifet(j)=0
33253  kflf(j)=0
33254  160 CONTINUE
33255 
33256 C...Loop over jets to be fragmented.
33257  DO 230 ip1=nsav+1,nsav+njet
33258  mstj(91)=0
33259  nsav1=n
33260  mstu91=mstu(90)
33261 
33262 C...Initial flavour and momentum values. Jet along +z axis.
33263  kflh=iabs(k(ip1,2))
33264  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
33265  kflo(2)=0
33266  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
33267 
33268 C...Initial values for quark or diquark jet.
33269  170 IF(iabs(k(ip1,2)).NE.21) THEN
33270  nstr=1
33271  kflo(1)=k(ip1,2)
33272  CALL pyptdi(0,pxo(1),pyo(1))
33273  wo(1)=wf
33274 
33275 C...Initial values for gluon treated like random quark jet.
33276  ELSEIF(mstj(2).LE.2) THEN
33277  nstr=1
33278  IF(mstj(2).EQ.2) mstj(91)=1
33279  kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
33280  CALL pyptdi(0,pxo(1),pyo(1))
33281  wo(1)=wf
33282 
33283 C...Initial values for gluon treated like quark-antiquark jet pair,
33284 C...sharing energy according to Altarelli-Parisi splitting function.
33285  ELSE
33286  nstr=2
33287  IF(mstj(2).EQ.4) mstj(91)=1
33288  kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
33289  kflo(2)=-kflo(1)
33290  CALL pyptdi(0,pxo(1),pyo(1))
33291  pxo(2)=-pxo(1)
33292  pyo(2)=-pyo(1)
33293  wo(1)=wf*pyr(0)**(1d0/3d0)
33294  wo(2)=wf-wo(1)
33295  ENDIF
33296 
33297 C...Initial values for rank, flavour, pT and W+.
33298  DO 220 istr=1,nstr
33299  180 i=n
33300  mstu(90)=mstu91
33301  irank=0
33302  kfl1=kflo(istr)
33303  px1=pxo(istr)
33304  py1=pyo(istr)
33305  w=wo(istr)
33306 
33307 C...New hadron. Generate flavour and hadron species.
33308  190 i=i+1
33309  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
33310  CALL pyerrm(11,'(PYINDF:) no more memory left in PYJETS')
33311  IF(mstu(21).GE.1) RETURN
33312  ENDIF
33313  irank=irank+1
33314  k(i,1)=1
33315  k(i,3)=ip1
33316  k(i,4)=0
33317  k(i,5)=0
33318  200 CALL pykfdi(kfl1,0,kfl2,k(i,2))
33319  IF(k(i,2).EQ.0) goto 180
33320  IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.
33321  & iabs(kfl2).GT.10) THEN
33322  IF(pyr(0).GT.parj(19)) goto 200
33323  ENDIF
33324 
33325 C...Find hadron mass. Generate four-momentum.
33326  p(i,5)=pymass(k(i,2))
33327  CALL pyptdi(kfl1,px2,py2)
33328  p(i,1)=px1+px2
33329  p(i,2)=py1+py2
33330  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
33331  CALL pyzdis(kfl1,kfl2,pr,z)
33332  mzsav=0
33333  IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
33334  mzsav=1
33335  mstu(90)=mstu(90)+1
33336  mstu(90+mstu(90))=i
33337  paru(90+mstu(90))=z
33338  ENDIF
33339  p(i,3)=0.5d0*(z*w-pr/max(1d-4,z*w))
33340  p(i,4)=0.5d0*(z*w+pr/max(1d-4,z*w))
33341  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
33342  & p(i,3).LE.0.001d0) THEN
33343  IF(w.GE.p(i,5)+0.5d0*parj(32)) goto 180
33344  p(i,3)=0.0001d0
33345  p(i,4)=sqrt(pr)
33346  z=p(i,4)/w
33347  ENDIF
33348 
33349 C...Remaining flavour and momentum.
33350  kfl1=-kfl2
33351  px1=-px2
33352  py1=-py2
33353  w=(1d0-z)*w
33354  DO 210 j=1,5
33355  v(i,j)=0d0
33356  210 CONTINUE
33357 
33358 C...Check if pL acceptable. Go back for new hadron if enough energy.
33359  IF(mstj(3).GE.0.AND.p(i,3).LT.0d0) THEN
33360  i=i-1
33361  IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
33362  ENDIF
33363  IF(w.GT.parj(31)) goto 190
33364  n=i
33365  220 CONTINUE
33366  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1d0*parj(32)
33367  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170
33368 
33369 C...Rotate jet to new direction.
33370  the=pyangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
33371  phi=pyangl(p(ip1,1),p(ip1,2))
33372  mstu(33)=1
33373  CALL pyrobo(nsav1+1,n,the,phi,0d0,0d0,0d0)
33374  k(k(ip1,3),4)=nsav1+1
33375  k(k(ip1,3),5)=n
33376 
33377 C...End of jet generation loop. Skip conservation in some cases.
33378  230 CONTINUE
33379  IF(njet.EQ.1.OR.mstj(3).LE.0) goto 490
33380  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150
33381 
33382 C...Subtract off produced hadron flavours, finished if zero.
33383  DO 240 i=nsav+njet+1,n
33384  kfa=iabs(k(i,2))
33385  kfla=mod(kfa/1000,10)
33386  kflb=mod(kfa/100,10)
33387  kflc=mod(kfa/10,10)
33388  IF(kfla.EQ.0) THEN
33389  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
33390  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
33391  ELSE
33392  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
33393  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
33394  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
33395  ENDIF
33396  240 CONTINUE
33397  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
33398  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
33399  IF(nreq.EQ.0) goto 320
33400 
33401 C...Take away flavour of low-momentum particles until enough freedom.
33402  nrem=0
33403  250 irem=0
33404  p2min=pecm**2
33405  DO 260 i=nsav+njet+1,n
33406  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
33407  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
33408  IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
33409  260 CONTINUE
33410  IF(irem.EQ.0) goto 150
33411  k(irem,1)=7
33412  kfa=iabs(k(irem,2))
33413  kfla=mod(kfa/1000,10)
33414  kflb=mod(kfa/100,10)
33415  kflc=mod(kfa/10,10)
33416  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
33417  IF(k(irem,1).EQ.8) goto 250
33418  IF(kfla.EQ.0) THEN
33419  isgn=isign(1,k(irem,2))*(-1)**kflb
33420  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
33421  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
33422  ELSE
33423  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
33424  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
33425  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
33426  ENDIF
33427  nrem=nrem+1
33428  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
33429  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
33430  IF(nreq.GT.nrem) goto 250
33431  DO 270 i=nsav+njet+1,n
33432  IF(k(i,1).EQ.8) k(i,1)=1
33433  270 CONTINUE
33434 
33435 C...Find combination of existing and new flavours for hadron.
33436  280 nfet=2
33437  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
33438  IF(nreq.LT.nrem) nfet=1
33439  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
33440  DO 290 j=1,nfet
33441  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*pyr(0)
33442  kflf(j)=isign(1,nfl(1))
33443  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
33444  IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
33445  290 CONTINUE
33446  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
33447  &goto 280
33448  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
33449  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
33450  &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280
33451  IF(nfet.EQ.0) kflf(1)=1+int((2d0+parj(2))*pyr(0))
33452  IF(nfet.EQ.0) kflf(2)=-kflf(1)
33453  IF(nfet.EQ.1) kflf(2)=isign(1+int((2d0+parj(2))*pyr(0)),-kflf(1))
33454  IF(nfet.LE.2) kflf(3)=0
33455  IF(kflf(3).NE.0) THEN
33456  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
33457  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
33458  IF(kflf(1).EQ.kflf(3).OR.(1d0+3d0*parj(4))*pyr(0).GT.1d0)
33459  & kflfc=kflfc+isign(2,kflfc)
33460  ELSE
33461  kflfc=kflf(1)
33462  ENDIF
33463  CALL pykfdi(kflfc,kflf(2),kfldmp,kf)
33464  IF(kf.EQ.0) goto 280
33465  DO 300 j=1,max(2,nfet)
33466  nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
33467  300 CONTINUE
33468 
33469 C...Store hadron at random among free positions.
33470  npos=min(1+int(pyr(0)*nrem),nrem)
33471  DO 310 i=nsav+njet+1,n
33472  IF(k(i,1).EQ.7) npos=npos-1
33473  IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310
33474  k(i,1)=1
33475  k(i,2)=kf
33476  p(i,5)=pymass(k(i,2))
33477  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
33478  310 CONTINUE
33479  nrem=nrem-1
33480  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
33481  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
33482  IF(nrem.GT.0) goto 280
33483 
33484 C...Compensate for missing momentum in global scheme (3 options).
33485  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
33486  DO 340 j=1,3
33487  psi(j)=0d0
33488  DO 330 i=nsav+njet+1,n
33489  psi(j)=psi(j)+p(i,j)
33490  330 CONTINUE
33491  340 CONTINUE
33492  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
33493  pws=0d0
33494  DO 350 i=nsav+njet+1,n
33495  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
33496  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
33497  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
33498  IF(mod(mstj(3),5).EQ.3) pws=pws+1d0
33499  350 CONTINUE
33500  DO 370 i=nsav+njet+1,n
33501  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
33502  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
33503  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
33504  IF(mod(mstj(3),5).EQ.3) pw=1d0
33505  DO 360 j=1,3
33506  p(i,j)=p(i,j)-psi(j)*pw/pws
33507  360 CONTINUE
33508  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
33509  370 CONTINUE
33510 
33511 C...Compensate for missing momentum withing each jet separately.
33512  ELSEIF(mod(mstj(3),5).EQ.4) THEN
33513  DO 390 i=n+1,n+njet
33514  k(i,1)=0
33515  DO 380 j=1,5
33516  p(i,j)=0d0
33517  380 CONTINUE
33518  390 CONTINUE
33519  DO 410 i=nsav+njet+1,n
33520  ir1=k(i,3)
33521  ir2=n+ir1-nsav
33522  k(ir2,1)=k(ir2,1)+1
33523  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
33524  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
33525  DO 400 j=1,3
33526  p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
33527  400 CONTINUE
33528  p(ir2,4)=p(ir2,4)+p(i,4)
33529  p(ir2,5)=p(ir2,5)+pls
33530  410 CONTINUE
33531  pss=0d0
33532  DO 420 i=n+1,n+njet
33533  IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8d0*p(i,5)+0.2d0))
33534  420 CONTINUE
33535  DO 440 i=nsav+njet+1,n
33536  ir1=k(i,3)
33537  ir2=n+ir1-nsav
33538  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
33539  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
33540  DO 430 j=1,3
33541  p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1d0/(p(ir2,5)*pss)-1d0)*
33542  & pls*p(ir1,j)
33543  430 CONTINUE
33544  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
33545  440 CONTINUE
33546  ENDIF
33547 
33548 C...Scale momenta for energy conservation.
33549  IF(mod(mstj(3),5).NE.0) THEN
33550  pms=0d0
33551  pes=0d0
33552  pqs=0d0
33553  DO 450 i=nsav+njet+1,n
33554  pms=pms+p(i,5)
33555  pes=pes+p(i,4)
33556  pqs=pqs+p(i,5)**2/p(i,4)
33557  450 CONTINUE
33558  IF(pms.GE.pecm) goto 150
33559  neco=0
33560  460 neco=neco+1
33561  pfac=(pecm-pqs)/(pes-pqs)
33562  pes=0d0
33563  pqs=0d0
33564  DO 480 i=nsav+njet+1,n
33565  DO 470 j=1,3
33566  p(i,j)=pfac*p(i,j)
33567  470 CONTINUE
33568  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
33569  pes=pes+p(i,4)
33570  pqs=pqs+p(i,5)**2/p(i,4)
33571  480 CONTINUE
33572  IF(neco.LT.10.AND.abs(pecm-pes).GT.2d-6*pecm) goto 460
33573  ENDIF
33574 
33575 C...Origin of produced particles and parton daughter pointers.
33576  490 DO 500 i=nsav+njet+1,n
33577  IF(mstu(16).NE.2) k(i,3)=nsav+1
33578  IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
33579  500 CONTINUE
33580  DO 510 i=nsav+1,nsav+njet
33581  i1=k(i,3)
33582  k(i1,1)=k(i1,1)+10
33583  IF(mstu(16).NE.2) THEN
33584  k(i1,4)=nsav+1
33585  k(i1,5)=nsav+1
33586  ELSE
33587  k(i1,4)=k(i1,4)-njet+1
33588  k(i1,5)=k(i1,5)-njet+1
33589  IF(k(i1,5).LT.k(i1,4)) THEN
33590  k(i1,4)=0
33591  k(i1,5)=0
33592  ENDIF
33593  ENDIF
33594  510 CONTINUE
33595 
33596 C...Document independent fragmentation system. Remove copy of jets.
33597  nsav=nsav+1
33598  k(nsav,1)=11
33599  k(nsav,2)=93
33600  k(nsav,3)=ip
33601  k(nsav,4)=nsav+1
33602  k(nsav,5)=n-njet+1
33603  DO 520 j=1,4
33604  p(nsav,j)=dps(j)
33605  v(nsav,j)=v(ip,j)
33606  520 CONTINUE
33607  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
33608  v(nsav,5)=0d0
33609  DO 540 i=nsav+njet,n
33610  DO 530 j=1,5
33611  k(i-njet+1,j)=k(i,j)
33612  p(i-njet+1,j)=p(i,j)
33613  v(i-njet+1,j)=v(i,j)
33614  530 CONTINUE
33615  540 CONTINUE
33616  n=n-njet+1
33617  DO 550 iz=mstu90+1,mstu(90)
33618  mstu(90+iz)=mstu(90+iz)-njet+1
33619  550 CONTINUE
33620 
33621 C...Boost back particle system. Set production vertices.
33622  IF(njet.NE.1) CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),
33623  &dps(2)/dps(4),dps(3)/dps(4))
33624  DO 570 i=nsav+1,n
33625  DO 560 j=1,4
33626  v(i,j)=v(ip,j)
33627  560 CONTINUE
33628  570 CONTINUE
33629 
33630  RETURN
33631  END
33632 
33633 C*********************************************************************
33634 
33635 C...PYDECY
33636 C...Handles the decay of unstable particles.
33637 
33638  SUBROUTINE pydecy(IP)
33639 
33640 C...Double precision and integer declarations.
33641  IMPLICIT DOUBLE PRECISION(a-h, o-z)
33642  INTEGER pyk,pychge,pycomp
33643 C...Commonblocks.
33644  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
33645  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
33646  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
33647  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
33648  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
33649 C...Local arrays.
33650  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
33651  &wtcor(10),ptau(4),pcmtau(4),dbetau(3)
33652  CHARACTER cidc*4
33653  DATA wtcor/2d0,5d0,15d0,60d0,250d0,1500d0,1.2d4,1.2d5,150d0,16d0/
33654 
33655 C...Functions: momentum in two-particle decays and four-product.
33656  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)
33657  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)
33658 
33659 C...Initial values.
33660  ntry=0
33661  nsav=n
33662  kfa=iabs(k(ip,2))
33663  kfs=isign(1,k(ip,2))
33664  kc=pycomp(kfa)
33665  mstj(92)=0
33666 
33667 C...Choose lifetime and determine decay vertex.
33668  IF(k(ip,1).EQ.5) THEN
33669  v(ip,5)=0d0
33670  ELSEIF(k(ip,1).NE.4) THEN
33671  v(ip,5)=-pmas(kc,4)*log(pyr(0))
33672  ENDIF
33673  DO 100 j=1,4
33674  vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
33675  100 CONTINUE
33676 
33677 C...Determine whether decay allowed or not.
33678  mout=0
33679  IF(mstj(22).EQ.2) THEN
33680  IF(pmas(kc,4).GT.parj(71)) mout=1
33681  ELSEIF(mstj(22).EQ.3) THEN
33682  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
33683  ELSEIF(mstj(22).EQ.4) THEN
33684  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
33685  IF(abs(vdcy(3)).GT.parj(74)) mout=1
33686  ENDIF
33687  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
33688  k(ip,1)=4
33689  RETURN
33690  ENDIF
33691 
33692 C...Interface to external tau decay library (for tau polarization).
33693  IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
33694 
33695 C...Starting values for pointers and momenta.
33696  itau=ip
33697  DO 110 j=1,4
33698  ptau(j)=p(itau,j)
33699  pcmtau(j)=p(itau,j)
33700  110 CONTINUE
33701 
33702 C...Iterate to find position and code of mother of tau.
33703  imtau=itau
33704  120 imtau=k(imtau,3)
33705 
33706  IF(imtau.EQ.0) THEN
33707 C...If no known origin then impossible to do anything further.
33708  kforig=0
33709  iorig=0
33710 
33711  ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
33712 C...If tau -> tau + gamma then add gamma energy and loop.
33713  IF(k(k(imtau,4),2).EQ.22) THEN
33714  DO 130 j=1,4
33715  pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
33716  130 CONTINUE
33717  ELSEIF(k(k(imtau,5),2).EQ.22) THEN
33718  DO 140 j=1,4
33719  pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
33720  140 CONTINUE
33721  ENDIF
33722  goto 120
33723 
33724  ELSEIF(iabs(k(imtau,2)).GT.100) THEN
33725 C...If coming from weak decay of hadron then W is not stored in record,
33726 C...but can be reconstructed by adding neutrino momentum.
33727  kforig=-isign(24,k(itau,2))
33728  iorig=0
33729  DO 160 ii=k(imtau,4),k(imtau,5)
33730  IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
33731  DO 150 j=1,4
33732  pcmtau(j)=pcmtau(j)+p(ii,j)
33733  150 CONTINUE
33734  ENDIF
33735  160 CONTINUE
33736 
33737  ELSE
33738 C...If coming from resonance decay then find latest copy of this
33739 C...resonance (may not completely agree).
33740  kforig=k(imtau,2)
33741  iorig=imtau
33742  DO 170 ii=imtau+1,ip-1
33743  IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
33744  & abs(p(ii,5)-p(iorig,5)).LT.1d-5*p(iorig,5)) iorig=ii
33745  170 CONTINUE
33746  DO 180 j=1,4
33747  pcmtau(j)=p(iorig,j)
33748  180 CONTINUE
33749  ENDIF
33750 
33751 C...Boost tau to rest frame of production process (where known)
33752 C...and rotate it to sit along +z axis.
33753  DO 190 j=1,3
33754  dbetau(j)=pcmtau(j)/pcmtau(4)
33755  190 CONTINUE
33756  IF(kforig.NE.0) CALL pyrobo(itau,itau,0d0,0d0,-dbetau(1),
33757  & -dbetau(2),-dbetau(3))
33758  phitau=pyangl(p(itau,1),p(itau,2))
33759  CALL pyrobo(itau,itau,0d0,-phitau,0d0,0d0,0d0)
33760  thetau=pyangl(p(itau,3),p(itau,1))
33761  CALL pyrobo(itau,itau,-thetau,0d0,0d0,0d0,0d0)
33762 
33763 C...Call tau decay routine (if meaningful) and fill extra info.
33764  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
33765  CALL pytaud(itau,iorig,kforig,ndecay)
33766  DO 200 ii=nsav+1,nsav+ndecay
33767  k(ii,1)=1
33768  k(ii,3)=ip
33769  k(ii,4)=0
33770  k(ii,5)=0
33771  200 CONTINUE
33772  n=nsav+ndecay
33773  ENDIF
33774 
33775 C...Boost back decay tau and decay products.
33776  DO 210 j=1,4
33777  p(itau,j)=ptau(j)
33778  210 CONTINUE
33779  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
33780  CALL pyrobo(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
33781  IF(kforig.NE.0) CALL pyrobo(nsav+1,n,0d0,0d0,dbetau(1),
33782  & dbetau(2),dbetau(3))
33783 
33784 C...Skip past ordinary tau decay treatment.
33785  mmat=0
33786  mbst=0
33787  nd=0
33788  goto 630
33789  ENDIF
33790  ENDIF
33791 
33792 C...B-Bbar mixing: flip sign of meson appropriately.
33793  mmix=0
33794  IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
33795  xbbmix=parj(76)
33796  IF(kfa.EQ.531) xbbmix=parj(77)
33797  IF(sin(0.5d0*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.pyr(0)) mmix=1
33798  IF(mmix.EQ.1) kfs=-kfs
33799  ENDIF
33800 
33801 C...Check existence of decay channels. Particle/antiparticle rules.
33802  kca=kc
33803  IF(mdcy(kc,2).GT.0) THEN
33804  mdmdcy=mdme(mdcy(kc,2),2)
33805  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
33806  ENDIF
33807  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
33808  CALL pyerrm(9,'(PYDECY:) no decay channel defined')
33809  RETURN
33810  ENDIF
33811  IF(mod(kfa/1000,10).EQ.0.AND.kca.EQ.85) kfs=-kfs
33812  IF(kchg(kc,3).EQ.0) THEN
33813  kfsp=1
33814  kfsn=0
33815  IF(pyr(0).GT.0.5d0) kfs=-kfs
33816  ELSEIF(kfs.GT.0) THEN
33817  kfsp=1
33818  kfsn=0
33819  ELSE
33820  kfsp=0
33821  kfsn=1
33822  ENDIF
33823 
33824 C...Sum branching ratios of allowed decay channels.
33825  220 nope=0
33826  brsu=0d0
33827  DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
33828  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
33829  & kfsn*mdme(idl,1).NE.3) goto 230
33830  IF(mdme(idl,2).GT.100) goto 230
33831  nope=nope+1
33832  brsu=brsu+brat(idl)
33833  230 CONTINUE
33834  IF(nope.EQ.0) THEN
33835  CALL pyerrm(2,'(PYDECY:) all decay channels closed by user')
33836  RETURN
33837  ENDIF
33838 
33839 C...Select decay channel among allowed ones.
33840  240 rbr=brsu*pyr(0)
33841  idl=mdcy(kca,2)-1
33842  250 idl=idl+1
33843  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
33844  &kfsn*mdme(idl,1).NE.3) THEN
33845  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
33846  ELSEIF(mdme(idl,2).GT.100) THEN
33847  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
33848  ELSE
33849  idc=idl
33850  rbr=rbr-brat(idl)
33851  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0d0) goto 250
33852  ENDIF
33853 
33854 C...Start readout of decay channel: matrix element, reset counters.
33855  mmat=mdme(idc,2)
33856  260 ntry=ntry+1
33857  IF(mod(ntry,200).EQ.0) THEN
33858  WRITE(cidc,'(I4)') idc
33859  CALL pyerrm(4,'(PYDECY:) caught in loop for decay channel'//
33860  & cidc)
33861  goto 240
33862  ENDIF
33863  IF(ntry.GT.1000) THEN
33864  CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
33865  IF(mstu(21).GE.1) RETURN
33866  ENDIF
33867  i=n
33868  np=0
33869  nq=0
33870  mbst=0
33871  IF(mmat.GE.11.AND.p(ip,4).GT.20d0*p(ip,5)) mbst=1
33872  DO 270 j=1,4
33873  pv(1,j)=0d0
33874  IF(mbst.EQ.0) pv(1,j)=p(ip,j)
33875  270 CONTINUE
33876  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
33877  pv(1,5)=p(ip,5)
33878  ps=0d0
33879  psq=0d0
33880  mrem=0
33881  mhaddy=0
33882  IF(kfa.GT.80) mhaddy=1
33883 
33884 C...Read out decay products. Convert to standard flavour code.
33885  jtmax=5
33886  IF(mdme(idc+1,2).EQ.101) jtmax=10
33887  DO 280 jt=1,jtmax
33888  IF(jt.LE.5) kp=kfdp(idc,jt)
33889  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
33890  IF(kp.EQ.0) goto 280
33891  kpa=iabs(kp)
33892  kcp=pycomp(kpa)
33893  IF(kpa.GT.80) mhaddy=1
33894  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
33895  kfp=kp
33896  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
33897  kfp=kfs*kp
33898  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
33899  kfp=-kfs*mod(kfa/10,10)
33900  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
33901  kfp=kfs*(100*mod(kfa/10,100)+3)
33902  ELSEIF(kpa.EQ.81) THEN
33903  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
33904  ELSEIF(kp.EQ.82) THEN
33905  CALL pykfdi(-kfs*int(1d0+(2d0+parj(2))*pyr(0)),0,kfp,kdump)
33906  IF(kfp.EQ.0) goto 260
33907  mstj(93)=1
33908  IF(pv(1,5).LT.parj(32)+2d0*pymass(kfp)) goto 260
33909  ELSEIF(kp.EQ.-82) THEN
33910  kfp=-kfp
33911  IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)
33912  ENDIF
33913  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=pycomp(mod(kfp,10000))
33914 
33915 C...Add decay product to event record or to quark flavour list.
33916  kfpa=iabs(kfp)
33917  kqp=kchg(kcp,2)
33918  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
33919  nq=nq+1
33920  kflo(nq)=kfp
33921  mstj(93)=2
33922  psq=psq+pymass(kflo(nq))
33923  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
33924  & mod(nq,2).EQ.1) THEN
33925  nq=nq-1
33926  ps=ps-p(i,5)
33927  k(i,1)=1
33928  kfi=k(i,2)
33929  CALL pykfdi(kfp,kfi,kfldmp,k(i,2))
33930  IF(k(i,2).EQ.0) goto 260
33931  mstj(93)=1
33932  p(i,5)=pymass(k(i,2))
33933  ps=ps+p(i,5)
33934  ELSE
33935  i=i+1
33936  np=np+1
33937  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
33938  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
33939  k(i,1)=1+mod(nq,2)
33940  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
33941  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
33942  k(i,2)=kfp
33943  k(i,3)=ip
33944  k(i,4)=0
33945  k(i,5)=0
33946  p(i,5)=pymass(kfp)
33947  ps=ps+p(i,5)
33948  ENDIF
33949  280 CONTINUE
33950 
33951 C...Check masses for resonance decays.
33952  IF(mhaddy.EQ.0) THEN
33953  IF(ps+parj(64).GT.pv(1,5)) goto 240
33954  ENDIF
33955 
33956 C...Choose decay multiplicity in phase space model.
33957  290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
33958  psp=ps
33959  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1d0))
33960  IF(mmat.EQ.12) cnde=cnde+parj(63)
33961  300 ntry=ntry+1
33962  IF(ntry.GT.1000) THEN
33963  CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
33964  IF(mstu(21).GE.1) RETURN
33965  ENDIF
33966  IF(mmat.LE.20) THEN
33967  gauss=sqrt(-2d0*cnde*log(max(1d-10,pyr(0))))*
33968  & sin(paru(2)*pyr(0))
33969  nd=0.5d0+0.5d0*np+0.25d0*nq+cnde+gauss
33970  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 300
33971  IF(mmat.EQ.13.AND.nd.EQ.2) goto 300
33972  IF(mmat.EQ.14.AND.nd.LE.3) goto 300
33973  IF(mmat.EQ.15.AND.nd.LE.4) goto 300
33974  ELSE
33975  nd=mmat-20
33976  ENDIF
33977 
33978 C...Form hadrons from flavour content.
33979  DO 310 jt=1,4
33980  kfl1(jt)=kflo(jt)
33981  310 CONTINUE
33982  IF(nd.EQ.np+nq/2) goto 330
33983  DO 320 i=n+np+1,n+nd-nq/2
33984  jt=1+int((nq-1)*pyr(0))
33985  CALL pykfdi(kfl1(jt),0,kfl2,k(i,2))
33986  IF(k(i,2).EQ.0) goto 300
33987  kfl1(jt)=-kfl2
33988  320 CONTINUE
33989  330 jt=2
33990  jt2=3
33991  jt3=4
33992  IF(nq.EQ.4.AND.pyr(0).LT.parj(66)) jt=4
33993  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
33994  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
33995  IF(jt.EQ.3) jt2=2
33996  IF(jt.EQ.4) jt3=2
33997  CALL pykfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
33998  IF(k(n+nd-nq/2+1,2).EQ.0) goto 300
33999  IF(nq.EQ.4) CALL pykfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
34000  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 300
34001 
34002 C...Check that sum of decay product masses not too large.
34003  ps=psp
34004  DO 340 i=n+np+1,n+nd
34005  k(i,1)=1
34006  k(i,3)=ip
34007  k(i,4)=0
34008  k(i,5)=0
34009  p(i,5)=pymass(k(i,2))
34010  ps=ps+p(i,5)
34011  340 CONTINUE
34012  IF(ps+parj(64).GT.pv(1,5)) goto 300
34013 
34014 C...Rescale energy to subtract off spectator quark mass.
34015  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44)
34016  & .AND.np.GE.3) THEN
34017  ps=ps-p(n+np,5)
34018  pqt=(p(n+np,5)+parj(65))/pv(1,5)
34019  DO 350 j=1,5
34020  p(n+np,j)=pqt*pv(1,j)
34021  pv(1,j)=(1d0-pqt)*pv(1,j)
34022  350 CONTINUE
34023  IF(ps+parj(64).GT.pv(1,5)) goto 260
34024  nd=np-1
34025  mrem=1
34026 
34027 C...Fully specified final state: check mass broadening effects.
34028  ELSE
34029  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 260
34030  nd=np
34031  ENDIF
34032 
34033 C...Determine position of grandmother, number of sisters.
34034  nm=0
34035  kfas=0
34036  msgn=0
34037  IF(mmat.EQ.3) THEN
34038  im=k(ip,3)
34039  IF(im.LT.0.OR.im.GE.ip) im=0
34040  IF(im.NE.0) kfam=iabs(k(im,2))
34041  IF(im.NE.0) THEN
34042  DO 360 il=max(ip-2,im+1),min(ip+2,n)
34043  IF(k(il,3).EQ.im) nm=nm+1
34044  IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
34045  360 CONTINUE
34046  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
34047  & mod(kfam/1000,10).NE.0) nm=0
34048  IF(nm.EQ.2) THEN
34049  kfas=iabs(k(isis,2))
34050  IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
34051  & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
34052  ENDIF
34053  ENDIF
34054  ENDIF
34055 
34056 C...Kinematics of one-particle decays.
34057  IF(nd.EQ.1) THEN
34058  DO 370 j=1,4
34059  p(n+1,j)=p(ip,j)
34060  370 CONTINUE
34061  goto 630
34062  ENDIF
34063 
34064 C...Calculate maximum weight ND-particle decay.
34065  pv(nd,5)=p(n+nd,5)
34066  IF(nd.GE.3) THEN
34067  wtmax=1d0/wtcor(nd-2)
34068  pmax=pv(1,5)-ps+p(n+nd,5)
34069  pmin=0d0
34070  DO 380 il=nd-1,1,-1
34071  pmax=pmax+p(n+il,5)
34072  pmin=pmin+p(n+il+1,5)
34073  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
34074  380 CONTINUE
34075  ENDIF
34076 
34077 C...Find virtual gamma mass in Dalitz decay.
34078  390 IF(nd.EQ.2) THEN
34079  ELSEIF(mmat.EQ.2) THEN
34080  pmes=4d0*pmas(11,1)**2
34081  pmrho2=pmas(131,1)**2
34082  pgrho2=pmas(131,2)**2
34083  400 pmst=pmes*(p(ip,5)**2/pmes)**pyr(0)
34084  wt=(1+0.5d0*pmes/pmst)*sqrt(max(0d0,1d0-pmes/pmst))*
34085  & (1d0-pmst/p(ip,5)**2)**3*(1d0+pgrho2/pmrho2)/
34086  & ((1d0-pmst/pmrho2)**2+pgrho2/pmrho2)
34087  IF(wt.LT.pyr(0)) goto 400
34088  pv(2,5)=max(2.00001d0*pmas(11,1),sqrt(pmst))
34089 
34090 C...M-generator gives weight. If rejected, try again.
34091  ELSE
34092  410 rord(1)=1d0
34093  DO 440 il1=2,nd-1
34094  rsav=pyr(0)
34095  DO 420 il2=il1-1,1,-1
34096  IF(rsav.LE.rord(il2)) goto 430
34097  rord(il2+1)=rord(il2)
34098  420 CONTINUE
34099  430 rord(il2+1)=rsav
34100  440 CONTINUE
34101  rord(nd)=0d0
34102  wt=1d0
34103  DO 450 il=nd-1,1,-1
34104  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*
34105  & (pv(1,5)-ps)
34106  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
34107  450 CONTINUE
34108  IF(wt.LT.pyr(0)*wtmax) goto 410
34109  ENDIF
34110 
34111 C...Perform two-particle decays in respective CM frame.
34112  460 DO 480 il=1,nd-1
34113  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
34114  ue(3)=2d0*pyr(0)-1d0
34115  phi=paru(2)*pyr(0)
34116  ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
34117  ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
34118  DO 470 j=1,3
34119  p(n+il,j)=pa*ue(j)
34120  pv(il+1,j)=-pa*ue(j)
34121  470 CONTINUE
34122  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
34123  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
34124  480 CONTINUE
34125 
34126 C...Lorentz transform decay products to lab frame.
34127  DO 490 j=1,4
34128  p(n+nd,j)=pv(nd,j)
34129  490 CONTINUE
34130  DO 530 il=nd-1,1,-1
34131  DO 500 j=1,3
34132  be(j)=pv(il,j)/pv(il,4)
34133  500 CONTINUE
34134  ga=pv(il,4)/pv(il,5)
34135  DO 520 i=n+il,n+nd
34136  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
34137  DO 510 j=1,3
34138  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
34139  510 CONTINUE
34140  p(i,4)=ga*(p(i,4)+bep)
34141  520 CONTINUE
34142  530 CONTINUE
34143 
34144 C...Check that no infinite loop in matrix element weight.
34145  ntry=ntry+1
34146  IF(ntry.GT.800) goto 560
34147 
34148 C...Matrix elements for omega and phi decays.
34149  IF(mmat.EQ.1) THEN
34150  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
34151  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
34152  & +2d0*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
34153  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001d0).LT.pyr(0)) goto 390
34154 
34155 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
34156  ELSEIF(mmat.EQ.2) THEN
34157  four12=four(n+1,n+2)
34158  four13=four(n+1,n+3)
34159  wt=(pmst-0.5d0*pmes)*(four12**2+four13**2)+
34160  & pmes*(four12*four13+four12**2+four13**2)
34161  IF(wt.LT.pyr(0)*0.25d0*pmst*(p(ip,5)**2-pmst)**2) goto 460
34162 
34163 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
34164 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
34165 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
34166  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
34167  four10=four(ip,im)
34168  four12=four(ip,n+1)
34169  four02=four(im,n+1)
34170  pms1=p(ip,5)**2
34171  pms0=p(im,5)**2
34172  pms2=p(n+1,5)**2
34173  IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
34174  IF(kfas.EQ.22) hnum=pms1*(2d0*four10*four12*four02-
34175  & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
34176  hnum=max(1d-6*pms1**2*pms0*pms2,hnum)
34177  hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
34178  IF(hnum.LT.pyr(0)*hden) goto 460
34179 
34180 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
34181  ELSEIF(mmat.EQ.4) THEN
34182  hx1=2d0*four(ip,n+1)/p(ip,5)**2
34183  hx2=2d0*four(ip,n+2)/p(ip,5)**2
34184  hx3=2d0*four(ip,n+3)/p(ip,5)**2
34185  wt=((1d0-hx1)/(hx2*hx3))**2+((1d0-hx2)/(hx1*hx3))**2+
34186  & ((1d0-hx3)/(hx1*hx2))**2
34187  IF(wt.LT.2d0*pyr(0)) goto 390
34188  IF(k(ip+1,2).EQ.22.AND.(1d0-hx1)*p(ip,5)**2.LT.4d0*parj(32)**2)
34189  & goto 390
34190 
34191 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
34192  ELSEIF(mmat.EQ.41) THEN
34193  hx1=2d0*four(ip,n+1)/p(ip,5)**2
34194  hxm=min(0.75d0,2d0*(1d0-ps/p(ip,5)))
34195  IF(hx1*(3d0-2d0*hx1).LT.pyr(0)*hxm*(3d0-2d0*hxm)) goto 390
34196 
34197 C...Matrix elements for weak decays (only semileptonic for c and b)
34198  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
34199  & .AND.nd.EQ.3) THEN
34200  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
34201  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
34202  IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 390
34203  ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
34204  DO 550 j=1,4
34205  p(n+np+1,j)=0d0
34206  DO 540 is=n+3,n+np
34207  p(n+np+1,j)=p(n+np+1,j)+p(is,j)
34208  540 CONTINUE
34209  550 CONTINUE
34210  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
34211  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
34212  IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 390
34213  ENDIF
34214 
34215 C...Scale back energy and reattach spectator.
34216  560 IF(mrem.EQ.1) THEN
34217  DO 570 j=1,5
34218  pv(1,j)=pv(1,j)/(1d0-pqt)
34219  570 CONTINUE
34220  nd=nd+1
34221  mrem=0
34222  ENDIF
34223 
34224 C...Low invariant mass for system with spectator quark gives particle,
34225 C...not two jets. Readjust momenta accordingly.
34226  IF(mmat.EQ.31.AND.nd.EQ.3) THEN
34227  mstj(93)=1
34228  pm2=pymass(k(n+2,2))
34229  mstj(93)=1
34230  pm3=pymass(k(n+3,2))
34231  IF(p(n+2,5)**2+p(n+3,5)**2+2d0*four(n+2,n+3).GE.
34232  & (parj(32)+pm2+pm3)**2) goto 630
34233  k(n+2,1)=1
34234  kftemp=k(n+2,2)
34235  CALL pykfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
34236  IF(k(n+2,2).EQ.0) goto 260
34237  p(n+2,5)=pymass(k(n+2,2))
34238  ps=p(n+1,5)+p(n+2,5)
34239  pv(2,5)=p(n+2,5)
34240  mmat=0
34241  nd=2
34242  goto 460
34243  ELSEIF(mmat.EQ.44) THEN
34244  mstj(93)=1
34245  pm3=pymass(k(n+3,2))
34246  mstj(93)=1
34247  pm4=pymass(k(n+4,2))
34248  IF(p(n+3,5)**2+p(n+4,5)**2+2d0*four(n+3,n+4).GE.
34249  & (parj(32)+pm3+pm4)**2) goto 600
34250  k(n+3,1)=1
34251  kftemp=k(n+3,2)
34252  CALL pykfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
34253  IF(k(n+3,2).EQ.0) goto 260
34254  p(n+3,5)=pymass(k(n+3,2))
34255  DO 580 j=1,3
34256  p(n+3,j)=p(n+3,j)+p(n+4,j)
34257  580 CONTINUE
34258  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)
34259  ha=p(n+1,4)**2-p(n+2,4)**2
34260  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
34261  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
34262  & (p(n+1,3)-p(n+2,3))**2
34263  hd=(pv(1,4)-p(n+3,4))**2
34264  he=ha**2-2d0*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
34265  hf=hd*hc-hb**2
34266  hg=hd*hc-ha*hb
34267  hh=(sqrt(hg**2+he*hf)-hg)/(2d0*hf)
34268  DO 590 j=1,3
34269  pcor=hh*(p(n+1,j)-p(n+2,j))
34270  p(n+1,j)=p(n+1,j)+pcor
34271  p(n+2,j)=p(n+2,j)-pcor
34272  590 CONTINUE
34273  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)
34274  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)
34275  nd=nd-1
34276  ENDIF
34277 
34278 C...Check invariant mass of W jets. May give one particle or start over.
34279  600 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
34280  &.AND.iabs(k(n+1,2)).LT.10) THEN
34281  pmr=sqrt(max(0d0,p(n+1,5)**2+p(n+2,5)**2+2d0*four(n+1,n+2)))
34282  mstj(93)=1
34283  pm1=pymass(k(n+1,2))
34284  mstj(93)=1
34285  pm2=pymass(k(n+2,2))
34286  IF(pmr.GT.parj(32)+pm1+pm2) goto 610
34287  kfldum=int(1.5d0+pyr(0))
34288  CALL pykfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
34289  CALL pykfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
34290  IF(kf1.EQ.0.OR.kf2.EQ.0) goto 260
34291  psm=pymass(kf1)+pymass(kf2)
34292  IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) goto 610
34293  IF(mmat.GE.43.AND.pmr.GT.0.2d0*parj(32)+psm) goto 610
34294  IF(mmat.EQ.48) goto 390
34295  IF(nd.EQ.4.OR.kfa.EQ.15) goto 260
34296  k(n+1,1)=1
34297  kftemp=k(n+1,2)
34298  CALL pykfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
34299  IF(k(n+1,2).EQ.0) goto 260
34300  p(n+1,5)=pymass(k(n+1,2))
34301  k(n+2,2)=k(n+3,2)
34302  p(n+2,5)=p(n+3,5)
34303  ps=p(n+1,5)+p(n+2,5)
34304  IF(ps+parj(64).GT.pv(1,5)) goto 260
34305  pv(2,5)=p(n+3,5)
34306  mmat=0
34307  nd=2
34308  goto 460
34309  ENDIF
34310 
34311 C...Phase space decay of partons from W decay.
34312  610 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
34313  kflo(1)=k(n+1,2)
34314  kflo(2)=k(n+2,2)
34315  k(n+1,1)=k(n+3,1)
34316  k(n+1,2)=k(n+3,2)
34317  DO 620 j=1,5
34318  pv(1,j)=p(n+1,j)+p(n+2,j)
34319  p(n+1,j)=p(n+3,j)
34320  620 CONTINUE
34321  pv(1,5)=pmr
34322  n=n+1
34323  np=0
34324  nq=2
34325  ps=0d0
34326  mstj(93)=2
34327  psq=pymass(kflo(1))
34328  mstj(93)=2
34329  psq=psq+pymass(kflo(2))
34330  mmat=11
34331  goto 290
34332  ENDIF
34333 
34334 C...Boost back for rapidly moving particle.
34335  630 n=n+nd
34336  IF(mbst.EQ.1) THEN
34337  DO 640 j=1,3
34338  be(j)=p(ip,j)/p(ip,4)
34339  640 CONTINUE
34340  ga=p(ip,4)/p(ip,5)
34341  DO 660 i=nsav+1,n
34342  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
34343  DO 650 j=1,3
34344  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
34345  650 CONTINUE
34346  p(i,4)=ga*(p(i,4)+bep)
34347  660 CONTINUE
34348  ENDIF
34349 
34350 C...Fill in position of decay vertex.
34351  DO 680 i=nsav+1,n
34352  DO 670 j=1,4
34353  v(i,j)=vdcy(j)
34354  670 CONTINUE
34355  v(i,5)=0d0
34356  680 CONTINUE
34357 
34358 C...Set up for parton shower evolution from jets.
34359  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
34360  k(nsav+1,1)=3
34361  k(nsav+2,1)=3
34362  k(nsav+3,1)=3
34363  k(nsav+1,4)=mstu(5)*(nsav+2)
34364  k(nsav+1,5)=mstu(5)*(nsav+3)
34365  k(nsav+2,4)=mstu(5)*(nsav+3)
34366  k(nsav+2,5)=mstu(5)*(nsav+1)
34367  k(nsav+3,4)=mstu(5)*(nsav+1)
34368  k(nsav+3,5)=mstu(5)*(nsav+2)
34369  mstj(92)=-(nsav+1)
34370  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
34371  k(nsav+2,1)=3
34372  k(nsav+3,1)=3
34373  k(nsav+2,4)=mstu(5)*(nsav+3)
34374  k(nsav+2,5)=mstu(5)*(nsav+3)
34375  k(nsav+3,4)=mstu(5)*(nsav+2)
34376  k(nsav+3,5)=mstu(5)*(nsav+2)
34377  mstj(92)=nsav+2
34378  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
34379  & iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
34380  k(nsav+1,1)=3
34381  k(nsav+2,1)=3
34382  k(nsav+1,4)=mstu(5)*(nsav+2)
34383  k(nsav+1,5)=mstu(5)*(nsav+2)
34384  k(nsav+2,4)=mstu(5)*(nsav+1)
34385  k(nsav+2,5)=mstu(5)*(nsav+1)
34386  mstj(92)=nsav+1
34387  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
34388  & iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
34389  mstj(92)=nsav+1
34390  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
34391  & THEN
34392  k(nsav+1,1)=3
34393  k(nsav+2,1)=3
34394  k(nsav+3,1)=3
34395  kcp=pycomp(k(nsav+1,2))
34396  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
34397  jcon=4
34398  IF(kqp.LT.0) jcon=5
34399  k(nsav+1,jcon)=mstu(5)*(nsav+2)
34400  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
34401  k(nsav+2,jcon)=mstu(5)*(nsav+3)
34402  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
34403  mstj(92)=nsav+1
34404  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
34405  k(nsav+1,1)=3
34406  k(nsav+3,1)=3
34407  k(nsav+1,4)=mstu(5)*(nsav+3)
34408  k(nsav+1,5)=mstu(5)*(nsav+3)
34409  k(nsav+3,4)=mstu(5)*(nsav+1)
34410  k(nsav+3,5)=mstu(5)*(nsav+1)
34411  mstj(92)=nsav+1
34412  ENDIF
34413 
34414 C...Mark decayed particle; special option for B-Bbar mixing.
34415  IF(k(ip,1).EQ.5) k(ip,1)=15
34416  IF(k(ip,1).LE.10) k(ip,1)=11
34417  IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
34418  k(ip,4)=nsav+1
34419  k(ip,5)=n
34420 
34421  RETURN
34422  END
34423 
34424 C*********************************************************************
34425 
34426 C...PYKFDI
34427 C...Generates a new flavour pair and combines off a hadron.
34428 
34429  SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)
34430 
34431 C...Double precision and integer declarations.
34432  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34433  INTEGER pyk,pychge,pycomp
34434 C...Commonblocks.
34435  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34436  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34437  SAVE /pydat1/,/pydat2/
34438 
34439 C...Default flavour values. Input consistency checks.
34440  kf1a=iabs(kfl1)
34441  kf2a=iabs(kfl2)
34442  kfl3=0
34443  kf=0
34444  IF(kf1a.EQ.0) RETURN
34445  IF(kf2a.NE.0) THEN
34446  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
34447  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
34448  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
34449  ENDIF
34450 
34451 C...Check if tabulated flavour probabilities are to be used.
34452  IF(mstj(15).EQ.1) THEN
34453  ktab1=-1
34454  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
34455  kfl1a=mod(kf1a/1000,10)
34456  kfl1b=mod(kf1a/100,10)
34457  kfl1s=mod(kf1a,10)
34458  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
34459  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
34460  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
34461  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
34462  ktab2=0
34463  IF(kf2a.NE.0) THEN
34464  ktab2=-1
34465  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
34466  kfl2a=mod(kf2a/1000,10)
34467  kfl2b=mod(kf2a/100,10)
34468  kfl2s=mod(kf2a,10)
34469  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
34470  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
34471  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
34472  ENDIF
34473  IF(ktab1.GE.0.AND.ktab2.GE.0) goto 150
34474  ENDIF
34475 
34476 C...Parameters and breaking diquark parameter combinations.
34477  100 par2=parj(2)
34478  par3=parj(3)
34479  par4=3d0*parj(4)
34480  IF(mstj(12).GE.2) THEN
34481  par3m=sqrt(parj(3))
34482  par4m=1d0/(3d0*sqrt(parj(4)))
34483  pardm=parj(7)/(parj(7)+par3m*parj(6))
34484  pars0=parj(5)*(2d0+(1d0+par2*par3m*parj(7))*(1d0+par4m))
34485  pars1=parj(7)*pars0/(2d0*par3m)+parj(5)*(parj(6)*(1d0+par4m)+
34486  & par2*par3m*parj(6)*parj(7))
34487  pars2=parj(5)*2d0*parj(6)*parj(7)*(par2*parj(7)+
34488  & (1d0+par4m)/par3m)
34489  parsm=max(pars0,pars1,pars2)
34490  par4=par4*(1d0+parsm)/(1d0+parsm/(3d0*par4m))
34491  ENDIF
34492 
34493 C...Choice of whether to generate meson or baryon.
34494  110 mbary=0
34495  kfda=0
34496  IF(kf1a.LE.10) THEN
34497  IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1d0+parj(1))*pyr(0).GT.1d0)
34498  & mbary=1
34499  IF(kf2a.GT.10) mbary=2
34500  IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a
34501  ELSE
34502  mbary=2
34503  IF(kf1a.LE.10000) kfda=kf1a
34504  ENDIF
34505 
34506 C...Possibility of process diquark -> meson + new diquark.
34507  IF(kfda.NE.0.AND.mstj(12).GE.2) THEN
34508  kflda=mod(kfda/1000,10)
34509  kfldb=mod(kfda/100,10)
34510  kflds=mod(kfda,10)
34511  wtdq=pars0
34512  IF(max(kflda,kfldb).EQ.3) wtdq=pars1
34513  IF(min(kflda,kfldb).EQ.3) wtdq=pars2
34514  IF(kflds.EQ.1) wtdq=wtdq/(3d0*par4m)
34515  IF((1d0+wtdq)*pyr(0).GT.1d0) mbary=-1
34516  IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN
34517  ENDIF
34518 
34519 C...Flavour for meson, possibly with new flavour.
34520  IF(mbary.LE.0) THEN
34521  kfs=isign(1,kfl1)
34522  IF(mbary.EQ.0) THEN
34523  IF(kf2a.EQ.0) kfl3=isign(1+int((2d0+par2)*pyr(0)),-kfl1)
34524  kfla=max(kf1a,kf2a+iabs(kfl3))
34525  kflb=min(kf1a,kf2a+iabs(kfl3))
34526  IF(kfla.NE.kf1a) kfs=-kfs
34527 
34528 C...Splitting of diquark into meson plus new diquark.
34529  ELSE
34530  kfl1a=mod(kf1a/1000,10)
34531  kfl1b=mod(kf1a/100,10)
34532  120 kfl1d=kfl1a+int(pyr(0)+0.5d0)*(kfl1b-kfl1a)
34533  kfl1e=kfl1a+kfl1b-kfl1d
34534  IF((kfl1d.EQ.3.AND.pyr(0).GT.pardm).OR.(kfl1e.EQ.3.AND.
34535  & pyr(0).LT.pardm)) THEN
34536  kfl1d=kfl1a+kfl1b-kfl1d
34537  kfl1e=kfl1a+kfl1b-kfl1e
34538  ENDIF
34539  kfl3a=1+int((2d0+par2*par3m*parj(7))*pyr(0))
34540  IF((kfl1e.NE.kfl3a.AND.pyr(0).GT.(1d0+par4m)/
34541  & max(2d0,1d0+par4m)).OR.(kfl1e.EQ.kfl3a.AND.pyr(0).GT.
34542  & 2d0/max(2d0,1d0+par4m))) goto 120
34543  kflds=3
34544  IF(kfl1e.NE.kfl3a) kflds=2*int(pyr(0)+1d0/(1d0+par4m))+1
34545  kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+
34546  & kflds,-kfl1)
34547  kfla=max(kfl1d,kfl3a)
34548  kflb=min(kfl1d,kfl3a)
34549  IF(kfla.NE.kfl1d) kfs=-kfs
34550  ENDIF
34551 
34552 C...Form meson, with spin and flavour mixing for diagonal states.
34553  IF(kfla.LE.2) kmul=int(parj(11)+pyr(0))
34554  IF(kfla.EQ.3) kmul=int(parj(12)+pyr(0))
34555  IF(kfla.GE.4) kmul=int(parj(13)+pyr(0))
34556  IF(kmul.EQ.0.AND.parj(14).GT.0d0) THEN
34557  IF(pyr(0).LT.parj(14)) kmul=2
34558  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0d0) THEN
34559  rmul=pyr(0)
34560  IF(rmul.LT.parj(15)) kmul=3
34561  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
34562  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
34563  ENDIF
34564  kfls=3
34565  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
34566  IF(kmul.EQ.5) kfls=5
34567  IF(kfla.NE.kflb) THEN
34568  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
34569  ELSE
34570  rmix=pyr(0)
34571  imix=2*kfla+10*kmul
34572  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
34573  & int(rmix+parf(imix)))+kfls
34574  IF(kfla.GE.4) kf=110*kfla+kfls
34575  ENDIF
34576  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
34577  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
34578 
34579 C...Optional extra suppression of eta and eta'.
34580  IF(kf.EQ.221) THEN
34581  IF(pyr(0).GT.parj(25)) goto 110
34582  ELSEIF(kf.EQ.331) THEN
34583  IF(pyr(0).GT.parj(26)) goto 110
34584  ENDIF
34585 
34586 C...Generate diquark flavour.
34587  ELSE
34588  130 IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN
34589  kfla=kf1a
34590  140 kflb=1+int((2d0+par2*par3)*pyr(0))
34591  kflc=1+int((2d0+par2*par3)*pyr(0))
34592  kflds=1
34593  IF(kflb.GE.kflc) kflds=3
34594  IF(kflds.EQ.1.AND.par4*pyr(0).GT.1d0) goto 140
34595  IF(kflds.EQ.3.AND.par4.LT.pyr(0)) goto 140
34596  kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)
34597 
34598 C...Take diquark flavour from input.
34599  ELSEIF(kf1a.LE.10) THEN
34600  kfla=kf1a
34601  kflb=mod(kf2a/1000,10)
34602  kflc=mod(kf2a/100,10)
34603  kflds=mod(kf2a,10)
34604 
34605 C...Generate (or take from input) quark to go with diquark.
34606  ELSE
34607  IF(kf2a.EQ.0) kfl3=isign(1+int((2d0+par2)*pyr(0)),kfl1)
34608  kfla=kf2a+iabs(kfl3)
34609  kflb=mod(kf1a/1000,10)
34610  kflc=mod(kf1a/100,10)
34611  kflds=mod(kf1a,10)
34612  ENDIF
34613 
34614 C...SU(6) factors for formation of baryon. Try again if fails.
34615  kbary=kflds
34616  IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5
34617  IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1
34618  wt=parf(60+kbary)+parj(18)*parf(70+kbary)
34619  IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN
34620  wtdq=pars0
34621  IF(max(kflb,kflc).EQ.3) wtdq=pars1
34622  IF(min(kflb,kflc).EQ.3) wtdq=pars2
34623  IF(kflds.EQ.1) wtdq=wtdq/(3d0*par4m)
34624  IF(kflds.EQ.1) wt=wt*(1d0+wtdq)/(1d0+parsm/(3d0*par4m))
34625  IF(kflds.EQ.3) wt=wt*(1d0+wtdq)/(1d0+parsm)
34626  ENDIF
34627  IF(kf2a.EQ.0.AND.wt.LT.pyr(0)) goto 130
34628 
34629 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
34630  kfld=max(kfla,kflb,kflc)
34631  kflf=min(kfla,kflb,kflc)
34632  kfle=kfla+kflb+kflc-kfld-kflf
34633  kfls=2
34634  IF((parf(60+kbary)+parj(18)*parf(70+kbary))*pyr(0).GT.
34635  & parf(60+kbary)) kfls=4
34636  kfll=0
34637  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN
34638  IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1
34639  IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25d0+pyr(0))
34640  IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75d0+pyr(0))
34641  ENDIF
34642  IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
34643  IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
34644  ENDIF
34645  RETURN
34646 
34647 C...Use tabulated probabilities to select new flavour and hadron.
34648  150 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
34649  kt3l=1
34650  kt3u=6
34651  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
34652  kt3l=1
34653  kt3u=6
34654  ELSEIF(ktab2.EQ.0) THEN
34655  kt3l=1
34656  kt3u=22
34657  ELSE
34658  kt3l=ktab2
34659  kt3u=ktab2
34660  ENDIF
34661  rfl=0d0
34662  DO 170 kts=0,2
34663  DO 160 kt3=kt3l,kt3u
34664  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
34665  160 CONTINUE
34666  170 CONTINUE
34667  rfl=pyr(0)*rfl
34668  DO 190 kts=0,2
34669  ktabs=kts
34670  DO 180 kt3=kt3l,kt3u
34671  ktab3=kt3
34672  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
34673  IF(rfl.LE.0d0) goto 200
34674  180 CONTINUE
34675  190 CONTINUE
34676  200 CONTINUE
34677 
34678 C...Reconstruct flavour of produced quark/diquark.
34679  IF(ktab3.LE.6) THEN
34680  kfl3a=ktab3
34681  kfl3b=0
34682  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
34683  ELSE
34684  kfl3a=1
34685  IF(ktab3.GE.8) kfl3a=2
34686  IF(ktab3.GE.11) kfl3a=3
34687  IF(ktab3.GE.16) kfl3a=4
34688  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
34689  kfl3=1000*kfl3a+100*kfl3b+1
34690  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
34691  & kfl3+2
34692  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
34693  ENDIF
34694 
34695 C...Reconstruct meson code.
34696  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
34697  &kfl3b.NE.0)) THEN
34698  rfl=pyr(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
34699  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
34700  kf=110+2*ktabs+1
34701  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
34702  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
34703  & 25*ktabs)) kf=330+2*ktabs+1
34704  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
34705  kfla=max(ktab1,ktab3)
34706  kflb=min(ktab1,ktab3)
34707  kfs=isign(1,kfl1)
34708  IF(kfla.NE.kf1a) kfs=-kfs
34709  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
34710  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
34711  kfs=isign(1,kfl1)
34712  IF(kfl1a.EQ.kfl3a) THEN
34713  kfla=max(kfl1b,kfl3b)
34714  kflb=min(kfl1b,kfl3b)
34715  IF(kfla.NE.kfl1b) kfs=-kfs
34716  ELSEIF(kfl1a.EQ.kfl3b) THEN
34717  kfla=kfl3a
34718  kflb=kfl1b
34719  kfs=-kfs
34720  ELSEIF(kfl1b.EQ.kfl3a) THEN
34721  kfla=kfl1a
34722  kflb=kfl3b
34723  ELSEIF(kfl1b.EQ.kfl3b) THEN
34724  kfla=max(kfl1a,kfl3a)
34725  kflb=min(kfl1a,kfl3a)
34726  IF(kfla.NE.kfl1a) kfs=-kfs
34727  ELSE
34728  CALL pyerrm(2,'(PYKFDI:) no matching flavours for qq -> qq')
34729  goto 100
34730  ENDIF
34731  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
34732 
34733 C...Reconstruct baryon code.
34734  ELSE
34735  IF(ktab1.GE.7) THEN
34736  kfla=kfl3a
34737  kflb=kfl1a
34738  kflc=kfl1b
34739  ELSE
34740  kfla=kfl1a
34741  kflb=kfl3a
34742  kflc=kfl3b
34743  ENDIF
34744  kfld=max(kfla,kflb,kflc)
34745  kflf=min(kfla,kflb,kflc)
34746  kfle=kfla+kflb+kflc-kfld-kflf
34747  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
34748  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
34749  ENDIF
34750 
34751 C...Check that constructed flavour code is an allowed one.
34752  IF(kfl2.NE.0) kfl3=0
34753  kc=pycomp(kf)
34754  IF(kc.EQ.0) THEN
34755  CALL pyerrm(2,'(PYKFDI:) user-defined flavour probabilities '//
34756  & 'failed')
34757  goto 100
34758  ENDIF
34759 
34760  RETURN
34761  END
34762 
34763 C*********************************************************************
34764 
34765 C...PYPTDI
34766 C...Generates transverse momentum according to a Gaussian.
34767 
34768  SUBROUTINE pyptdi(KFL,PX,PY)
34769 
34770 C...Double precision and integer declarations.
34771  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34772  INTEGER pyk,pychge,pycomp
34773 C...Commonblocks.
34774  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34775  SAVE /pydat1/
34776 
34777 C...Generate p_T and azimuthal angle, gives p_x and p_y.
34778  kfla=iabs(kfl)
34779  pt=parj(21)*sqrt(-log(max(1d-10,pyr(0))))
34780  IF(parj(23).GT.pyr(0)) pt=parj(24)*pt
34781  IF(mstj(91).EQ.1) pt=parj(22)*pt
34782  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0d0
34783  phi=paru(2)*pyr(0)
34784  px=pt*cos(phi)
34785  py=pt*sin(phi)
34786 
34787  RETURN
34788  END
34789 
34790 C*********************************************************************
34791 
34792 C...PYZDIS
34793 C...Generates the longitudinal splitting variable z.
34794 
34795  SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)
34796 
34797 C...Double precision and integer declarations.
34798  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34799  INTEGER pyk,pychge,pycomp
34800 C...Commonblocks.
34801  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34802  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34803  SAVE /pydat1/,/pydat2/
34804 
34805 C...Check if heavy flavour fragmentation.
34806  kfla=iabs(kfl1)
34807  kflb=iabs(kfl2)
34808  kflh=kfla
34809  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
34810 
34811 C...Lund symmetric scaling function: determine parameters of shape.
34812  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
34813  &mstj(11).GE.4) THEN
34814  fa=parj(41)
34815  IF(mstj(91).EQ.1) fa=parj(43)
34816  IF(kflb.GE.10) fa=fa+parj(45)
34817  fbb=parj(42)
34818  IF(mstj(91).EQ.1) fbb=parj(44)
34819  fb=fbb*pr
34820  fc=1d0
34821  IF(kfla.GE.10) fc=fc-parj(45)
34822  IF(kflb.GE.10) fc=fc+parj(45)
34823  IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN
34824  fred=parj(46)
34825  IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
34826  fc=fc+fred*fbb*parf(100+kflh)**2
34827  ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN
34828  fred=parj(46)
34829  IF(mstj(11).EQ.5) fred=parj(48)
34830  fc=fc+fred*fbb*pmas(kflh,1)**2
34831  ENDIF
34832  mc=1
34833  IF(abs(fc-1d0).GT.0.01d0) mc=2
34834 
34835 C...Determine position of maximum. Special cases for a = 0 or a = c.
34836  IF(fa.LT.0.02d0) THEN
34837  ma=1
34838  zmax=1d0
34839  IF(fc.GT.fb) zmax=fb/fc
34840  ELSEIF(abs(fc-fa).LT.0.01d0) THEN
34841  ma=2
34842  zmax=fb/(fb+fc)
34843  ELSE
34844  ma=3
34845  zmax=0.5d0*(fb+fc-sqrt((fb-fc)**2+4d0*fa*fb))/(fc-fa)
34846  IF(zmax.GT.0.9999d0.AND.fb.GT.100d0) zmax=min(zmax,1d0-fa/fb)
34847  ENDIF
34848 
34849 C...Subdivide z range if distribution very peaked near endpoint.
34850  mmax=2
34851  IF(zmax.LT.0.1d0) THEN
34852  mmax=1
34853  zdiv=2.75d0*zmax
34854  IF(mc.EQ.1) THEN
34855  fint=1d0-log(zdiv)
34856  ELSE
34857  zdivc=zdiv**(1d0-fc)
34858  fint=1d0+(1d0-1d0/zdivc)/(fc-1d0)
34859  ENDIF
34860  ELSEIF(zmax.GT.0.85d0.AND.fb.GT.1d0) THEN
34861  mmax=3
34862  fscb=sqrt(4d0+(fc/fb)**2)
34863  zdiv=fscb-1d0/zmax-(fc/fb)*log(zmax*0.5d0*(fscb+fc/fb))
34864  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1d0-zmax)
34865  zdiv=min(zmax,max(0d0,zdiv))
34866  fint=1d0+fb*(1d0-zdiv)
34867  ENDIF
34868 
34869 C...Choice of z, preweighted for peaks at low or high z.
34870  100 z=pyr(0)
34871  fpre=1d0
34872  IF(mmax.EQ.1) THEN
34873  IF(fint*pyr(0).LE.1d0) THEN
34874  z=zdiv*z
34875  ELSEIF(mc.EQ.1) THEN
34876  z=zdiv**z
34877  fpre=zdiv/z
34878  ELSE
34879  z=(zdivc+z*(1d0-zdivc))**(1d0/(1d0-fc))
34880  fpre=(zdiv/z)**fc
34881  ENDIF
34882  ELSEIF(mmax.EQ.3) THEN
34883  IF(fint*pyr(0).LE.1d0) THEN
34884  z=zdiv+log(z)/fb
34885  fpre=exp(fb*(z-zdiv))
34886  ELSE
34887  z=zdiv+z*(1d0-zdiv)
34888  ENDIF
34889  ENDIF
34890 
34891 C...Weighting according to correct formula.
34892  IF(z.LE.0d0.OR.z.GE.1d0) goto 100
34893  fexp=fc*log(zmax/z)+fb*(1d0/zmax-1d0/z)
34894  IF(ma.GE.2) fexp=fexp+fa*log((1d0-z)/(1d0-zmax))
34895  fval=exp(max(-50d0,min(50d0,fexp)))
34896  IF(fval.LT.pyr(0)*fpre) goto 100
34897 
34898 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
34899  ELSE
34900  fc=parj(50+max(1,kflh))
34901  IF(mstj(91).EQ.1) fc=parj(59)
34902  110 z=pyr(0)
34903  IF(fc.GE.0d0.AND.fc.LE.1d0) THEN
34904  IF(fc.GT.pyr(0)) z=1d0-z**(1d0/3d0)
34905  ELSEIF(fc.GT.-1.AND.fc.LT.0d0) THEN
34906  IF(-4d0*fc*z*(1d0-z)**2.LT.pyr(0)*((1d0-z)**2-fc*z)**2)
34907  & goto 110
34908  ELSE
34909  IF(fc.GT.0d0) z=1d0-z**(1d0/fc)
34910  IF(fc.LT.0d0) z=z**(-1d0/fc)
34911  ENDIF
34912  ENDIF
34913 
34914  RETURN
34915  END
34916 
34917 C*********************************************************************
34918 
34919 C...PYSHOW
34920 C...Generates timelike parton showers from given partons.
34921 
34922  SUBROUTINE pyshow(IP1,IP2,QMAX)
34923 
34924 C...Double precision and integer declarations.
34925  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34926  INTEGER pyk,pychge,pycomp
34927 C...Commonblocks.
34928  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
34929  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34930  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34931  SAVE /pyjets/,/pydat1/,/pydat2/
34932 C...Local arrays.
34933  dimension pmth(5,50),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
34934  &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),
34935  &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),
34936  &isii(2)
34937 
34938 C...Initialization of cutoff masses etc.
34939  IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.
34940  &qmax.LE.min(parj(82),parj(83))) RETURN
34941  DO 100 ifl=0,40
34942  ksh(ifl)=0
34943  100 CONTINUE
34944  ksh(21)=1
34945  pmth(1,21)=pymass(21)
34946  pmth(2,21)=sqrt(pmth(1,21)**2+0.25d0*parj(82)**2)
34947  pmth(3,21)=2d0*pmth(2,21)
34948  pmth(4,21)=pmth(3,21)
34949  pmth(5,21)=pmth(3,21)
34950  pmth(1,22)=pymass(22)
34951  pmth(2,22)=sqrt(pmth(1,22)**2+0.25d0*parj(83)**2)
34952  pmth(3,22)=2d0*pmth(2,22)
34953  pmth(4,22)=pmth(3,22)
34954  pmth(5,22)=pmth(3,22)
34955  pmqth1=parj(82)
34956  IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
34957  pmqth2=pmth(2,21)
34958  IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
34959  DO 110 ifl=1,8
34960  ksh(ifl)=1
34961  pmth(1,ifl)=pymass(ifl)
34962  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*pmqth1**2)
34963  pmth(3,ifl)=pmth(2,ifl)+pmqth2
34964  pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(82)**2)+pmth(2,21)
34965  pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)+pmth(2,22)
34966  110 CONTINUE
34967  DO 120 ifl=11,17,2
34968  IF(mstj(41).GE.2) ksh(ifl)=1
34969  pmth(1,ifl)=pymass(ifl)
34970  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)
34971  pmth(3,ifl)=pmth(2,ifl)+pmth(2,22)
34972  pmth(4,ifl)=pmth(3,ifl)
34973  pmth(5,ifl)=pmth(3,ifl)
34974  120 CONTINUE
34975  pt2min=max(0.5d0*parj(82),1.1d0*parj(81))**2
34976  alams=parj(81)**2
34977  alfm=log(pt2min/alams)
34978 
34979 C...Store positions of shower initiating partons.
34980  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
34981  npa=1
34982  ipa(1)=ip1
34983  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
34984  & mstu(32))) THEN
34985  npa=2
34986  ipa(1)=ip1
34987  ipa(2)=ip2
34988  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
34989  & .AND.ip2.GE.-3) THEN
34990  npa=iabs(ip2)
34991  DO 130 i=1,npa
34992  ipa(i)=ip1+i-1
34993  130 CONTINUE
34994  ELSE
34995  CALL pyerrm(12,
34996  & '(PYSHOW:) failed to reconstruct showering system')
34997  IF(mstu(21).GE.1) RETURN
34998  ENDIF
34999 
35000 C...Check on phase space available for emission.
35001  irej=0
35002  DO 140 j=1,5
35003  ps(j)=0d0
35004  140 CONTINUE
35005  pm=0d0
35006  DO 160 i=1,npa
35007  kfla(i)=iabs(k(ipa(i),2))
35008  pma(i)=p(ipa(i),5)
35009 C...Special cutoff masses for t, l, h with variable masses.
35010  ifla=kfla(i)
35011  IF(kfla(i).GE.6.AND.kfla(i).LE.8) THEN
35012  ifla=37+kfla(i)+isign(2,k(ipa(i),2))
35013  pmth(1,ifla)=pma(i)
35014  pmth(2,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*pmqth1**2)
35015  pmth(3,ifla)=pmth(2,ifla)+pmqth2
35016  pmth(4,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*parj(82)**2)+
35017  & pmth(2,21)
35018  pmth(5,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*parj(83)**2)+
35019  & pmth(2,22)
35020  ENDIF
35021  IF(kfla(i).LE.40) THEN
35022  IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,ifla)
35023  ENDIF
35024  pm=pm+pma(i)
35025  IF(kfla(i).GT.40) THEN
35026  irej=irej+1
35027  ELSE
35028  IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1
35029  ENDIF
35030  DO 150 j=1,4
35031  ps(j)=ps(j)+p(ipa(i),j)
35032  150 CONTINUE
35033  160 CONTINUE
35034  IF(irej.EQ.npa) RETURN
35035  ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
35036  IF(npa.EQ.1) ps(5)=ps(4)
35037  IF(ps(5).LE.pm+pmqth1) RETURN
35038 
35039 C...Check if 3-jet matrix elements to be used.
35040  m3jc=0
35041  IF(npa.EQ.2.AND.mstj(47).GE.1) THEN
35042  IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
35043  & kfla(2).LE.8) m3jc=1
35044  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
35045  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1
35046  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
35047  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1
35048  IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.
35049  & kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1
35050  IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1
35051  m3jcm=0
35052  IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN
35053  m3jcm=1
35054  qme=(2d0*pmth(1,kfla(1))/ps(5))**2
35055  ENDIF
35056  ENDIF
35057 
35058 C...Find if interference with initial state partons.
35059  miis=0
35060  IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2) miis=mstj(50)
35061  IF(miis.NE.0) THEN
35062  DO 180 i=1,2
35063  kcii(i)=0
35064  kca=pycomp(kfla(i))
35065  IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
35066  niis(i)=0
35067  IF(kcii(i).NE.0) THEN
35068  DO 170 j=1,2
35069  icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
35070  IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
35071  & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
35072  niis(i)=niis(i)+1
35073  iiis(i,niis(i))=icsi
35074  ENDIF
35075  170 CONTINUE
35076  ENDIF
35077  180 CONTINUE
35078  IF(niis(1)+niis(2).EQ.0) miis=0
35079  ENDIF
35080 
35081 C...Boost interfering initial partons to rest frame
35082 C...and reconstruct their polar and azimuthal angles.
35083  IF(miis.NE.0) THEN
35084  DO 200 i=1,2
35085  DO 190 j=1,5
35086  k(n+i,j)=k(ipa(i),j)
35087  p(n+i,j)=p(ipa(i),j)
35088  v(n+i,j)=0d0
35089  190 CONTINUE
35090  200 CONTINUE
35091  DO 220 i=3,2+niis(1)
35092  DO 210 j=1,5
35093  k(n+i,j)=k(iiis(1,i-2),j)
35094  p(n+i,j)=p(iiis(1,i-2),j)
35095  v(n+i,j)=0d0
35096  210 CONTINUE
35097  220 CONTINUE
35098  DO 240 i=3+niis(1),2+niis(1)+niis(2)
35099  DO 230 j=1,5
35100  k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
35101  p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
35102  v(n+i,j)=0d0
35103  230 CONTINUE
35104  240 CONTINUE
35105  CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,0d0,-ps(1)/ps(4),
35106  & -ps(2)/ps(4),-ps(3)/ps(4))
35107  phi=pyangl(p(n+1,1),p(n+1,2))
35108  CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,-phi,0d0,0d0,0d0)
35109  the=pyangl(p(n+1,3),p(n+1,1))
35110  CALL pyrobo(n+1,n+2+niis(1)+niis(2),-the,0d0,0d0,0d0,0d0)
35111  DO 250 i=3,2+niis(1)
35112  theiis(1,i-2)=pyangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
35113  phiiis(1,i-2)=pyangl(p(n+i,1),p(n+i,2))
35114  250 CONTINUE
35115  DO 260 i=3+niis(1),2+niis(1)+niis(2)
35116  theiis(2,i-2-niis(1))=paru(1)-pyangl(p(n+i,3),
35117  & sqrt(p(n+i,1)**2+p(n+i,2)**2))
35118  phiiis(2,i-2-niis(1))=pyangl(p(n+i,1),p(n+i,2))
35119  260 CONTINUE
35120  ENDIF
35121 
35122 C...Define imagined single initiator of shower for parton system.
35123  ns=n
35124  IF(n.GT.mstu(4)-mstu(32)-5) THEN
35125  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
35126  IF(mstu(21).GE.1) RETURN
35127  ENDIF
35128  IF(npa.GE.2) THEN
35129  k(n+1,1)=11
35130  k(n+1,2)=21
35131  k(n+1,3)=0
35132  k(n+1,4)=0
35133  k(n+1,5)=0
35134  p(n+1,1)=0d0
35135  p(n+1,2)=0d0
35136  p(n+1,3)=0d0
35137  p(n+1,4)=ps(5)
35138  p(n+1,5)=ps(5)
35139  v(n+1,5)=ps(5)**2
35140  n=n+1
35141  ENDIF
35142 
35143 C...Loop over partons that may branch.
35144  nep=npa
35145  im=ns
35146  IF(npa.EQ.1) im=ns-1
35147  270 im=im+1
35148  IF(n.GT.ns) THEN
35149  IF(im.GT.n) goto 510
35150  kflm=iabs(k(im,2))
35151  IF(kflm.GT.40) goto 270
35152  IF(ksh(kflm).EQ.0) goto 270
35153  iflm=kflm
35154  IF(kflm.GE.6.AND.kflm.LE.8) iflm=37+kflm+isign(2,k(im,2))
35155  IF(p(im,5).LT.pmth(2,iflm)) goto 270
35156  igm=k(im,3)
35157  ELSE
35158  igm=-1
35159  ENDIF
35160  IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
35161  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
35162  IF(mstu(21).GE.1) RETURN
35163  ENDIF
35164 
35165 C...Position of aunt (sister to branching parton).
35166 C...Origin and flavour of daughters.
35167  iau=0
35168  IF(igm.GT.0) THEN
35169  IF(k(im-1,3).EQ.igm) iau=im-1
35170  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
35171  ENDIF
35172  IF(igm.GE.0) THEN
35173  k(im,4)=n+1
35174  DO 280 i=1,nep
35175  k(n+i,3)=im
35176  280 CONTINUE
35177  ELSE
35178  k(n+1,3)=ipa(1)
35179  ENDIF
35180  IF(igm.LE.0) THEN
35181  DO 290 i=1,nep
35182  k(n+i,2)=k(ipa(i),2)
35183  290 CONTINUE
35184  ELSEIF(kflm.NE.21) THEN
35185  k(n+1,2)=k(im,2)
35186  k(n+2,2)=k(im,5)
35187  ELSEIF(k(im,5).EQ.21) THEN
35188  k(n+1,2)=21
35189  k(n+2,2)=21
35190  ELSE
35191  k(n+1,2)=k(im,5)
35192  k(n+2,2)=-k(im,5)
35193  ENDIF
35194 
35195 C...Reset flags on daughers and tries made.
35196  DO 300 ip=1,nep
35197  k(n+ip,1)=3
35198  k(n+ip,4)=0
35199  k(n+ip,5)=0
35200  kfld(ip)=iabs(k(n+ip,2))
35201  IF(kchg(pycomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
35202  itry(ip)=0
35203  isl(ip)=0
35204  isi(ip)=0
35205  IF(kfld(ip).LE.40) THEN
35206  IF(ksh(kfld(ip)).EQ.1) isi(ip)=1
35207  ENDIF
35208  300 CONTINUE
35209  islm=0
35210 
35211 C...Maximum virtuality of daughters.
35212  IF(igm.LE.0) THEN
35213  DO 310 i=1,npa
35214  IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
35215  & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
35216  p(n+i,5)=min(qmax,ps(5))
35217  IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
35218  IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
35219  310 CONTINUE
35220  ELSE
35221  IF(mstj(43).LE.2) pem=v(im,2)
35222  IF(mstj(43).GE.3) pem=p(im,4)
35223  p(n+1,5)=min(p(im,5),v(im,1)*pem)
35224  p(n+2,5)=min(p(im,5),(1d0-v(im,1))*pem)
35225  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
35226  ENDIF
35227  DO 320 i=1,nep
35228  pmsd(i)=p(n+i,5)
35229  IF(isi(i).EQ.1) THEN
35230  ifld=kfld(i)
35231  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
35232  & isign(2,k(n+i,2))
35233  IF(p(n+i,5).LE.pmth(3,ifld)) p(n+i,5)=pmth(1,ifld)
35234  ENDIF
35235  v(n+i,5)=p(n+i,5)**2
35236  320 CONTINUE
35237 
35238 C...Choose one of the daughters for evolution.
35239  330 inum=0
35240  IF(nep.EQ.1) inum=1
35241  DO 340 i=1,nep
35242  IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
35243  340 CONTINUE
35244  DO 350 i=1,nep
35245  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
35246  ifld=kfld(i)
35247  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
35248  & isign(2,k(n+i,2))
35249  IF(p(n+i,5).GE.pmth(2,ifld)) inum=i
35250  ENDIF
35251  350 CONTINUE
35252  IF(inum.EQ.0) THEN
35253  rmax=0d0
35254  DO 360 i=1,nep
35255  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN
35256  rpm=p(n+i,5)/pmsd(i)
35257  ifld=kfld(i)
35258  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
35259  & isign(2,k(n+i,2))
35260  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ifld)) THEN
35261  rmax=rpm
35262  inum=i
35263  ENDIF
35264  ENDIF
35265  360 CONTINUE
35266  ENDIF
35267 
35268 C...Store information on choice of evolving daughter.
35269  inum=max(1,inum)
35270  iep(1)=n+inum
35271  DO 370 i=2,nep
35272  iep(i)=iep(i-1)+1
35273  IF(iep(i).GT.n+nep) iep(i)=n+1
35274  370 CONTINUE
35275  DO 380 i=1,nep
35276  kfl(i)=iabs(k(iep(i),2))
35277  380 CONTINUE
35278  itry(inum)=itry(inum)+1
35279  IF(itry(inum).GT.200) THEN
35280  CALL pyerrm(14,'(PYSHOW:) caught in infinite loop')
35281  IF(mstu(21).GE.1) RETURN
35282  ENDIF
35283  z=0.5d0
35284  IF(kfl(1).GT.40) goto 430
35285  IF(ksh(kfl(1)).EQ.0) goto 430
35286  ifl=kfl(1)
35287  IF(kfl(1).GE.6.AND.kfl(1).LE.8) ifl=37+kfl(1)+
35288  &isign(2,k(iep(1),2))
35289  IF(p(iep(1),5).LT.pmth(2,ifl)) goto 430
35290 
35291 C...Select side for interference with initial state partons.
35292  IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
35293  iii=iep(1)-ns-1
35294  isii(iii)=0
35295  IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
35296  isii(iii)=1
35297  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
35298  IF(pyr(0).GT.0.5d0) isii(iii)=1
35299  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
35300  isii(iii)=1
35301  IF(pyr(0).GT.0.5d0) isii(iii)=2
35302  ENDIF
35303  ENDIF
35304 
35305 C...Calculate allowed z range.
35306  IF(nep.EQ.1) THEN
35307  pmed=ps(4)
35308  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
35309  pmed=p(im,5)
35310  ELSE
35311  IF(inum.EQ.1) pmed=v(im,1)*pem
35312  IF(inum.EQ.2) pmed=(1d0-v(im,1))*pem
35313  ENDIF
35314  IF(mod(mstj(43),2).EQ.1) THEN
35315  zc=pmth(2,21)/pmed
35316  zce=pmth(2,22)/pmed
35317  ELSE
35318  zc=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,21)/pmed)**2)))
35319  IF(zc.LT.1d-4) zc=(pmth(2,21)/pmed)**2
35320  zce=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,22)/pmed)**2)))
35321  IF(zce.LT.1d-4) zce=(pmth(2,22)/pmed)**2
35322  ENDIF
35323  zc=min(zc,0.491d0)
35324  zce=min(zce,0.491d0)
35325  IF((mstj(41).EQ.1.AND.zc.GT.0.49d0).OR.(mstj(41).GE.2.AND.
35326  &min(zc,zce).GT.0.49d0)) THEN
35327  p(iep(1),5)=pmth(1,ifl)
35328  v(iep(1),5)=p(iep(1),5)**2
35329  goto 430
35330  ENDIF
35331 
35332 C...Integral of Altarelli-Parisi z kernel for QCD.
35333  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
35334  fbr=6d0*log((1d0-zc)/zc)+mstj(45)*(0.5d0-zc)
35335  ELSEIF(mstj(49).EQ.0) THEN
35336  fbr=(8d0/3d0)*log((1d0-zc)/zc)
35337 
35338 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
35339  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
35340  fbr=(parj(87)+mstj(45)*parj(88))*(1d0-2d0*zc)
35341  ELSEIF(mstj(49).EQ.1) THEN
35342  fbr=(1d0-2d0*zc)/3d0
35343  IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4d0*fbr
35344 
35345 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
35346  ELSEIF(kfl(1).EQ.21) THEN
35347  fbr=6d0*mstj(45)*(0.5d0-zc)
35348  ELSE
35349  fbr=2d0*log((1d0-zc)/zc)
35350  ENDIF
35351 
35352 C...Reset QCD probability for lepton.
35353  IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0d0
35354 
35355 C...Integral of Altarelli-Parisi kernel for photon emission.
35356  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
35357  fbre=(kchg(kfl(1),1)/3d0)**2*2d0*log((1d0-zce)/zce)
35358  IF(mstj(41).EQ.10) fbre=parj(84)*fbre
35359  ENDIF
35360 
35361 C...Inner veto algorithm starts. Find maximum mass for evolution.
35362  390 pms=v(iep(1),5)
35363  IF(igm.GE.0) THEN
35364  pm2=0d0
35365  DO 400 i=2,nep
35366  pm=p(iep(i),5)
35367  IF(kfl(i).LE.40) THEN
35368  ifli=kfl(i)
35369  IF(kfl(i).GE.6.AND.kfl(i).LE.8) ifli=37+kfl(i)+
35370  & isign(2,k(iep(i),2))
35371  IF(ksh(kfl(i)).EQ.1) pm=pmth(2,ifli)
35372  ENDIF
35373  pm2=pm2+pm
35374  400 CONTINUE
35375  pms=min(pms,(p(im,5)-pm2)**2)
35376  ENDIF
35377 
35378 C...Select mass for daughter in QCD evolution.
35379  b0=27d0/6d0
35380  DO 410 iff=4,mstj(45)
35381  IF(pms.GT.4d0*pmth(2,iff)**2) b0=(33d0-2d0*iff)/6d0
35382  410 CONTINUE
35383  IF(fbr.LT.1d-3) THEN
35384  pmsqcd=0d0
35385  ELSEIF(mstj(44).LE.0) THEN
35386  pmsqcd=pms*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(111)*fbr)))
35387  ELSEIF(mstj(44).EQ.1) THEN
35388  pmsqcd=4d0*alams*(0.25d0*pms/alams)**(pyr(0)**(b0/fbr))
35389  ELSE
35390  pmsqcd=pms*exp(max(-50d0,alfm*b0*log(pyr(0))/fbr))
35391  ENDIF
35392  IF(zc.GT.0.49d0.OR.pmsqcd.LE.pmth(4,ifl)**2) pmsqcd=pmth(2,ifl)**2
35393  v(iep(1),5)=pmsqcd
35394  mce=1
35395 
35396 C...Select mass for daughter in QED evolution.
35397  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
35398  pmsqed=pms*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(101)*fbre)))
35399  IF(zce.GT.0.49d0.OR.pmsqed.LE.pmth(5,ifl)**2) pmsqed=
35400  & pmth(2,ifl)**2
35401  IF(pmsqed.GT.pmsqcd) THEN
35402  v(iep(1),5)=pmsqed
35403  mce=2
35404  ENDIF
35405  ENDIF
35406 
35407 C...Check whether daughter mass below cutoff.
35408  p(iep(1),5)=sqrt(v(iep(1),5))
35409  IF(p(iep(1),5).LE.pmth(3,ifl)) THEN
35410  p(iep(1),5)=pmth(1,ifl)
35411  v(iep(1),5)=p(iep(1),5)**2
35412  goto 430
35413  ENDIF
35414 
35415 C...Select z value of branching: q -> qgamma.
35416  IF(mce.EQ.2) THEN
35417  z=1d0-(1d0-zce)*(zce/(1d0-zce))**pyr(0)
35418  IF(1d0+z**2.LT.2d0*pyr(0)) goto 390
35419  k(iep(1),5)=22
35420 
35421 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
35422  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
35423  z=1d0-(1d0-zc)*(zc/(1d0-zc))**pyr(0)
35424  IF(1d0+z**2.LT.2d0*pyr(0)) goto 390
35425  k(iep(1),5)=21
35426  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5d0-zc).LT.pyr(0)*fbr) THEN
35427  z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
35428  IF(pyr(0).GT.0.5d0) z=1d0-z
35429  IF((1d0-z*(1d0-z))**2.LT.pyr(0)) goto 390
35430  k(iep(1),5)=21
35431  ELSEIF(mstj(49).NE.1) THEN
35432  z=zc+(1d0-2d0*zc)*pyr(0)
35433  IF(z**2+(1d0-z)**2.LT.pyr(0)) goto 390
35434  kflb=1+int(mstj(45)*pyr(0))
35435  pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
35436  IF(pmq.GE.1d0) goto 390
35437  pmq0=4d0*pmth(2,21)**2/v(iep(1),5)
35438  IF(mod(mstj(43),2).EQ.0.AND.(1d0+0.5d0*pmq)*sqrt(1d0-pmq).LT.
35439  & pyr(0)*(1d0+0.5d0*pmq0)*sqrt(1d0-pmq0)) goto 390
35440  k(iep(1),5)=kflb
35441 
35442 C...Ditto for scalar gluon model.
35443  ELSEIF(kfl(1).NE.21) THEN
35444  z=1d0-sqrt(zc**2+pyr(0)*(1d0-2d0*zc))
35445  k(iep(1),5)=21
35446  ELSEIF(pyr(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
35447  z=zc+(1d0-2d0*zc)*pyr(0)
35448  k(iep(1),5)=21
35449  ELSE
35450  z=zc+(1d0-2d0*zc)*pyr(0)
35451  kflb=1+int(mstj(45)*pyr(0))
35452  pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
35453  IF(pmq.GE.1d0) goto 390
35454  k(iep(1),5)=kflb
35455  ENDIF
35456  IF(mce.EQ.1.AND.mstj(44).GE.2) THEN
35457  IF(z*(1d0-z)*v(iep(1),5).LT.pt2min) goto 390
35458  IF(alfm/log(v(iep(1),5)*z*(1d0-z)/alams).LT.pyr(0)) goto 390
35459  ENDIF
35460 
35461 C...Check if z consistent with chosen m.
35462  IF(kfl(1).EQ.21) THEN
35463  kflgd1=iabs(k(iep(1),5))
35464  kflgd2=kflgd1
35465  ELSE
35466  kflgd1=kfl(1)
35467  kflgd2=iabs(k(iep(1),5))
35468  ENDIF
35469  IF(nep.EQ.1) THEN
35470  ped=ps(4)
35471  ELSEIF(nep.GE.3) THEN
35472  ped=p(iep(1),4)
35473  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
35474  ped=0.5d0*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
35475  ELSE
35476  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
35477  IF(iep(1).EQ.n+2) ped=(1d0-v(im,1))*pem
35478  ENDIF
35479  IF(mod(mstj(43),2).EQ.1) THEN
35480  iflgd1=kflgd1
35481  IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=ifl
35482  pmqth3=0.5d0*parj(82)
35483  IF(kflgd2.EQ.22) pmqth3=0.5d0*parj(83)
35484  pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(iep(1),5)
35485  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
35486  zd=sqrt(max(0d0,(1d0-v(iep(1),5)/ped**2)*((1d0-pmq1-pmq2)**2-
35487  & 4d0*pmq1*pmq2)))
35488  zh=1d0+pmq1-pmq2
35489  ELSE
35490  zd=sqrt(max(0d0,1d0-v(iep(1),5)/ped**2))
35491  zh=1d0
35492  ENDIF
35493  zl=0.5d0*(zh-zd)
35494  zu=0.5d0*(zh+zd)
35495  IF(z.LT.zl.OR.z.GT.zu) goto 390
35496  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1d0-zl)/max(1d-20,zl*
35497  &(1d0-zu)))
35498  IF(kfl(1).NE.21) v(iep(1),3)=log((1d0-zl)/max(1d-10,1d0-zu))
35499 
35500 C...Width suppression for q -> q + g.
35501  IF(mstj(40).NE.0.AND.kfl(1).NE.21) THEN
35502  IF(igm.EQ.0) THEN
35503  eglu=0.5d0*ps(5)*(1d0-z)*(1d0+v(iep(1),5)/v(ns+1,5))
35504  ELSE
35505  eglu=pmed*(1d0-z)
35506  ENDIF
35507  chi=parj(89)**2/(parj(89)**2+eglu**2)
35508  IF(mstj(40).EQ.1) THEN
35509  IF(chi.LT.pyr(0)) goto 390
35510  ELSEIF(mstj(40).EQ.2) THEN
35511  IF(1d0-chi.LT.pyr(0)) goto 390
35512  ENDIF
35513  ENDIF
35514 
35515 C...Three-jet matrix element correction.
35516  IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
35517  x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
35518  x2=1d0-v(iep(1),5)/v(ns+1,5)
35519  x3=(1d0-x1)+(1d0-x2)
35520  IF(mce.EQ.2) THEN
35521  ki1=k(ipa(inum),2)
35522  ki2=k(ipa(3-inum),2)
35523  qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3d0
35524  qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3d0
35525  wshow=qf1**2*(1d0-x1)/x3*(1d0+(x1/(2d0-x2))**2)+
35526  & qf2**2*(1d0-x2)/x3*(1d0+(x2/(2d0-x1))**2)
35527  wme=(qf1*(1d0-x1)/x3-qf2*(1d0-x2)/x3)**2*(x1**2+x2**2)
35528  ELSEIF(mstj(49).NE.1) THEN
35529  wshow=1d0+(1d0-x1)/x3*(x1/(2d0-x2))**2+
35530  & (1d0-x2)/x3*(x2/(2d0-x1))**2
35531  wme=x1**2+x2**2
35532  IF(m3jcm.EQ.1) wme=wme-qme*x3-0.5d0*qme**2-
35533  & (0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/max(1d-7,1d0-x1)+
35534  & (1d0-x1)/max(1d-7,1d0-x2))
35535  ELSE
35536  wshow=4d0*x3*((1d0-x1)/(2d0-x2)**2+(1d0-x2)/(2d0-x1)**2)
35537  wme=x3**2
35538  IF(mstj(102).GE.2) wme=x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*
35539  & parj(171)
35540  ENDIF
35541  IF(wme.LT.pyr(0)*wshow) goto 390
35542 
35543 C...Impose angular ordering by rejection of nonordered emission.
35544  ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN
35545  maom=1
35546  zm=v(im,1)
35547  IF(iep(1).EQ.n+2) zm=1d0-v(im,1)
35548  the2id=z*(1d0-z)*(zm*p(im,4))**2/v(iep(1),5)
35549  iaom=im
35550  420 IF(k(iaom,5).EQ.22) THEN
35551  iaom=k(iaom,3)
35552  IF(k(iaom,3).LE.ns) maom=0
35553  IF(maom.EQ.1) goto 420
35554  ENDIF
35555  IF(maom.EQ.1) THEN
35556  the2im=v(iaom,1)*(1d0-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
35557  IF(the2id.LT.the2im) goto 390
35558  ENDIF
35559  ENDIF
35560 
35561 C...Impose user-defined maximum angle at first branching.
35562  IF(mstj(48).EQ.1) THEN
35563  IF(nep.EQ.1.AND.im.EQ.ns) THEN
35564  the2id=z*(1d0-z)*ps(4)**2/v(iep(1),5)
35565  IF(the2id.LT.1d0/parj(85)**2) goto 390
35566  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
35567  the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
35568  IF(the2id.LT.1d0/parj(85)**2) goto 390
35569  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
35570  the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
35571  IF(the2id.LT.1d0/parj(86)**2) goto 390
35572  ENDIF
35573  ENDIF
35574 
35575 C...Impose angular constraint in first branching from interference
35576 C...with initial state partons.
35577  IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
35578  the2d=max((1d0-z)/z,z/(1d0-z))*v(iep(1),5)/(0.5d0*p(im,4))**2
35579  IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
35580  IF(the2d.GT.theiis(1,isii(1))**2) goto 390
35581  ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
35582  IF(the2d.GT.theiis(2,isii(2))**2) goto 390
35583  ENDIF
35584  ENDIF
35585 
35586 C...End of inner veto algorithm. Check if only one leg evolved so far.
35587  430 v(iep(1),1)=z
35588  isl(1)=0
35589  isl(2)=0
35590  IF(nep.EQ.1) goto 460
35591  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 330
35592  DO 440 i=1,nep
35593  IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN
35594  IF(ksh(kfld(i)).EQ.1) THEN
35595  ifld=kfld(i)
35596  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
35597  & isign(2,k(n+i,2))
35598  IF(p(n+i,5).GE.pmth(2,ifld)) goto 330
35599  ENDIF
35600  ENDIF
35601  440 CONTINUE
35602 
35603 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
35604  IF(nep.EQ.3) THEN
35605  pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
35606  pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
35607  pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
35608  pts=0.25d0*(2d0*pa1s*pa2s+2d0*pa1s*pa3s+2d0*pa2s*pa3s-
35609  & pa1s**2-pa2s**2-pa3s**2)/pa1s
35610  IF(pts.LE.0d0) goto 330
35611  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
35612  DO 450 i1=n+1,n+2
35613  kflda=iabs(k(i1,2))
35614  IF(kflda.GT.40) goto 450
35615  IF(ksh(kflda).EQ.0) goto 450
35616  iflda=kflda
35617  IF(kflda.GE.6.AND.kflda.LE.8) iflda=37+kflda+
35618  & isign(2,k(i1,2))
35619  IF(p(i1,5).LT.pmth(2,iflda)) goto 450
35620  IF(kflda.EQ.21) THEN
35621  kflgd1=iabs(k(i1,5))
35622  kflgd2=kflgd1
35623  ELSE
35624  kflgd1=kflda
35625  kflgd2=iabs(k(i1,5))
35626  ENDIF
35627  i2=2*n+3-i1
35628  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
35629  ped=0.5d0*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
35630  ELSE
35631  IF(i1.EQ.n+1) zm=v(im,1)
35632  IF(i1.EQ.n+2) zm=1d0-v(im,1)
35633  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
35634  & 4d0*v(n+1,5)*v(n+2,5))
35635  ped=pem*(0.5d0*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)
35636  ENDIF
35637  IF(mod(mstj(43),2).EQ.1) THEN
35638  pmqth3=0.5d0*parj(82)
35639  IF(kflgd2.EQ.22) pmqth3=0.5d0*parj(83)
35640  iflgd1=kflgd1
35641  IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=iflda
35642  pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(i1,5)
35643  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
35644  zd=sqrt(max(0d0,(1d0-v(i1,5)/ped**2)*((1d0-pmq1-pmq2)**2-
35645  & 4d0*pmq1*pmq2)))
35646  zh=1d0+pmq1-pmq2
35647  ELSE
35648  zd=sqrt(max(0d0,1d0-v(i1,5)/ped**2))
35649  zh=1d0
35650  ENDIF
35651  zl=0.5d0*(zh-zd)
35652  zu=0.5d0*(zh+zd)
35653  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1
35654  IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1
35655  IF(kflda.EQ.21) v(i1,4)=log(zu*(1d0-zl)/max(1d-20,
35656  & zl*(1d0-zu)))
35657  IF(kflda.NE.21) v(i1,4)=log((1d0-zl)/max(1d-10,1d0-zu))
35658  450 CONTINUE
35659  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
35660  isl(3-islm)=0
35661  islm=3-islm
35662  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
35663  zdr1=max(0d0,v(n+1,3)/max(1d-6,v(n+1,4))-1d0)
35664  zdr2=max(0d0,v(n+2,3)/max(1d-6,v(n+2,4))-1d0)
35665  IF(zdr2.GT.pyr(0)*(zdr1+zdr2)) isl(1)=0
35666  IF(isl(1).EQ.1) isl(2)=0
35667  IF(isl(1).EQ.0) islm=1
35668  IF(isl(2).EQ.0) islm=2
35669  ENDIF
35670  IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 330
35671  ENDIF
35672  ifld1=kfld(1)
35673  IF(kfld(1).GE.6.AND.kfld(1).LE.8) ifld1=37+kfld(1)+
35674  &isign(2,k(n+1,2))
35675  ifld2=kfld(2)
35676  IF(kfld(2).GE.6.AND.kfld(2).LE.8) ifld2=37+kfld(2)+
35677  &isign(2,k(n+2,2))
35678  IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
35679  &pmth(2,ifld1).OR.p(n+2,5).GE.pmth(2,ifld2))) THEN
35680  pmq1=v(n+1,5)/v(im,5)
35681  pmq2=v(n+2,5)/v(im,5)
35682  zd=sqrt(max(0d0,(1d0-v(im,5)/pem**2)*((1d0-pmq1-pmq2)**2-
35683  & 4d0*pmq1*pmq2)))
35684  zh=1d0+pmq1-pmq2
35685  zl=0.5d0*(zh-zd)
35686  zu=0.5d0*(zh+zd)
35687  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 330
35688  ENDIF
35689 
35690 C...Accepted branch. Construct four-momentum for initial partons.
35691  460 mazip=0
35692  mazic=0
35693  IF(nep.EQ.1) THEN
35694  p(n+1,1)=0d0
35695  p(n+1,2)=0d0
35696  p(n+1,3)=sqrt(max(0d0,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
35697  & p(n+1,5))))
35698  p(n+1,4)=p(ipa(1),4)
35699  v(n+1,2)=p(n+1,4)
35700  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
35701  ped1=0.5d0*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
35702  p(n+1,1)=0d0
35703  p(n+1,2)=0d0
35704  p(n+1,3)=sqrt(max(0d0,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
35705  p(n+1,4)=ped1
35706  p(n+2,1)=0d0
35707  p(n+2,2)=0d0
35708  p(n+2,3)=-p(n+1,3)
35709  p(n+2,4)=p(im,5)-ped1
35710  v(n+1,2)=p(n+1,4)
35711  v(n+2,2)=p(n+2,4)
35712  ELSEIF(nep.EQ.3) THEN
35713  p(n+1,1)=0d0
35714  p(n+1,2)=0d0
35715  p(n+1,3)=sqrt(max(0d0,pa1s))
35716  p(n+2,1)=sqrt(pts)
35717  p(n+2,2)=0d0
35718  p(n+2,3)=0.5d0*(pa3s-pa2s-pa1s)/p(n+1,3)
35719  p(n+3,1)=-p(n+2,1)
35720  p(n+3,2)=0d0
35721  p(n+3,3)=-(p(n+1,3)+p(n+2,3))
35722  v(n+1,2)=p(n+1,4)
35723  v(n+2,2)=p(n+2,4)
35724  v(n+3,2)=p(n+3,4)
35725 
35726 C...Construct transverse momentum for ordinary branching in shower.
35727  ELSE
35728  zm=v(im,1)
35729  pzm=sqrt(max(0d0,(pem+p(im,5))*(pem-p(im,5))))
35730  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4d0*v(n+1,5)*v(n+2,5)
35731  IF(pzm.LE.0d0) THEN
35732  pts=0d0
35733  ELSEIF(mod(mstj(43),2).EQ.1) THEN
35734  pts=(pem**2*(zm*(1d0-zm)*v(im,5)-(1d0-zm)*v(n+1,5)-
35735  & zm*v(n+2,5))-0.25d0*pmls)/pzm**2
35736  ELSE
35737  pts=pmls*(zm*(1d0-zm)*pem**2/v(im,5)-0.25d0)/pzm**2
35738  ENDIF
35739  pt=sqrt(max(0d0,pts))
35740 
35741 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
35742  hazip=0d0
35743  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21
35744  & .AND.iau.NE.0) THEN
35745  IF(k(igm,3).NE.0) mazip=1
35746  zau=v(igm,1)
35747  IF(iau.EQ.im+1) zau=1d0-v(igm,1)
35748  IF(mazip.EQ.0) zau=0d0
35749  IF(k(igm,2).NE.21) THEN
35750  hazip=2d0*zau/(1d0+zau**2)
35751  ELSE
35752  hazip=(zau/(1d0-zau*(1d0-zau)))**2
35753  ENDIF
35754  IF(k(n+1,2).NE.21) THEN
35755  hazip=hazip*(-2d0*zm*(1d0-zm))/(1d0-2d0*zm*(1d0-zm))
35756  ELSE
35757  hazip=hazip*(zm*(1d0-zm)/(1d0-zm*(1d0-zm)))**2
35758  ENDIF
35759  ENDIF
35760 
35761 C...Find coefficient of azimuthal asymmetry due to soft gluon
35762 C...interference.
35763  hazic=0d0
35764  IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
35765  & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
35766  IF(k(igm,3).NE.0) mazic=n+1
35767  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
35768  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
35769  & zm.GT.0.5d0) mazic=n+2
35770  IF(k(iau,2).EQ.22) mazic=0
35771  zs=zm
35772  IF(mazic.EQ.n+2) zs=1d0-zm
35773  zgm=v(igm,1)
35774  IF(iau.EQ.im-1) zgm=1d0-v(igm,1)
35775  IF(mazic.EQ.0) zgm=1d0
35776  IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
35777  & sqrt((1d0-zs)*(1d0-zgm)/(zs*zgm))
35778  hazic=min(0.95d0,hazic)
35779  ENDIF
35780  ENDIF
35781 
35782 C...Construct kinematics for ordinary branching in shower.
35783  470 IF(nep.EQ.2.AND.igm.GT.0) THEN
35784  IF(mod(mstj(43),2).EQ.1) THEN
35785  p(n+1,4)=pem*v(im,1)
35786  ELSE
35787  p(n+1,4)=pem*(0.5d0*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
35788  & sqrt(pmls)*zm)/v(im,5)
35789  ENDIF
35790  phi=paru(2)*pyr(0)
35791  p(n+1,1)=pt*cos(phi)
35792  p(n+1,2)=pt*sin(phi)
35793  IF(pzm.GT.0d0) THEN
35794  p(n+1,3)=0.5d0*(v(n+2,5)-v(n+1,5)-v(im,5)+
35795  & 2d0*pem*p(n+1,4))/pzm
35796  ELSE
35797  p(n+1,3)=0d0
35798  ENDIF
35799  p(n+2,1)=-p(n+1,1)
35800  p(n+2,2)=-p(n+1,2)
35801  p(n+2,3)=pzm-p(n+1,3)
35802  p(n+2,4)=pem-p(n+1,4)
35803  IF(mstj(43).LE.2) THEN
35804  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
35805  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
35806  ENDIF
35807  ENDIF
35808 
35809 C...Rotate and boost daughters.
35810  IF(igm.GT.0) THEN
35811  IF(mstj(43).LE.2) THEN
35812  bex=p(igm,1)/p(igm,4)
35813  bey=p(igm,2)/p(igm,4)
35814  bez=p(igm,3)/p(igm,4)
35815  ga=p(igm,4)/p(igm,5)
35816  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1d0+ga)-
35817  & p(im,4))
35818  ELSE
35819  bex=0d0
35820  bey=0d0
35821  bez=0d0
35822  ga=1d0
35823  gabep=0d0
35824  ENDIF
35825  the=pyangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+
35826  & (p(im,2)+gabep*bey)**2))
35827  phi=pyangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
35828  DO 480 i=n+1,n+2
35829  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
35830  & sin(the)*cos(phi)*p(i,3)
35831  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
35832  & sin(the)*sin(phi)*p(i,3)
35833  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
35834  dp(4)=p(i,4)
35835  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
35836  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
35837  p(i,1)=dp(1)+dgabp*bex
35838  p(i,2)=dp(2)+dgabp*bey
35839  p(i,3)=dp(3)+dgabp*bez
35840  p(i,4)=ga*(dp(4)+dbp)
35841  480 CONTINUE
35842  ENDIF
35843 
35844 C...Weight with azimuthal distribution, if required.
35845  IF(mazip.NE.0.OR.mazic.NE.0) THEN
35846  DO 490 j=1,3
35847  dpt(1,j)=p(im,j)
35848  dpt(2,j)=p(iau,j)
35849  dpt(3,j)=p(n+1,j)
35850  490 CONTINUE
35851  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
35852  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
35853  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
35854  DO 500 j=1,3
35855  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm
35856  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm
35857  500 CONTINUE
35858  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
35859  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
35860  IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
35861  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
35862  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
35863  IF(mazip.NE.0) THEN
35864  IF(1d0+hazip*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(hazip)))
35865  & goto 470
35866  ENDIF
35867  IF(mazic.NE.0) THEN
35868  IF(mazic.EQ.n+2) cad=-cad
35869  IF((1d0-hazic)*(1d0-hazic*cad)/(1d0+hazic**2-2d0*hazic*cad)
35870  & .LT.pyr(0)) goto 470
35871  ENDIF
35872  ENDIF
35873  ENDIF
35874 
35875 C...Azimuthal anisotropy due to interference with initial state partons.
35876  IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
35877  &k(n+2,2).EQ.21)) THEN
35878  iii=im-ns-1
35879  IF(isii(iii).GE.1) THEN
35880  iaziid=n+1
35881  IF(k(n+1,2).NE.21) iaziid=n+2
35882  IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
35883  & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
35884  theiid=pyangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
35885  IF(iii.EQ.2) theiid=paru(1)-theiid
35886  phiiid=pyangl(p(iaziid,1),p(iaziid,2))
35887  hazii=min(0.95d0,theiid/theiis(iii,isii(iii)))
35888  cad=cos(phiiid-phiiis(iii,isii(iii)))
35889  phirel=abs(phiiid-phiiis(iii,isii(iii)))
35890  IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
35891  IF((1d0-hazii)*(1d0-hazii*cad)/(1d0+hazii**2-2d0*hazii*cad)
35892  & .LT.pyr(0)) goto 470
35893  ENDIF
35894  ENDIF
35895 
35896 C...Continue loop over partons that may branch, until none left.
35897  IF(igm.GE.0) k(im,1)=14
35898  n=n+nep
35899  nep=2
35900  IF(n.GT.mstu(4)-mstu(32)-5) THEN
35901  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
35902  IF(mstu(21).GE.1) n=ns
35903  IF(mstu(21).GE.1) RETURN
35904  ENDIF
35905  goto 270
35906 
35907 C...Set information on imagined shower initiator.
35908  510 IF(npa.GE.2) THEN
35909  k(ns+1,1)=11
35910  k(ns+1,2)=94
35911  k(ns+1,3)=ip1
35912  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
35913  k(ns+1,4)=ns+2
35914  k(ns+1,5)=ns+1+npa
35915  iim=1
35916  ELSE
35917  iim=0
35918  ENDIF
35919 
35920 C...Reconstruct string drawing information.
35921  DO 520 i=ns+1+iim,n
35922  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
35923  k(i,1)=1
35924  ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
35925  & iabs(k(i,2)).LE.18) THEN
35926  k(i,1)=1
35927  ELSEIF(k(i,1).LE.10) THEN
35928  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
35929  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
35930  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
35931  id1=mod(k(i,4),mstu(5))
35932  IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
35933  id2=2*mod(k(i,4),mstu(5))+1-id1
35934  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
35935  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
35936  k(id1,4)=k(id1,4)+mstu(5)*i
35937  k(id1,5)=k(id1,5)+mstu(5)*id2
35938  k(id2,4)=k(id2,4)+mstu(5)*id1
35939  k(id2,5)=k(id2,5)+mstu(5)*i
35940  ELSE
35941  id1=mod(k(i,4),mstu(5))
35942  id2=id1+1
35943  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
35944  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
35945  IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN
35946  k(id1,4)=k(id1,4)+mstu(5)*i
35947  k(id1,5)=k(id1,5)+mstu(5)*i
35948  ELSE
35949  k(id1,4)=0
35950  k(id1,5)=0
35951  ENDIF
35952  k(id2,4)=0
35953  k(id2,5)=0
35954  ENDIF
35955  520 CONTINUE
35956 
35957 C...Transformation from CM frame.
35958  IF(npa.GE.2) THEN
35959  bex=ps(1)/ps(4)
35960  bey=ps(2)/ps(4)
35961  bez=ps(3)/ps(4)
35962  ga=ps(4)/ps(5)
35963  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
35964  & /(1d0+ga)-p(ipa(1),4))
35965  ELSE
35966  bex=0d0
35967  bey=0d0
35968  bez=0d0
35969  gabep=0d0
35970  ENDIF
35971  the=pyangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
35972  &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
35973  phi=pyangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
35974  IF(npa.EQ.3) THEN
35975  chi=pyangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
35976  & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
35977  & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
35978  & gabep*bey))
35979  mstu(33)=1
35980  CALL pyrobo(ns+1,n,0d0,chi,0d0,0d0,0d0)
35981  ENDIF
35982  mstu(33)=1
35983  CALL pyrobo(ns+1,n,the,phi,bex,bey,bez)
35984 
35985 C...Decay vertex of shower.
35986  DO 540 i=ns+1,n
35987  DO 530 j=1,5
35988  v(i,j)=v(ip1,j)
35989  530 CONTINUE
35990  540 CONTINUE
35991 
35992 C...Delete trivial shower, else connect initiators.
35993  IF(n.EQ.ns+npa+iim) THEN
35994  n=ns
35995  ELSE
35996  DO 550 ip=1,npa
35997  k(ipa(ip),1)=14
35998  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
35999  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
36000  k(ns+iim+ip,3)=ipa(ip)
36001  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
36002  IF(k(ns+iim+ip,1).NE.1) THEN
36003  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
36004  k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
36005  ENDIF
36006  550 CONTINUE
36007  ENDIF
36008 
36009  RETURN
36010  END
36011 
36012 C*********************************************************************
36013 
36014 C...PYBOEI
36015 C...Modifies an event so as to approximately take into account
36016 C...Bose-Einstein effects according to a simple phenomenological
36017 C...parametrization.
36018 
36019  SUBROUTINE pyboei(NSAV)
36020 
36021 C...Double precision and integer declarations.
36022  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36023  INTEGER pyk,pychge,pycomp
36024 C...Commonblocks.
36025  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
36026  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36027  SAVE /pyjets/,/pydat1/
36028 C...Local arrays and data.
36029  dimension dps(4),kfbe(9),nbe(0:9),bei(100)
36030  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
36031 
36032 C...Boost event to overall CM frame. Calculate CM energy.
36033  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
36034  DO 100 j=1,4
36035  dps(j)=0d0
36036  100 CONTINUE
36037  DO 120 i=1,n
36038  kfa=iabs(k(i,2))
36039  IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22)
36040  & .AND.k(i,3).GT.0) THEN
36041  kfma=iabs(k(k(i,3),2))
36042  IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
36043  ENDIF
36044  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120
36045  DO 110 j=1,4
36046  dps(j)=dps(j)+p(i,j)
36047  110 CONTINUE
36048  120 CONTINUE
36049  CALL pyrobo(0,0,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
36050  &-dps(3)/dps(4))
36051  pecm=0d0
36052  DO 130 i=1,n
36053  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
36054  130 CONTINUE
36055 
36056 C...Reserve copy of particles by species at end of record.
36057  nbe(0)=n+mstu(3)
36058  DO 160 ibe=1,min(9,mstj(52))
36059  nbe(ibe)=nbe(ibe-1)
36060  DO 150 i=nsav+1,n
36061  IF(k(i,2).NE.kfbe(ibe)) goto 150
36062  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150
36063  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
36064  CALL pyerrm(11,'(PYBOEI:) no more memory left in PYJETS')
36065  RETURN
36066  ENDIF
36067  nbe(ibe)=nbe(ibe)+1
36068  k(nbe(ibe),1)=i
36069  DO 140 j=1,3
36070  p(nbe(ibe),j)=0d0
36071  140 CONTINUE
36072  150 CONTINUE
36073  160 CONTINUE
36074  IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) goto 280
36075 
36076 C...Tabulate integral for subsequent momentum shift.
36077  DO 220 ibe=1,min(9,mstj(52))
36078  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 180
36079  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
36080  & .LE.1) goto 180
36081  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
36082  & nbe(7)-nbe(6)).LE.1) goto 180
36083  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 180
36084  IF(ibe.EQ.1) pmhq=2d0*pymass(211)
36085  IF(ibe.EQ.4) pmhq=2d0*pymass(321)
36086  IF(ibe.EQ.8) pmhq=2d0*pymass(221)
36087  IF(ibe.EQ.9) pmhq=2d0*pymass(331)
36088  qdel=0.1d0*min(pmhq,parj(93))
36089  IF(mstj(51).EQ.1) THEN
36090  nbin=min(100,nint(9d0*parj(93)/qdel))
36091  beex=exp(0.5d0*qdel/parj(93))
36092  bert=exp(-qdel/parj(93))
36093  ELSE
36094  nbin=min(100,nint(3d0*parj(93)/qdel))
36095  ENDIF
36096  DO 170 ibin=1,nbin
36097  qbin=qdel*(ibin-0.5d0)
36098  bei(ibin)=qdel*(qbin**2+qdel**2/12d0)/sqrt(qbin**2+pmhq**2)
36099  IF(mstj(51).EQ.1) THEN
36100  beex=beex*bert
36101  bei(ibin)=bei(ibin)*beex
36102  ELSE
36103  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
36104  ENDIF
36105  IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
36106  170 CONTINUE
36107 
36108 C...Loop through particle pairs and find old relative momentum.
36109  180 DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)-1
36110  i1=k(i1m,1)
36111  DO 200 i2m=i1m+1,nbe(ibe)
36112  i2=k(i2m,1)
36113  q2old=max(0d0,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-
36114  & (p(i1,2)+ p(i2,2))**2-(p(i1,3)+p(i2,3))**2-
36115  & (p(i1,5)+p(i2,5))**2)
36116  qold=sqrt(q2old)
36117 
36118 C...Calculate new relative momentum.
36119  IF(qold.LT.1d-3*qdel) THEN
36120  goto 200
36121  ELSEIF(qold.LE.qdel) THEN
36122  qmov=qold/3d0
36123  ELSEIF(qold.LT.(nbin-0.1d0)*qdel) THEN
36124  rbin=qold/qdel
36125  ibin=rbin
36126  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
36127  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
36128  & sqrt(q2old+pmhq**2)/q2old
36129  ELSE
36130  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
36131  ENDIF
36132  q2new=q2old*(qold/(qold+3d0*parj(92)*qmov))**(2d0/3d0)
36133 
36134 C...Calculate and save shift to be performed on three-momenta.
36135  hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)
36136  hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2
36137  ha=0.5d0*(1d0-sqrt(hc1*q2new/(hc1*q2old-hc2)))
36138  DO 190 j=1,3
36139  pd=ha*(p(i2,j)-p(i1,j))
36140  p(i1m,j)=p(i1m,j)+pd
36141  p(i2m,j)=p(i2m,j)-pd
36142  190 CONTINUE
36143  200 CONTINUE
36144  210 CONTINUE
36145  220 CONTINUE
36146 
36147 C...Shift momenta and recalculate energies.
36148  DO 240 im=nbe(0)+1,nbe(min(9,mstj(52)))
36149  i=k(im,1)
36150  DO 230 j=1,3
36151  p(i,j)=p(i,j)+p(im,j)
36152  230 CONTINUE
36153  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
36154  240 CONTINUE
36155 
36156 C...Rescale all momenta for energy conservation.
36157  pes=0d0
36158  pqs=0d0
36159  DO 250 i=1,n
36160  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 250
36161  pes=pes+p(i,4)
36162  pqs=pqs+p(i,5)**2/p(i,4)
36163  250 CONTINUE
36164  fac=(pecm-pqs)/(pes-pqs)
36165  DO 270 i=1,n
36166  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
36167  DO 260 j=1,3
36168  p(i,j)=fac*p(i,j)
36169  260 CONTINUE
36170  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
36171  270 CONTINUE
36172 
36173 C...Boost back to correct reference frame.
36174  280 CALL pyrobo(0,0,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
36175  DO 290 i=1,n
36176  IF(k(i,1).LT.0) k(i,1)=-k(i,1)
36177  290 CONTINUE
36178 
36179  RETURN
36180  END
36181 
36182 C*********************************************************************
36183 
36184 C...PYMASS
36185 C...Gives the mass of a particle/parton.
36186 
36187  FUNCTION pymass(KF)
36188 
36189 C...Double precision and integer declarations.
36190  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36191  INTEGER pyk,pychge,pycomp
36192 C...Commonblocks.
36193  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36194  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36195  SAVE /pydat1/,/pydat2/
36196 
36197 C...Reset variables. Compressed code. Special case for popcorn diquarks.
36198  pymass=0d0
36199  kfa=iabs(kf)
36200  IF(kfa/10000.EQ.1.AND.mod(kfa/10,10).EQ.0) kfa=kfa-10000
36201  kc=pycomp(isign(kfa,kf))
36202  IF(kc.EQ.0) THEN
36203  mstj(93)=0
36204  RETURN
36205  ENDIF
36206 
36207 C...Guarantee use of constituent masses for internal checks.
36208  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.
36209  &(kfa.LE.10.OR.mod(kfa/10,10).EQ.0)) THEN
36210  parf(106)=pmas(6,1)
36211  parf(107)=pmas(7,1)
36212  parf(108)=pmas(8,1)
36213  IF(kfa.LE.10) THEN
36214  pymass=parf(100+kfa)
36215  IF(mstj(93).EQ.2) pymass=max(0d0,pymass-parf(121))
36216  ELSEIF(mstj(93).EQ.1) THEN
36217  pymass=parf(100+mod(kfa/1000,10))+parf(100+mod(kfa/100,10))
36218  ELSE
36219  pymass=max(0d0,pmas(kc,1)-parf(122)-2d0*parf(112)/3d0)
36220  ENDIF
36221 
36222 C...Other masses can be read directly off table.
36223  ELSE
36224  pymass=pmas(kc,1)
36225  ENDIF
36226 
36227 C...Optional mass broadening according to truncated Breit-Wigner
36228 C...(either in m or in m^2).
36229  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1d-4) THEN
36230  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
36231  pymass=pymass+0.5d0*pmas(kc,2)*tan((2d0*pyr(0)-1d0)*
36232  & atan(2d0*pmas(kc,3)/pmas(kc,2)))
36233  ELSE
36234  pm0=pymass
36235  pmlow=atan((max(0d0,pm0-pmas(kc,3))**2-pm0**2)/
36236  & (pm0*pmas(kc,2)))
36237  pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
36238  pymass=sqrt(max(0d0,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
36239  & (pmupp-pmlow)*pyr(0))))
36240  ENDIF
36241  ENDIF
36242  mstj(93)=0
36243 
36244  RETURN
36245  END
36246 
36247 C*********************************************************************
36248 
36249 C...PYNAME
36250 C...Gives the particle/parton name as a character string.
36251 
36252  SUBROUTINE pyname(KF,CHAU)
36253 
36254 C...Double precision and integer declarations.
36255  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36256  INTEGER pyk,pychge,pycomp
36257 C...Commonblocks.
36258  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36259  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36260  common/pydat4/chaf(500,2)
36261  CHARACTER chaf*16
36262  SAVE /pydat1/,/pydat2/,/pydat4/
36263 C...Local character variable.
36264  CHARACTER chau*16
36265 
36266 C...Read out code with distinction particle/antiparticle.
36267  chau=' '
36268  kc=pycomp(kf)
36269  IF(kc.NE.0) chau=chaf(kc,(3-isign(1,kf))/2)
36270 
36271 
36272  RETURN
36273  END
36274 
36275 C*********************************************************************
36276 
36277 C...PYCHGE
36278 C...Gives three times the charge for a particle/parton.
36279 
36280  FUNCTION pychge(KF)
36281 
36282 C...Double precision and integer declarations.
36283  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36284  INTEGER pyk,pychge,pycomp
36285 C...Commonblocks.
36286  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36287  SAVE /pydat2/
36288 
36289 C...Read out charge and change sign for antiparticle.
36290  pychge=0
36291  kc=pycomp(kf)
36292  IF(kc.NE.0) pychge=kchg(kc,1)*isign(1,kf)
36293 
36294  RETURN
36295  END
36296 
36297 C*********************************************************************
36298 
36299 C...PYCOMP
36300 C...Compress the standard KF codes for use in mass and decay arrays;
36301 C...also checks whether a given code actually is defined.
36302 
36303  FUNCTION pycomp(KF)
36304 
36305 C...Double precision and integer declarations.
36306  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36307  INTEGER pyk,pychge,pycomp
36308 C...Commonblocks.
36309  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36310  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36311  SAVE /pydat1/,/pydat2/
36312 C...Local arrays and saved data.
36313  dimension kford(100:500),kcord(101:500)
36314  SAVE kford,kcord,nford,kflast,kclast
36315 
36316 C...Whenever necessary reorder codes for faster search.
36317  IF(mstu(20).EQ.0) THEN
36318  nford=100
36319  kford(100)=0
36320  DO 120 i=101,500
36321  kfa=kchg(i,4)
36322  IF(kfa.LE.100) goto 120
36323  nford=nford+1
36324  DO 100 i1=nford-1,0,-1
36325  IF(kfa.GE.kford(i1)) goto 110
36326  kford(i1+1)=kford(i1)
36327  kcord(i1+1)=kcord(i1)
36328  100 CONTINUE
36329  110 kford(i1+1)=kfa
36330  kcord(i1+1)=i
36331  120 CONTINUE
36332  mstu(20)=1
36333  kflast=0
36334  kclast=0
36335  ENDIF
36336 
36337 C...Fast action if same code as in latest call.
36338  IF(kf.EQ.kflast) THEN
36339  pycomp=kclast
36340  RETURN
36341  ENDIF
36342 
36343 C...Starting values.
36344  pycomp=0
36345  kfa=iabs(kf)
36346 
36347 C...Simple cases: direct translation.
36348  IF(kfa.GT.kford(nford)) THEN
36349  ELSEIF(kfa.LE.100) THEN
36350  pycomp=kfa
36351 
36352 C...Else binary search.
36353  ELSE
36354  imin=100
36355  imax=nford+1
36356  130 iavg=(imin+imax)/2
36357  IF(kford(iavg).GT.kfa) THEN
36358  imax=iavg
36359  IF(imax.GT.imin+1) goto 130
36360  ELSEIF(kford(iavg).LT.kfa) THEN
36361  imin=iavg
36362  IF(imax.GT.imin+1) goto 130
36363  ELSE
36364  pycomp=kcord(iavg)
36365  ENDIF
36366  ENDIF
36367 
36368 C...Check if antiparticle allowed.
36369  IF(pycomp.NE.0.AND.kf.LT.0) THEN
36370  IF(kchg(pycomp,3).EQ.0) pycomp=0
36371  ENDIF
36372 
36373 C...Save codes for possible future fast action.
36374  kflast=kf
36375  kclast=pycomp
36376 
36377  RETURN
36378  END
36379 
36380 C*********************************************************************
36381 
36382 C...PYERRM
36383 C...Informs user of errors in program execution.
36384 
36385  SUBROUTINE pyerrm(MERR,CHMESS)
36386 
36387 C...Double precision and integer declarations.
36388  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36389  INTEGER pyk,pychge,pycomp
36390 C...Commonblocks.
36391  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
36392  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36393  SAVE /pyjets/,/pydat1/
36394 C...Local character variable.
36395  CHARACTER chmess*(*)
36396 
36397 C...Write first few warnings, then be silent.
36398  IF(merr.LE.10) THEN
36399  mstu(27)=mstu(27)+1
36400  mstu(28)=merr
36401  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
36402  & merr,mstu(31),chmess
36403 
36404 C...Write first few errors, then be silent or stop program.
36405  ELSEIF(merr.LE.20) THEN
36406  mstu(23)=mstu(23)+1
36407  mstu(24)=merr-10
36408  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
36409  & merr-10,mstu(31),chmess
36410  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
36411  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
36412  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
36413  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
36414  WRITE(mstu(11),5200)
36415  IF(merr.NE.17) CALL pylist(2)
36416  IF(merr.NE.17) CALL pylist(2)
36417  IF(merr.NE.17) CALL pylist(2)
36418  WRITE(6,*)' J.R. programme continuing without stop'
36419 C STOP
36420  ENDIF
36421 
36422 C...Stop program in case of irreparable error.
36423  ELSE
36424  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
36425  stop
36426  ENDIF
36427 
36428 C...Formats for output.
36429  5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i9,
36430  &' PYEXEC calls:'/5x,a)
36431  5100 FORMAT(/5x,'Error type',i2,' has occured after',i9,
36432  &' PYEXEC calls:'/5x,a)
36433  5200 FORMAT(5x,'Execution will be stopped after listing of last ',
36434  &'event!')
36435  5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i9,
36436  &' PYEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
36437 
36438  RETURN
36439  END
36440 
36441 C*********************************************************************
36442 
36443 C...PYALEM
36444 C...Calculates the running alpha_electromagnetic.
36445 
36446  FUNCTION pyalem(Q2)
36447 
36448 C...Double precision and integer declarations.
36449  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36450  INTEGER pyk,pychge,pycomp
36451 C...Commonblocks.
36452  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36453  SAVE /pydat1/
36454 
36455 C...Calculate real part of photon vacuum polarization.
36456 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
36457 C...For hadrons use parametrization of H. Burkhardt et al.
36458 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
36459  aempi=paru(101)/(3d0*paru(1))
36460  IF(mstu(101).LE.0.OR.q2.LT.2d-6) THEN
36461  rpigg=0d0
36462  ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
36463  rpigg=0d0
36464  ELSEIF(mstu(101).EQ.2) THEN
36465  rpigg=1d0-paru(101)/paru(103)
36466  ELSEIF(q2.LT.0.09d0) THEN
36467  rpigg=aempi*(13.4916d0+log(q2))+0.00835d0*log(1d0+q2)
36468  ELSEIF(q2.LT.9d0) THEN
36469  rpigg=aempi*(16.3200d0+2d0*log(q2))+
36470  & 0.00238d0*log(1d0+3.927d0*q2)
36471  ELSEIF(q2.LT.1d4) THEN
36472  rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00165d0+
36473  & 0.00299d0*log(1d0+q2)
36474  ELSE
36475  rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00221d0+
36476  & 0.00293d0*log(1d0+q2)
36477  ENDIF
36478 
36479 C...Calculate running alpha_em.
36480  pyalem=paru(101)/(1d0-rpigg)
36481  paru(108)=pyalem
36482 
36483  RETURN
36484  END
36485 
36486 C*********************************************************************
36487 
36488 C...PYALPS
36489 C...Gives the value of alpha_strong.
36490 
36491  FUNCTION pyalps(Q2)
36492 
36493 C...Double precision and integer declarations.
36494  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36495  INTEGER pyk,pychge,pycomp
36496 C...Commonblocks.
36497  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36498  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36499  SAVE /pydat1/,/pydat2/
36500 
36501 C...Constant alpha_strong trivial.
36502  IF(mstu(111).LE.0) THEN
36503  pyalps=paru(111)
36504  mstu(118)=mstu(112)
36505  paru(117)=0d0
36506  paru(118)=paru(111)
36507  RETURN
36508  ENDIF
36509 
36510 C...Find effective Q2, number of flavours and Lambda.
36511  q2eff=q2
36512  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
36513  nf=mstu(112)
36514  alam2=paru(112)**2
36515  100 IF(nf.GT.max(2,mstu(113))) THEN
36516  q2thr=paru(113)*pmas(nf,1)**2
36517  IF(q2eff.LT.q2thr) THEN
36518  nf=nf-1
36519  alam2=alam2*(q2thr/alam2)**(2d0/(33d0-2d0*nf))
36520  goto 100
36521  ENDIF
36522  ENDIF
36523  110 IF(nf.LT.min(8,mstu(114))) THEN
36524  q2thr=paru(113)*pmas(nf+1,1)**2
36525  IF(q2eff.GT.q2thr) THEN
36526  nf=nf+1
36527  alam2=alam2*(alam2/q2thr)**(2d0/(33d0-2d0*nf))
36528  goto 110
36529  ENDIF
36530  ENDIF
36531  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
36532  paru(117)=sqrt(alam2)
36533 
36534 C...Evaluate first or second order alpha_strong.
36535  b0=(33d0-2d0*nf)/6d0
36536  algq=log(max(1.0001d0,q2eff/alam2))
36537  IF(mstu(111).EQ.1) THEN
36538  pyalps=min(paru(115),paru(2)/(b0*algq))
36539  ELSE
36540  b1=(153d0-19d0*nf)/6d0
36541  pyalps=min(paru(115),paru(2)/(b0*algq)*(1d0-b1*log(algq)/
36542  & (b0**2*algq)))
36543  ENDIF
36544  mstu(118)=nf
36545  paru(118)=pyalps
36546 
36547  RETURN
36548  END
36549 
36550 C*********************************************************************
36551 
36552 C...PYANGL
36553 C...Reconstructs an angle from given x and y coordinates.
36554 
36555  FUNCTION pyangl(X,Y)
36556 
36557 C...Double precision and integer declarations.
36558  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36559  INTEGER pyk,pychge,pycomp
36560 C...Commonblocks.
36561  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36562  SAVE /pydat1/
36563 
36564  pyangl=0d0
36565  r=sqrt(x**2+y**2)
36566  IF(r.LT.1d-20) RETURN
36567  IF(abs(x)/r.LT.0.8d0) THEN
36568  pyangl=sign(acos(x/r),y)
36569  ELSE
36570  pyangl=asin(y/r)
36571  IF(x.LT.0d0.AND.pyangl.GE.0d0) THEN
36572  pyangl=paru(1)-pyangl
36573  ELSEIF(x.LT.0d0) THEN
36574  pyangl=-paru(1)-pyangl
36575  ENDIF
36576  ENDIF
36577 
36578  RETURN
36579  END
36580 
36581 C*********************************************************************
36582 
36583 C...PYR
36584 C...Generates random numbers uniformly distributed between
36585 C...0 and 1, excluding the endpoints.
36586 
36587  FUNCTION pyr(IDUMMY)
36588 
36589 C...Double precision and integer declarations.
36590  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36591  INTEGER pyk,pychge,pycomp
36592 C...Commonblocks.
36593  common/pydatr/mrpy(6),rrpy(100)
36594  SAVE /pydatr/
36595 C...Equivalence between commonblock and local variables.
36596  equivalence(mrpy1,mrpy(1)),(mrpy2,mrpy(2)),(mrpy3,mrpy(3)),
36597  &(mrpy4,mrpy(4)),(mrpy5,mrpy(5)),(mrpy6,mrpy(6)),
36598  &(rrpy98,rrpy(98)),(rrpy99,rrpy(99)),(rrpy00,rrpy(100))
36599 
36600 C...Initialize generation from given seed.
36601  IF(mrpy2.EQ.0) THEN
36602  ij=mod(mrpy1/30082,31329)
36603  kl=mod(mrpy1,30082)
36604  i=mod(ij/177,177)+2
36605  j=mod(ij,177)+2
36606  k=mod(kl/169,178)+1
36607  l=mod(kl,169)
36608  DO 110 ii=1,97
36609  s=0d0
36610  t=0.5d0
36611  DO 100 jj=1,48
36612  m=mod(mod(i*j,179)*k,179)
36613  i=j
36614  j=k
36615  k=m
36616  l=mod(53*l+1,169)
36617  IF(mod(l*m,64).GE.32) s=s+t
36618  t=0.5d0*t
36619  100 CONTINUE
36620  rrpy(ii)=s
36621  110 CONTINUE
36622  twom24=1d0
36623  DO 120 i24=1,24
36624  twom24=0.5d0*twom24
36625  120 CONTINUE
36626  rrpy98=362436d0*twom24
36627  rrpy99=7654321d0*twom24
36628  rrpy00=16777213d0*twom24
36629  mrpy2=1
36630  mrpy3=0
36631  mrpy4=97
36632  mrpy5=33
36633  ENDIF
36634 
36635 C...Generate next random number.
36636  130 runi=rrpy(mrpy4)-rrpy(mrpy5)
36637  IF(runi.LT.0d0) runi=runi+1d0
36638  rrpy(mrpy4)=runi
36639  mrpy4=mrpy4-1
36640  IF(mrpy4.EQ.0) mrpy4=97
36641  mrpy5=mrpy5-1
36642  IF(mrpy5.EQ.0) mrpy5=97
36643  rrpy98=rrpy98-rrpy99
36644  IF(rrpy98.LT.0d0) rrpy98=rrpy98+rrpy00
36645  runi=runi-rrpy98
36646  IF(runi.LT.0d0) runi=runi+1d0
36647  IF(runi.LE.0d0.OR.runi.GE.1d0) goto 130
36648 
36649 C...Update counters. Random number to output.
36650  mrpy3=mrpy3+1
36651  IF(mrpy3.EQ.1000000000) THEN
36652  mrpy2=mrpy2+1
36653  mrpy3=0
36654  ENDIF
36655  pyr=runi
36656 
36657  RETURN
36658  END
36659 
36660 C*********************************************************************
36661 
36662 C...PYRGET
36663 C...Dumps the state of the random number generator on a file
36664 C...for subsequent startup from this state onwards.
36665 
36666  SUBROUTINE pyrget(LFN,MOVE)
36667 
36668 C...Double precision and integer declarations.
36669  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36670  INTEGER pyk,pychge,pycomp
36671 C...Commonblocks.
36672  common/pydatr/mrpy(6),rrpy(100)
36673  SAVE /pydatr/
36674 C...Local character variable.
36675  CHARACTER cherr*8
36676 
36677 C...Backspace required number of records (or as many as there are).
36678  IF(move.LT.0) THEN
36679  nbck=min(mrpy(6),-move)
36680  DO 100 ibck=1,nbck
36681  backspace(lfn,err=110,iostat=ierr)
36682  100 CONTINUE
36683  mrpy(6)=mrpy(6)-nbck
36684  ENDIF
36685 
36686 C...Unformatted write on unit LFN.
36687  WRITE(lfn,err=110,iostat=ierr) (mrpy(i1),i1=1,5),
36688  &(rrpy(i2),i2=1,100)
36689  mrpy(6)=mrpy(6)+1
36690  RETURN
36691 
36692 C...Write error.
36693  110 WRITE(cherr,'(I8)') ierr
36694  CALL pyerrm(18,'(PYRGET:) error when accessing file, IOSTAT ='//
36695  &cherr)
36696 
36697  RETURN
36698  END
36699 
36700 C*********************************************************************
36701 
36702 C...PYRSET
36703 C...Reads a state of the random number generator from a file
36704 C...for subsequent generation from this state onwards.
36705 
36706  SUBROUTINE pyrset(LFN,MOVE)
36707 
36708 C...Double precision and integer declarations.
36709  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36710  INTEGER pyk,pychge,pycomp
36711 C...Commonblocks.
36712  common/pydatr/mrpy(6),rrpy(100)
36713  SAVE /pydatr/
36714 C...Local character variable.
36715  CHARACTER cherr*8
36716 
36717 C...Backspace required number of records (or as many as there are).
36718  IF(move.LT.0) THEN
36719  nbck=min(mrpy(6),-move)
36720  DO 100 ibck=1,nbck
36721  backspace(lfn,err=120,iostat=ierr)
36722  100 CONTINUE
36723  mrpy(6)=mrpy(6)-nbck
36724  ENDIF
36725 
36726 C...Unformatted read from unit LFN.
36727  nfor=1+max(0,move)
36728  DO 110 ifor=1,nfor
36729  READ(lfn,err=120,iostat=ierr) (mrpy(i1),i1=1,5),
36730  & (rrpy(i2),i2=1,100)
36731  110 CONTINUE
36732  mrpy(6)=mrpy(6)+nfor
36733  RETURN
36734 
36735 C...Write error.
36736  120 WRITE(cherr,'(I8)') ierr
36737  CALL pyerrm(18,'(PYRSET:) error when accessing file, IOSTAT ='//
36738  &cherr)
36739 
36740  RETURN
36741  END
36742 
36743 C*********************************************************************
36744 
36745 C...PYROBO
36746 C...Performs rotations and boosts.
36747 
36748  SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
36749 
36750 C...Double precision and integer declarations.
36751  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36752  INTEGER pyk,pychge,pycomp
36753 C...Commonblocks.
36754  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
36755  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36756  SAVE /pyjets/,/pydat1/
36757 C...Local arrays.
36758  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
36759 
36760 C...Find and check range of rotation/boost.
36761  imin=imi
36762  IF(imin.LE.0) imin=1
36763  IF(mstu(1).GT.0) imin=mstu(1)
36764  imax=ima
36765  IF(imax.LE.0) imax=n
36766  IF(mstu(2).GT.0) imax=mstu(2)
36767  IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
36768  CALL pyerrm(11,'(PYROBO:) range outside PYJETS memory')
36769  RETURN
36770  ENDIF
36771 
36772 C...Optional resetting of V (when not set before.)
36773  IF(mstu(33).NE.0) THEN
36774  DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
36775  DO 100 j=1,5
36776  v(i,j)=0d0
36777  100 CONTINUE
36778  110 CONTINUE
36779  mstu(33)=0
36780  ENDIF
36781 
36782 C...Rotate, typically from z axis to direction (theta,phi).
36783  IF(the**2+phi**2.GT.1d-20) THEN
36784  rot(1,1)=cos(the)*cos(phi)
36785  rot(1,2)=-sin(phi)
36786  rot(1,3)=sin(the)*cos(phi)
36787  rot(2,1)=cos(the)*sin(phi)
36788  rot(2,2)=cos(phi)
36789  rot(2,3)=sin(the)*sin(phi)
36790  rot(3,1)=-sin(the)
36791  rot(3,2)=0d0
36792  rot(3,3)=cos(the)
36793  DO 140 i=imin,imax
36794  IF(k(i,1).LE.0) goto 140
36795  DO 120 j=1,3
36796  pr(j)=p(i,j)
36797  vr(j)=v(i,j)
36798  120 CONTINUE
36799  DO 130 j=1,3
36800  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
36801  v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
36802  130 CONTINUE
36803  140 CONTINUE
36804  ENDIF
36805 
36806 C...Boost, typically from rest to momentum/energy=beta.
36807  IF(bex**2+bey**2+bez**2.GT.1d-20) THEN
36808  dbx=bex
36809  dby=bey
36810  dbz=bez
36811  db=sqrt(dbx**2+dby**2+dbz**2)
36812  eps1=1d0-1d-12
36813  IF(db.GT.eps1) THEN
36814 C...Rescale boost vector if too close to unity.
36815  CALL pyerrm(3,'(PYROBO:) boost vector too large')
36816  dbx=dbx*(eps1/db)
36817  dby=dby*(eps1/db)
36818  dbz=dbz*(eps1/db)
36819  db=eps1
36820  ENDIF
36821  dga=1d0/sqrt(1d0-db**2)
36822  DO 160 i=imin,imax
36823  IF(k(i,1).LE.0) goto 160
36824  DO 150 j=1,4
36825  dp(j)=p(i,j)
36826  dv(j)=v(i,j)
36827  150 CONTINUE
36828  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
36829  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
36830  p(i,1)=dp(1)+dgabp*dbx
36831  p(i,2)=dp(2)+dgabp*dby
36832  p(i,3)=dp(3)+dgabp*dbz
36833  p(i,4)=dga*(dp(4)+dbp)
36834  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
36835  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
36836  v(i,1)=dv(1)+dgabv*dbx
36837  v(i,2)=dv(2)+dgabv*dby
36838  v(i,3)=dv(3)+dgabv*dbz
36839  v(i,4)=dga*(dv(4)+dbv)
36840  160 CONTINUE
36841  ENDIF
36842 
36843  RETURN
36844  END
36845 
36846 C*********************************************************************
36847 
36848 C...PYEDIT
36849 C...Performs global manipulations on the event record, in particular
36850 C...to exclude unstable or undetectable partons/particles.
36851 
36852  SUBROUTINE pyedit(MEDIT)
36853 
36854 C...Double precision and integer declarations.
36855  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36856  INTEGER pyk,pychge,pycomp
36857 C...Commonblocks.
36858  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
36859  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36860  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36861  SAVE /pyjets/,/pydat1/,/pydat2/
36862 C...Local arrays.
36863  dimension ns(2),pts(2),pls(2)
36864 
36865 C...Remove unwanted partons/particles.
36866  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
36867  imax=n
36868  IF(mstu(2).GT.0) imax=mstu(2)
36869  i1=max(1,mstu(1))-1
36870  DO 110 i=max(1,mstu(1)),imax
36871  IF(k(i,1).EQ.0.OR.k(i,1).GT.20) goto 110
36872  IF(medit.EQ.1) THEN
36873  IF(k(i,1).GT.10) goto 110
36874  ELSEIF(medit.EQ.2) THEN
36875  IF(k(i,1).GT.10) goto 110
36876  kc=pycomp(k(i,2))
36877  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
36878  & goto 110
36879  ELSEIF(medit.EQ.3) THEN
36880  IF(k(i,1).GT.10) goto 110
36881  kc=pycomp(k(i,2))
36882  IF(kc.EQ.0) goto 110
36883  IF(kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0) goto 110
36884  ELSEIF(medit.EQ.5) THEN
36885  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) goto 110
36886  kc=pycomp(k(i,2))
36887  IF(kc.EQ.0) goto 110
36888  IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) goto 110
36889  ENDIF
36890 
36891 C...Pack remaining partons/particles. Origin no longer known.
36892  i1=i1+1
36893  DO 100 j=1,5
36894  k(i1,j)=k(i,j)
36895  p(i1,j)=p(i,j)
36896  v(i1,j)=v(i,j)
36897  100 CONTINUE
36898  k(i1,3)=0
36899  110 CONTINUE
36900  IF(i1.LT.n) mstu(3)=0
36901  IF(i1.LT.n) mstu(70)=0
36902  n=i1
36903 
36904 C...Selective removal of class of entries. New position of retained.
36905  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
36906  i1=0
36907  DO 120 i=1,n
36908  k(i,3)=mod(k(i,3),mstu(5))
36909  IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120
36910  IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120
36911  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
36912  & k(i,1).EQ.15).AND.k(i,2).NE.94) goto 120
36913  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
36914  & k(i,2).EQ.94)) goto 120
36915  IF(medit.EQ.15.AND.k(i,1).GE.21) goto 120
36916  i1=i1+1
36917  k(i,3)=k(i,3)+mstu(5)*i1
36918  120 CONTINUE
36919 
36920 C...Find new event history information and replace old.
36921  DO 140 i=1,n
36922  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0)
36923  & goto 140
36924  id=i
36925  130 im=mod(k(id,3),mstu(5))
36926  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
36927  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
36928  & k(im,2).NE.94) THEN
36929  id=im
36930  goto 130
36931  ENDIF
36932  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
36933  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
36934  id=im
36935  goto 130
36936  ENDIF
36937  ENDIF
36938  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
36939  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
36940  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
36941  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
36942  & k(k(i,4),3)/mstu(5)
36943  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
36944  & k(k(i,5),3)/mstu(5)
36945  ELSE
36946  kcm=mod(k(i,4)/mstu(5),mstu(5))
36947  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
36948  kcd=mod(k(i,4),mstu(5))
36949  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
36950  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
36951  kcm=mod(k(i,5)/mstu(5),mstu(5))
36952  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
36953  kcd=mod(k(i,5),mstu(5))
36954  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
36955  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
36956  ENDIF
36957  140 CONTINUE
36958 
36959 C...Pack remaining entries.
36960  i1=0
36961  mstu90=mstu(90)
36962  mstu(90)=0
36963  DO 170 i=1,n
36964  IF(k(i,3)/mstu(5).EQ.0) goto 170
36965  i1=i1+1
36966  DO 150 j=1,5
36967  k(i1,j)=k(i,j)
36968  p(i1,j)=p(i,j)
36969  v(i1,j)=v(i,j)
36970  150 CONTINUE
36971  k(i1,3)=mod(k(i1,3),mstu(5))
36972  DO 160 iz=1,mstu90
36973  IF(i.EQ.mstu(90+iz)) THEN
36974  mstu(90)=mstu(90)+1
36975  mstu(90+mstu(90))=i1
36976  paru(90+mstu(90))=paru(90+iz)
36977  ENDIF
36978  160 CONTINUE
36979  170 CONTINUE
36980  IF(i1.LT.n) mstu(3)=0
36981  IF(i1.LT.n) mstu(70)=0
36982  n=i1
36983 
36984 C...Fill in some missing daughter pointers (lost in colour flow).
36985  ELSEIF(medit.EQ.16) THEN
36986  DO 220 i=1,n
36987  IF(k(i,1).LE.10.OR.k(i,1).GT.20) goto 220
36988  IF(k(i,4).NE.0.OR.k(i,5).NE.0) goto 220
36989 C...Find daughters who point to mother.
36990  DO 180 i1=i+1,n
36991  IF(k(i1,3).NE.i) THEN
36992  ELSEIF(k(i,4).EQ.0) THEN
36993  k(i,4)=i1
36994  ELSE
36995  k(i,5)=i1
36996  ENDIF
36997  180 CONTINUE
36998  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
36999  IF(k(i,4).NE.0) goto 220
37000 C...Find daughters who point to documentation version of mother.
37001  im=k(i,3)
37002  IF(im.LE.0.OR.im.GE.i) goto 220
37003  IF(k(im,1).LE.20.OR.k(im,1).GT.30) goto 220
37004  IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1d-2) goto 220
37005  DO 190 i1=i+1,n
37006  IF(k(i1,3).NE.im) THEN
37007  ELSEIF(k(i,4).EQ.0) THEN
37008  k(i,4)=i1
37009  ELSE
37010  k(i,5)=i1
37011  ENDIF
37012  190 CONTINUE
37013  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
37014  IF(k(i,4).NE.0) goto 220
37015 C...Find daughters who point to documentation daughters who,
37016 C...in their turn, point to documentation mother.
37017  id1=im
37018  id2=im
37019  DO 200 i1=im+1,i-1
37020  IF(k(i1,3).EQ.im.AND.k(i1,1).GT.20.AND.k(i1,1).LE.30) THEN
37021  id2=i1
37022  IF(id1.EQ.im) id1=i1
37023  ENDIF
37024  200 CONTINUE
37025  DO 210 i1=i+1,n
37026  IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
37027  ELSEIF(k(i,4).EQ.0) THEN
37028  k(i,4)=i1
37029  ELSE
37030  k(i,5)=i1
37031  ENDIF
37032  210 CONTINUE
37033  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
37034  220 CONTINUE
37035 
37036 C...Save top entries at bottom of PYJETS commonblock.
37037  ELSEIF(medit.EQ.21) THEN
37038  IF(2*n.GE.mstu(4)) THEN
37039  CALL pyerrm(11,'(PYEDIT:) no more memory left in PYJETS')
37040  RETURN
37041  ENDIF
37042  DO 240 i=1,n
37043  DO 230 j=1,5
37044  k(mstu(4)-i,j)=k(i,j)
37045  p(mstu(4)-i,j)=p(i,j)
37046  v(mstu(4)-i,j)=v(i,j)
37047  230 CONTINUE
37048  240 CONTINUE
37049  mstu(32)=n
37050 
37051 C...Restore bottom entries of commonblock PYJETS to top.
37052  ELSEIF(medit.EQ.22) THEN
37053  DO 260 i=1,mstu(32)
37054  DO 250 j=1,5
37055  k(i,j)=k(mstu(4)-i,j)
37056  p(i,j)=p(mstu(4)-i,j)
37057  v(i,j)=v(mstu(4)-i,j)
37058  250 CONTINUE
37059  260 CONTINUE
37060  n=mstu(32)
37061 
37062 C...Mark primary entries at top of commonblock PYJETS as untreated.
37063  ELSEIF(medit.EQ.23) THEN
37064  i1=0
37065  DO 270 i=1,n
37066  kh=k(i,3)
37067  IF(kh.GE.1) THEN
37068  IF(k(kh,1).GT.20) kh=0
37069  ENDIF
37070  IF(kh.NE.0) goto 280
37071  i1=i1+1
37072  IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
37073  270 CONTINUE
37074  280 n=i1
37075 
37076 C...Place largest axis along z axis and second largest in xy plane.
37077  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
37078  CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61),1),
37079  & p(mstu(61),2)),0d0,0d0,0d0)
37080  CALL pyrobo(1,n+mstu(3),-pyangl(p(mstu(61),3),
37081  & p(mstu(61),1)),0d0,0d0,0d0,0d0)
37082  CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61)+1,1),
37083  & p(mstu(61)+1,2)),0d0,0d0,0d0)
37084  IF(medit.EQ.31) RETURN
37085 
37086 C...Rotate to put slim jet along +z axis.
37087  DO 290 is=1,2
37088  ns(is)=0
37089  pts(is)=0d0
37090  pls(is)=0d0
37091  290 CONTINUE
37092  DO 300 i=1,n
37093  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 300
37094  IF(mstu(41).GE.2) THEN
37095  kc=pycomp(k(i,2))
37096  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
37097  & kc.EQ.18) goto 300
37098  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
37099  & .EQ.0) goto 300
37100  ENDIF
37101  is=2d0-sign(0.5d0,p(i,3))
37102  ns(is)=ns(is)+1
37103  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
37104  300 CONTINUE
37105  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
37106  & CALL pyrobo(1,n+mstu(3),paru(1),0d0,0d0,0d0,0d0)
37107 
37108 C...Rotate to put second largest jet into -z,+x quadrant.
37109  DO 310 i=1,n
37110  IF(p(i,3).GE.0d0) goto 310
37111  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 310
37112  IF(mstu(41).GE.2) THEN
37113  kc=pycomp(k(i,2))
37114  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
37115  & kc.EQ.18) goto 310
37116  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
37117  & .EQ.0) goto 310
37118  ENDIF
37119  is=2d0-sign(0.5d0,p(i,1))
37120  pls(is)=pls(is)-p(i,3)
37121  310 CONTINUE
37122  IF(pls(2).GT.pls(1)) CALL pyrobo(1,n+mstu(3),0d0,paru(1),
37123  & 0d0,0d0,0d0)
37124  ENDIF
37125 
37126  RETURN
37127  END
37128 
37129 C*********************************************************************
37130 
37131 C...PYLIST
37132 C...Gives program heading, or lists an event, or particle
37133 C...data, or current parameter values.
37134 
37135  SUBROUTINE pylist(MLIST)
37136 
37137 C...Double precision and integer declarations.
37138  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37139  INTEGER pyk,pychge,pycomp
37140 C...Parameter statement to help give large particle numbers.
37141  parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)
37142 C...Commonblocks.
37143  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37144  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37145  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37146  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
37147  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
37148 C...Local arrays, character variables and data.
37149  CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chdl(7)*4
37150  dimension ps(6)
37151  DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
37152 
37153 C...Initialization printout: version number and date of last change.
37154  IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
37155  CALL pylogo
37156  mstu(12)=0
37157  IF(mlist.EQ.0) RETURN
37158  ENDIF
37159 
37160 C...List event data, including additional lines after N.
37161  IF(mlist.GE.1.AND.mlist.LE.3) THEN
37162  IF(mlist.EQ.1) WRITE(mstu(11),5100)
37163  IF(mlist.EQ.2) WRITE(mstu(11),5200)
37164  IF(mlist.EQ.3) WRITE(mstu(11),5300)
37165  lmx=12
37166  IF(mlist.GE.2) lmx=16
37167  istr=0
37168  imax=n
37169  IF(mstu(2).GT.0) imax=mstu(2)
37170  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
37171  IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) goto 120
37172 
37173 C...Get particle name, pad it and check it is not too long.
37174  CALL pyname(k(i,2),chap)
37175  len=0
37176  DO 100 lem=1,16
37177  IF(chap(lem:lem).NE.' ') len=lem
37178  100 CONTINUE
37179  mdl=(k(i,1)+19)/10
37180  ldl=0
37181  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
37182  chac=chap
37183  IF(len.GT.lmx) chac(lmx:lmx)='?'
37184  ELSE
37185  ldl=1
37186  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
37187  IF(len.EQ.0) THEN
37188  chac=chdl(mdl)(1:2*ldl)//' '
37189  ELSE
37190  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
37191  & chdl(mdl)(ldl+1:2*ldl)//' '
37192  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
37193  ENDIF
37194  ENDIF
37195 
37196 C...Add information on string connection.
37197  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
37198  & THEN
37199  kc=pycomp(k(i,2))
37200  kcc=0
37201  IF(kc.NE.0) kcc=kchg(kc,2)
37202  IF(iabs(k(i,2)).EQ.39) THEN
37203  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
37204  ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
37205  istr=1
37206  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
37207  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
37208  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
37209  ELSEIF(kcc.NE.0) THEN
37210  istr=0
37211  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
37212  ENDIF
37213  ENDIF
37214 
37215 C...Write data for particle/jet.
37216  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999d0) THEN
37217  WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),
37218  & (p(i,j2),j2=1,5)
37219  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999d0) THEN
37220  WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
37221  & (p(i,j2),j2=1,5)
37222  ELSEIF(mlist.EQ.1) THEN
37223  WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
37224  & (p(i,j2),j2=1,5)
37225  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
37226  & k(i,1).EQ.14)) THEN
37227  WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),
37228  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
37229  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
37230  & (p(i,j2),j2=1,5)
37231  ELSE
37232  WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),
37233  & (p(i,j2),j2=1,5)
37234  ENDIF
37235  IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)
37236 
37237 C...Insert extra separator lines specified by user.
37238  IF(mstu(70).GE.1) THEN
37239  isep=0
37240  DO 110 j=1,min(10,mstu(70))
37241  IF(i.EQ.mstu(70+j)) isep=1
37242  110 CONTINUE
37243  IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)
37244  IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)
37245  ENDIF
37246  120 CONTINUE
37247 
37248 C...Sum of charges and momenta.
37249  DO 130 j=1,6
37250  ps(j)=pyp(0,j)
37251  130 CONTINUE
37252  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999d0) THEN
37253  WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)
37254  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999d0) THEN
37255  WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)
37256  ELSEIF(mlist.EQ.1) THEN
37257  WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)
37258  ELSE
37259  WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)
37260  ENDIF
37261 
37262 C...Give simple list of KF codes defined in program.
37263  ELSEIF(mlist.EQ.11) THEN
37264  WRITE(mstu(11),6600)
37265  DO 140 kf=1,80
37266  CALL pyname(kf,chap)
37267  CALL pyname(-kf,chan)
37268  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
37269  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
37270  140 CONTINUE
37271  DO 170 kfls=1,3,2
37272  DO 160 kfla=1,5
37273  DO 150 kflb=1,kfla-(3-kfls)/2
37274  kf=1000*kfla+100*kflb+kfls
37275  CALL pyname(kf,chap)
37276  CALL pyname(-kf,chan)
37277  WRITE(mstu(11),6700) kf,chap,-kf,chan
37278  150 CONTINUE
37279  160 CONTINUE
37280  170 CONTINUE
37281  kf=130
37282  CALL pyname(kf,chap)
37283  WRITE(mstu(11),6700) kf,chap
37284  kf=310
37285  CALL pyname(kf,chap)
37286  WRITE(mstu(11),6700) kf,chap
37287  DO 200 kmul=0,5
37288  kfls=3
37289  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
37290  IF(kmul.EQ.5) kfls=5
37291  kflr=0
37292  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
37293  IF(kmul.EQ.4) kflr=2
37294  DO 190 kflb=1,5
37295  DO 180 kflc=1,kflb-1
37296  kf=10000*kflr+100*kflb+10*kflc+kfls
37297  CALL pyname(kf,chap)
37298  CALL pyname(-kf,chan)
37299  WRITE(mstu(11),6700) kf,chap,-kf,chan
37300  180 CONTINUE
37301  kf=10000*kflr+110*kflb+kfls
37302  CALL pyname(kf,chap)
37303  WRITE(mstu(11),6700) kf,chap
37304  190 CONTINUE
37305  200 CONTINUE
37306  kf=100443
37307  CALL pyname(kf,chap)
37308  WRITE(mstu(11),6700) kf,chap
37309  kf=100553
37310  CALL pyname(kf,chap)
37311  WRITE(mstu(11),6700) kf,chap
37312  DO 240 kflsp=1,3
37313  kfls=2+2*(kflsp/3)
37314  DO 230 kfla=1,5
37315  DO 220 kflb=1,kfla
37316  DO 210 kflc=1,kflb
37317  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc))
37318  & goto 210
37319  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 210
37320  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
37321  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
37322  CALL pyname(kf,chap)
37323  CALL pyname(-kf,chan)
37324  WRITE(mstu(11),6700) kf,chap,-kf,chan
37325  210 CONTINUE
37326  220 CONTINUE
37327  230 CONTINUE
37328  240 CONTINUE
37329  DO 250 kf=ksusy1+1,ksusy1+40
37330  CALL pyname(kf,chap)
37331  CALL pyname(-kf,chan)
37332  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
37333  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
37334  250 CONTINUE
37335  DO 260 kf=ksusy2+1,ksusy2+40
37336  CALL pyname(kf,chap)
37337  CALL pyname(-kf,chan)
37338  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
37339  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
37340  260 CONTINUE
37341  DO 270 kf=kexcit+1,kexcit+40
37342  CALL pyname(kf,chap)
37343  CALL pyname(-kf,chan)
37344  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
37345  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
37346  270 CONTINUE
37347 
37348 C...List parton/particle data table. Check whether to be listed.
37349  ELSEIF(mlist.EQ.12) THEN
37350  WRITE(mstu(11),6800)
37351  DO 300 kc=1,mstu(6)
37352  kf=kchg(kc,4)
37353  IF(kf.EQ.0) goto 300
37354  IF(kf.LT.mstu(1).OR.(mstu(2).GT.0.AND.kf.GT.mstu(2)))
37355  & goto 300
37356 
37357 C...Find particle name and mass. Print information.
37358  CALL pyname(kf,chap)
37359  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 300
37360  CALL pyname(-kf,chan)
37361  WRITE(mstu(11),6900) kf,kc,chap,chan,(kchg(kc,j1),j1=1,3),
37362  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
37363 
37364 C...Particle decay: channel number, branching ratios, matrix element,
37365 C...decay products.
37366  DO 290 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
37367  DO 280 j=1,5
37368  CALL pyname(kfdp(idc,j),chad(j))
37369  280 CONTINUE
37370  WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
37371  & (chad(j),j=1,5)
37372  290 CONTINUE
37373  300 CONTINUE
37374 
37375 C...List parameter value table.
37376  ELSEIF(mlist.EQ.13) THEN
37377  WRITE(mstu(11),7100)
37378  DO 310 i=1,200
37379  WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
37380  310 CONTINUE
37381  ENDIF
37382 
37383 C...Format statements for output on unit MSTU(11) (by default 6).
37384  5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
37385  &5x,'KF orig p_x p_y p_z E m'/)
37386  5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
37387  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
37388  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
37389  5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
37390  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
37391  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
37392  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
37393  5400 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.3)
37394  5500 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.2)
37395  5600 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.1)
37396  5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),5f13.5)
37397  5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),5f13.5)
37398  5900 FORMAT(66x,5(1x,f12.3))
37399  6000 FORMAT(1x,78('='))
37400  6100 FORMAT(1x,130('='))
37401  6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
37402  6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
37403  6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
37404  6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
37405  &5f13.5)
37406  6600 FORMAT(///20x,'List of KF codes in program'/)
37407  6700 FORMAT(4x,i9,4x,a16,6x,i9,4x,a16)
37408  6800 FORMAT(///30x,'Particle/parton data table'//8x,'KF',5x,'KC',4x,
37409  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
37410  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
37411  &1x,'ME',3x,'Br.rat.',4x,'decay products')
37412  6900 FORMAT(/1x,i9,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
37413  &1x,1p,e13.5,3x,i2)
37414  7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f10.6,4x,5a16)
37415  7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
37416  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
37417  7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
37418 
37419  RETURN
37420  END
37421 
37422 C*********************************************************************
37423 
37424 C...PYLOGO
37425 C...Writes a logo for the program.
37426 
37427  SUBROUTINE pylogo
37428 
37429 C...Double precision and integer declarations.
37430  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37431  INTEGER pyk,pychge,pycomp
37432 C...Parameter for length of information block.
37433  parameter(irefer=17)
37434 C...Commonblocks.
37435  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37436  common/pypars/mstp(200),parp(200),msti(200),pari(200)
37437  SAVE /pydat1/,/pypars/
37438 C...Local arrays and character variables.
37439  INTEGER idati(6)
37440  CHARACTER month(12)*3, logo(48)*32, refer(2*irefer)*36, line*79,
37441  &vers*1, subv*3, date*2, year*4, hour*2, minu*2, seco*2
37442 
37443 C...Data on months, logo, titles, and references.
37444  DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
37445  &'Oct','Nov','Dec'/
37446  DATA (logo(j),j=1,19)/
37447  &' *......* ',
37448  &' *:::!!:::::::::::* ',
37449  &' *::::::!!::::::::::::::* ',
37450  &' *::::::::!!::::::::::::::::* ',
37451  &' *:::::::::!!:::::::::::::::::* ',
37452  &' *:::::::::!!:::::::::::::::::* ',
37453  &' *::::::::!!::::::::::::::::*! ',
37454  &' *::::::!!::::::::::::::* !! ',
37455  &' !! *:::!!:::::::::::* !! ',
37456  &' !! !* -><- * !! ',
37457  &' !! !! !! ',
37458  &' !! !! !! ',
37459  &' !! !! ',
37460  &' !! ep !! ',
37461  &' !! !! ',
37462  &' !! pp !! ',
37463  &' !! e+e- !! ',
37464  &' !! !! ',
37465  &' !! '/
37466  DATA (logo(j),j=20,38)/
37467  &'Welcome to the Lund Monte Carlo!',
37468  &' ',
37469  &'PPP Y Y TTTTT H H III A ',
37470  &'P P Y Y T H H I A A ',
37471  &'PPP Y T HHHHH I AAAAA',
37472  &'P Y T H H I A A',
37473  &'P Y T H H III A A',
37474  &' ',
37475  &'This is PYTHIA version x.xxx ',
37476  &'Last date of change: xx xxx 199x',
37477  &' ',
37478  &'Now is xx xxx 199x at xx:xx:xx ',
37479  &' ',
37480  &'Disclaimer: this program comes ',
37481  &'without any guarantees. Beware ',
37482  &'of errors and use common sense ',
37483  &'when interpreting results. ',
37484  &' ',
37485  &'Copyright T. Sjostrand (1997) '/
37486  DATA (refer(j),j=1,18)/
37487  &'An archive of program versions and d',
37488  &'ocumentation is found on the web: ',
37489  &'http://thep.lu.se/tf2/staff/torbjorn',
37490  &'/Pythia.html ',
37491  &' ',
37492  &' ',
37493  &'When you cite this program, currentl',
37494  &'y the official reference is ',
37495  &'T. Sjostrand, Computer Physics Commu',
37496  &'n. 82 (1994) 74. ',
37497  &'The supersymmetry extensions are des',
37498  &'cribed in ',
37499  &'S. Mrenna, ANL-HEP-PR-96-63. ',
37500  &' ',
37501  &'Also remember that the program, to a',
37502  &' large extent, represents original ',
37503  &'physics research. Other publications',
37504  &' of special relevance to your '/
37505  DATA (refer(j),j=19,2*irefer)/
37506  &'studies may therefore deserve separa',
37507  &'te mention. ',
37508  &' ',
37509  &' ',
37510  &'Main author: Torbjorn Sjostrand; Dep',
37511  &'artment of Theoretical Physics 2, ',
37512  &' Lund University, Solvegatan 14A, S',
37513  &'-223 62 Lund, Sweden; ',
37514  &' phone: + 46 - 46 - 222 48 16; e-ma',
37515  &'il: torbjorn@thep.lu.se ',
37516  &'SUSY author: Stephen Mrenna, Argonne',
37517  &' National Laboratory, ',
37518  &' 9700 South Cass Avenue, Argonne, I',
37519  &'L 60439, USA; ',
37520  &' phone: + 1 - 630 - 252 - 7615; e-m',
37521  &'ail: mrenna@hep.anl.gov '/
37522 
37523 C...Check that PYDATA linked.
37524  IF(mstp(183)/10.NE.199) THEN
37525  WRITE(mstu(11),'(1X,A)')
37526  & 'Error: PYDATA has not been linked.'
37527  WRITE(mstu(11),'(1X,A)') 'Execution stopped!'
37528  stop
37529 
37530 C...Write current version number and current date+time.
37531  ELSE
37532  WRITE(vers,'(I1)') mstp(181)
37533  logo(28)(24:24)=vers
37534  WRITE(subv,'(I3)') mstp(182)
37535  logo(28)(26:28)=subv
37536  IF(mstp(182).LT.100) logo(28)(26:26)='0'
37537  WRITE(date,'(I2)') mstp(185)
37538  logo(29)(22:23)=date
37539  logo(29)(25:27)=month(mstp(184))
37540  WRITE(year,'(I4)') mstp(183)
37541  logo(29)(29:32)=year
37542  CALL pytime(idati)
37543  IF(idati(1).LE.0) THEN
37544  logo(31)=' '
37545  ELSE
37546  WRITE(date,'(I2)') idati(3)
37547  logo(31)(8:9)=date
37548  logo(31)(11:13)=month(max(1,min(12,idati(2))))
37549  WRITE(year,'(I4)') idati(1)
37550  logo(31)(15:18)=year
37551  WRITE(hour,'(I2)') idati(4)
37552  logo(31)(23:24)=hour
37553  WRITE(minu,'(I2)') idati(5)
37554  logo(31)(26:27)=minu
37555  IF(idati(5).LT.10) logo(31)(26:26)='0'
37556  WRITE(seco,'(I2)') idati(6)
37557  logo(31)(29:30)=seco
37558  IF(idati(6).LT.10) logo(31)(29:29)='0'
37559  ENDIF
37560  ENDIF
37561 
37562 C...Loop over lines in header. Define page feed and side borders.
37563  DO 100 ilin=1,29+irefer
37564  line=' '
37565  IF(ilin.EQ.1) THEN
37566  line(1:1)='1'
37567  ELSE
37568  line(2:3)='**'
37569  line(78:79)='**'
37570  ENDIF
37571 
37572 C...Separator lines and logos.
37573  IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.GE.28+irefer) THEN
37574  line(4:77)='***********************************************'//
37575  & '***************************'
37576  ELSEIF(ilin.GE.6.AND.ilin.LE.24) THEN
37577  line(6:37)=logo(ilin-5)
37578  line(44:75)=logo(ilin+14)
37579  ELSEIF(ilin.GE.26.AND.ilin.LE.25+irefer) THEN
37580  line(5:40)=refer(2*ilin-51)
37581  line(41:76)=refer(2*ilin-50)
37582  ENDIF
37583 
37584 C...Write lines to appropriate unit.
37585  IF(mstu(183)/10.EQ.199) THEN
37586  WRITE(mstu(11),'(A79)') line
37587  ELSE
37588  WRITE(*,'(A79)') line
37589  ENDIF
37590  100 CONTINUE
37591 
37592  RETURN
37593  END
37594 
37595 C*********************************************************************
37596 
37597 C...PYUPDA
37598 C...Facilitates the updating of particle and decay data
37599 C...by allowing it to be done in an external file.
37600 
37601  SUBROUTINE pyupda(MUPDA,LFN)
37602 
37603 C...Double precision and integer declarations.
37604  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37605  INTEGER pyk,pychge,pycomp
37606 C...Commonblocks.
37607  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37608  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37609  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
37610  common/pydat4/chaf(500,2)
37611  CHARACTER chaf*16
37612  common/pyint4/mwid(500),wids(500,5)
37613  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pyint4/
37614 C...Local arrays, character variables and data.
37615  CHARACTER chinl*120,chkf*9,chvar(22)*9,chlin*72,
37616  &chblk(20)*72,chold*16,chtmp*16,chnew*16,chcom*24
37617  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
37618  &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
37619  &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
37620  &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
37621  &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
37622 
37623 C...Write header if not yet done.
37624  IF(mstu(12).GE.1) CALL pylist(0)
37625 
37626 C...Write information on file for editing.
37627  IF(mupda.EQ.1) THEN
37628  DO 110 kc=1,500
37629  WRITE(lfn,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
37630  & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
37631  & mwid(kc),mdcy(kc,1)
37632  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
37633  WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
37634  & (kfdp(idc,j),j=1,5)
37635  100 CONTINUE
37636  110 CONTINUE
37637 
37638 C...Read complete set of information from edited file or
37639 C...read partial set of new or updated information from edited file.
37640  ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN
37641 
37642 C...Reset counters.
37643  kcc=100
37644  ndc=0
37645  chkf=' '
37646  IF(mupda.EQ.2) THEN
37647  DO 120 i=1,mstu(6)
37648  kchg(i,4)=0
37649  120 CONTINUE
37650  ELSE
37651  DO 130 kc=1,mstu(6)
37652  IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
37653  ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
37654  130 CONTINUE
37655  ENDIF
37656 
37657 C...Begin of loop: read new line; unknown whether particle or
37658 C...decay data.
37659  140 READ(lfn,5200,end=190) chinl
37660 
37661 C...Identify particle code and whether already defined (for MUPDA=3).
37662  IF(chinl(2:10).NE.' ') THEN
37663  chkf=chinl(2:10)
37664  READ(chkf,5300) kf
37665  IF(mupda.EQ.2) THEN
37666  IF(kf.LE.100) THEN
37667  kc=kf
37668  ELSE
37669  kcc=kcc+1
37670  kc=kcc
37671  ENDIF
37672  ELSE
37673  kcrep=0
37674  IF(kf.LE.100) THEN
37675  kcrep=kf
37676  ELSE
37677  DO 150 kcr=101,kcc
37678  IF(kchg(kcr,4).EQ.kf) kcrep=kcr
37679  150 CONTINUE
37680  ENDIF
37681 C...Remove duplicate old decay data.
37682  IF(kcrep.NE.0) THEN
37683  idcrep=mdcy(kcrep,2)
37684  ndcrep=mdcy(kcrep,3)
37685  DO 160 i=1,kcc
37686  IF(mdcy(i,2).GT.idcrep) mdcy(i,2)=mdcy(i,2)-ndcrep
37687  160 CONTINUE
37688  DO 180 i=idcrep,ndc-ndcrep
37689  mdme(i,1)=mdme(i+ndcrep,1)
37690  mdme(i,2)=mdme(i+ndcrep,2)
37691  brat(i)=brat(i+ndcrep)
37692  DO 170 j=1,5
37693  kfdp(i,j)=kfdp(i+ndcrep,j)
37694  170 CONTINUE
37695  180 CONTINUE
37696  ndc=ndc-ndcrep
37697  kc=kcrep
37698  ELSE
37699  kcc=kcc+1
37700  kc=kcc
37701  ENDIF
37702  ENDIF
37703 
37704 C...Study line with particle data.
37705  IF(kc.GT.mstu(6)) CALL pyerrm(27,
37706  & '(PYUPDA:) Particle arrays full by KF ='//chkf)
37707  READ(chinl,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
37708  & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
37709  & mwid(kc),mdcy(kc,1)
37710  mdcy(kc,2)=0
37711  mdcy(kc,3)=0
37712 
37713 C...Study line with decay data.
37714  ELSE
37715  ndc=ndc+1
37716  IF(ndc.GT.mstu(7)) CALL pyerrm(27,
37717  & '(PYUPDA:) Decay data arrays full by KF ='//chkf)
37718  IF(mdcy(kc,2).EQ.0) mdcy(kc,2)=ndc
37719  mdcy(kc,3)=mdcy(kc,3)+1
37720  READ(chinl,5100) mdme(ndc,1),mdme(ndc,2),brat(ndc),
37721  & (kfdp(ndc,j),j=1,5)
37722  ENDIF
37723 
37724 C...End of loop; ensure that PYCOMP tables are updated.
37725  goto 140
37726  190 CONTINUE
37727  mstu(20)=0
37728 
37729 C...Perform possible tests that new information is consistent.
37730  mstj24=mstj(24)
37731  mstj(24)=0
37732  DO 220 kc=1,mstu(6)
37733  kf=kchg(kc,4)
37734  IF(kf.EQ.0) goto 220
37735  WRITE(chkf,5300) kf
37736  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
37737  & pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0) CALL pyerrm(17,
37738  & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//chkf)
37739  brsum=0d0
37740  DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
37741  IF(mdme(idc,2).GT.80) goto 210
37742  kq=kchg(kc,1)
37743  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
37744  merr=0
37745  DO 200 j=1,5
37746  kp=kfdp(idc,j)
37747  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
37748  IF(kp.EQ.81) kq=0
37749  ELSEIF(pycomp(kp).EQ.0) THEN
37750  merr=3
37751  ELSE
37752  kq=kq-pychge(kp)
37753  pms=pms-pymass(kp)
37754  kpc=pycomp(kp)
37755  pms=pms-pmas(kpc,1)
37756  IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
37757  & pmas(kpc,3))
37758  ENDIF
37759  200 CONTINUE
37760  IF(kq.NE.0) merr=max(2,merr)
37761  IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
37762  & merr=max(1,merr)
37763  IF(merr.EQ.3) CALL pyerrm(17,
37764  & '(PYUPDA:) Unknown particle code in decay of KF ='//chkf)
37765  IF(merr.EQ.2) CALL pyerrm(17,
37766  & '(PYUPDA:) Charge not conserved in decay of KF ='//chkf)
37767  IF(merr.EQ.1) CALL pyerrm(7,
37768  & '(PYUPDA:) Kinematically unallowed decay of KF ='//chkf)
37769  brsum=brsum+brat(idc)
37770  210 CONTINUE
37771  WRITE(chtmp,5500) brsum
37772  IF(abs(brsum).GT.0.0005d0.AND.abs(brsum-1d0).GT.0.0005d0)
37773  & CALL pyerrm(7,'(PYUPDA:) Sum of branching ratios is '//
37774  & chtmp(9:16)//' for KF ='//chkf)
37775  220 CONTINUE
37776  mstj(24)=mstj24
37777 
37778 C...Write DATA statements for inclusion in program.
37779  ELSEIF(mupda.EQ.4) THEN
37780 
37781 C...Find out how many codes and decay channels are actually used.
37782  kcc=0
37783  ndc=0
37784  DO 230 i=1,mstu(6)
37785  IF(kchg(i,4).NE.0) THEN
37786  kcc=i
37787  ndc=max(ndc,mdcy(i,2)+mdcy(i,3)-1)
37788  ENDIF
37789  230 CONTINUE
37790 
37791 C...Initialize writing of DATA statements for inclusion in program.
37792  DO 300 ivar=1,22
37793  ndim=mstu(6)
37794  IF(ivar.GE.12.AND.ivar.LE.19) ndim=mstu(7)
37795  nlin=1
37796  chlin=' '
37797  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
37798  llin=35
37799  chold='START'
37800 
37801 C...Loop through variables for conversion to characters.
37802  DO 280 idim=1,ndim
37803  IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
37804  IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
37805  IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
37806  IF(ivar.EQ.4) WRITE(chtmp,5400) kchg(idim,4)
37807  IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,1)
37808  IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,2)
37809  IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,3)
37810  IF(ivar.EQ.8) WRITE(chtmp,5500) pmas(idim,4)
37811  IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,1)
37812  IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,2)
37813  IF(ivar.EQ.11) WRITE(chtmp,5400) mdcy(idim,3)
37814  IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,1)
37815  IF(ivar.EQ.13) WRITE(chtmp,5400) mdme(idim,2)
37816  IF(ivar.EQ.14) WRITE(chtmp,5600) brat(idim)
37817  IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,1)
37818  IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,2)
37819  IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,3)
37820  IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,4)
37821  IF(ivar.EQ.19) WRITE(chtmp,5400) kfdp(idim,5)
37822  IF(ivar.EQ.20) chtmp=chaf(idim,1)
37823  IF(ivar.EQ.21) chtmp=chaf(idim,2)
37824  IF(ivar.EQ.22) WRITE(chtmp,5400) mwid(idim)
37825 
37826 C...Replace variables beyond what is properly defined.
37827  IF(ivar.LE.4) THEN
37828  IF(idim.GT.kcc) chtmp=' 0'
37829  ELSEIF(ivar.LE.8) THEN
37830  IF(idim.GT.kcc) chtmp=' 0.0'
37831  ELSEIF(ivar.LE.11) THEN
37832  IF(idim.GT.kcc) chtmp=' 0'
37833  ELSEIF(ivar.LE.13) THEN
37834  IF(idim.GT.ndc) chtmp=' 0'
37835  ELSEIF(ivar.LE.14) THEN
37836  IF(idim.GT.ndc) chtmp=' 0.0'
37837  ELSEIF(ivar.LE.19) THEN
37838  IF(idim.GT.ndc) chtmp=' 0'
37839  ELSEIF(ivar.LE.21) THEN
37840  IF(idim.GT.kcc) chtmp=' '
37841  ELSE
37842  IF(idim.GT.kcc) chtmp=' 0'
37843  ENDIF
37844 
37845 C...Length of variable, trailing decimal zeros, quotation marks.
37846  llow=1
37847  lhig=1
37848  DO 240 ll=1,16
37849  IF(chtmp(17-ll:17-ll).NE.' ') llow=17-ll
37850  IF(chtmp(ll:ll).NE.' ') lhig=ll
37851  240 CONTINUE
37852  chnew=chtmp(llow:lhig)//' '
37853  lnew=1+lhig-llow
37854  IF((ivar.GE.5.AND.ivar.LE.8).OR.ivar.EQ.14) THEN
37855  lnew=lnew+1
37856  250 lnew=lnew-1
37857  IF(lnew.GE.2.AND.chnew(lnew:lnew).EQ.'0') goto 250
37858  IF(chnew(lnew:lnew).EQ.'.') lnew=lnew-1
37859  IF(lnew.EQ.0) THEN
37860  chnew(1:3)='0D0'
37861  lnew=3
37862  ELSE
37863  chnew(lnew+1:lnew+2)='D0'
37864  lnew=lnew+2
37865  ENDIF
37866  ELSEIF(ivar.EQ.20.OR.ivar.EQ.21) THEN
37867  DO 260 ll=lnew,1,-1
37868  IF(chnew(ll:ll).EQ.'''') THEN
37869  chtmp=chnew
37870  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
37871  lnew=lnew+1
37872  ENDIF
37873  260 CONTINUE
37874  lnew=min(14,lnew)
37875  chtmp=chnew
37876  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
37877  lnew=lnew+2
37878  ENDIF
37879 
37880 C...Form composite character string, often including repetition counter.
37881  IF(chnew.NE.chold) THEN
37882  nrpt=1
37883  chold=chnew
37884  chcom=chnew
37885  lcom=lnew
37886  ELSE
37887  lrpt=lnew+1
37888  IF(nrpt.GE.2) lrpt=lnew+3
37889  IF(nrpt.GE.10) lrpt=lnew+4
37890  IF(nrpt.GE.100) lrpt=lnew+5
37891  IF(nrpt.GE.1000) lrpt=lnew+6
37892  llin=llin-lrpt
37893  nrpt=nrpt+1
37894  WRITE(chtmp,5400) nrpt
37895  lrpt=1
37896  IF(nrpt.GE.10) lrpt=2
37897  IF(nrpt.GE.100) lrpt=3
37898  IF(nrpt.GE.1000) lrpt=4
37899  chcom(1:lrpt+1+lnew)=chtmp(17-lrpt:16)//'*'//chnew(1:lnew)
37900  lcom=lrpt+1+lnew
37901  ENDIF
37902 
37903 C...Add characters to end of line, to new line (after storing old line),
37904 C...or to new block of lines (after writing old block).
37905  IF(llin+lcom.LE.70) THEN
37906  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
37907  llin=llin+lcom+1
37908  ELSEIF(nlin.LE.19) THEN
37909  chlin(llin+1:72)=' '
37910  chblk(nlin)=chlin
37911  nlin=nlin+1
37912  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
37913  llin=6+lcom+1
37914  ELSE
37915  chlin(llin:72)='/'//' '
37916  chblk(nlin)=chlin
37917  WRITE(chtmp,5400) idim-nrpt
37918  chblk(1)(30:33)=chtmp(13:16)
37919  DO 270 ilin=1,nlin
37920  WRITE(lfn,5700) chblk(ilin)
37921  270 CONTINUE
37922  nlin=1
37923  chlin=' '
37924  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//
37925  & ',I= , )/'//chcom(1:lcom)//','
37926  WRITE(chtmp,5400) idim-nrpt+1
37927  chlin(25:28)=chtmp(13:16)
37928  llin=35+lcom+1
37929  ENDIF
37930  280 CONTINUE
37931 
37932 C...Write final block of lines.
37933  chlin(llin:72)='/'//' '
37934  chblk(nlin)=chlin
37935  WRITE(chtmp,5400) ndim
37936  chblk(1)(30:33)=chtmp(13:16)
37937  DO 290 ilin=1,nlin
37938  WRITE(lfn,5700) chblk(ilin)
37939  290 CONTINUE
37940  300 CONTINUE
37941  ENDIF
37942 
37943 C...Formats for reading and writing particle data.
37944  5000 FORMAT(1x,i9,2x,a16,2x,a16,3i3,3f12.5,1p,e13.5,2i3)
37945  5100 FORMAT(10x,2i5,f12.6,5i10)
37946  5200 FORMAT(a120)
37947  5300 FORMAT(i9)
37948  5400 FORMAT(i16)
37949  5500 FORMAT(f16.5)
37950  5600 FORMAT(f16.6)
37951  5700 FORMAT(a72)
37952 
37953  RETURN
37954  END
37955 
37956 C*********************************************************************
37957 
37958 C...PYK
37959 C...Provides various integer-valued event related data.
37960 
37961  FUNCTION pyk(I,J)
37962 
37963 C...Double precision and integer declarations.
37964  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37965  INTEGER pyk,pychge,pycomp
37966 C...Commonblocks.
37967  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
37968  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37969  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37970  SAVE /pyjets/,/pydat1/,/pydat2/
37971 
37972 C...Default value. For I=0 number of entries, number of stable entries
37973 C...or 3 times total charge.
37974  pyk=0
37975  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
37976  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
37977  pyk=n
37978  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
37979  DO 100 i1=1,n
37980  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+1
37981  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+
37982  & pychge(k(i1,2))
37983  100 CONTINUE
37984  ELSEIF(i.EQ.0) THEN
37985 
37986 C...For I > 0 direct readout of K matrix or charge.
37987  ELSEIF(j.LE.5) THEN
37988  pyk=k(i,j)
37989  ELSEIF(j.EQ.6) THEN
37990  pyk=pychge(k(i,2))
37991 
37992 C...Status (existing/fragmented/decayed), parton/hadron separation.
37993  ELSEIF(j.LE.8) THEN
37994  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pyk=1
37995  IF(j.EQ.8) pyk=pyk*k(i,2)
37996  ELSEIF(j.LE.12) THEN
37997  kfa=iabs(k(i,2))
37998  kc=pycomp(kfa)
37999  kq=0
38000  IF(kc.NE.0) kq=kchg(kc,2)
38001  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) pyk=k(i,2)
38002  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) pyk=k(i,2)
38003  IF(j.EQ.11) pyk=kc
38004  IF(j.EQ.12) pyk=kq*isign(1,k(i,2))
38005 
38006 C...Heaviest flavour in hadron/diquark.
38007  ELSEIF(j.EQ.13) THEN
38008  kfa=iabs(k(i,2))
38009  pyk=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
38010  IF(kfa.LT.10) pyk=kfa
38011  IF(mod(kfa/1000,10).NE.0) pyk=mod(kfa/1000,10)
38012  pyk=pyk*isign(1,k(i,2))
38013 
38014 C...Particle history: generation, ancestor, rank.
38015  ELSEIF(j.LE.15) THEN
38016  i2=i
38017  i1=i
38018  110 pyk=pyk+1
38019  i2=i1
38020  i1=k(i1,3)
38021  IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110
38022  IF(j.EQ.15) pyk=i2
38023  ELSEIF(j.EQ.16) THEN
38024  kfa=iabs(k(i,2))
38025  IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
38026  & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
38027  i1=i
38028  120 i2=i1
38029  i1=k(i1,3)
38030  IF(i1.GT.0) THEN
38031  kfam=iabs(k(i1,2))
38032  ilp=1
38033  IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
38034  IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
38035  & ilp=0
38036  IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
38037  IF(ilp.EQ.1) goto 120
38038  ENDIF
38039  IF(k(i1,1).EQ.12) THEN
38040  DO 130 i3=i1+1,i2
38041  IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
38042  & .AND.k(i3,2).NE.93) pyk=pyk+1
38043  130 CONTINUE
38044  ELSE
38045  i3=i2
38046  140 pyk=pyk+1
38047  i3=i3+1
38048  IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) goto 140
38049  ENDIF
38050  ENDIF
38051 
38052 C...Particle coming from collapsing jet system or not.
38053  ELSEIF(j.EQ.17) THEN
38054  i1=i
38055  150 pyk=pyk+1
38056  i3=i1
38057  i1=k(i1,3)
38058  i0=max(1,i1)
38059  kc=pycomp(k(i0,2))
38060  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
38061  IF(pyk.EQ.1) pyk=-1
38062  IF(pyk.GT.1) pyk=0
38063  RETURN
38064  ENDIF
38065  IF(kchg(kc,2).EQ.0) goto 150
38066  IF(k(i1,1).NE.12) pyk=0
38067  IF(k(i1,1).NE.12) RETURN
38068  i2=i1
38069  160 i2=i2+1
38070  IF(i2.LT.n.AND.k(i2,1).NE.11) goto 160
38071  k3m=k(i3-1,3)
38072  IF(k3m.GE.i1.AND.k3m.LE.i2) pyk=0
38073  k3p=k(i3+1,3)
38074  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) pyk=0
38075 
38076 C...Number of decay products. Colour flow.
38077  ELSEIF(j.EQ.18) THEN
38078  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) pyk=max(0,k(i,5)-k(i,4)+1)
38079  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) pyk=0
38080  ELSEIF(j.LE.22) THEN
38081  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
38082  IF(j.EQ.19) pyk=mod(k(i,4)/mstu(5),mstu(5))
38083  IF(j.EQ.20) pyk=mod(k(i,5)/mstu(5),mstu(5))
38084  IF(j.EQ.21) pyk=mod(k(i,4),mstu(5))
38085  IF(j.EQ.22) pyk=mod(k(i,5),mstu(5))
38086  ELSE
38087  ENDIF
38088 
38089  RETURN
38090  END
38091 
38092 C*********************************************************************
38093 
38094 C...PYP
38095 C...Provides various real-valued event related data.
38096 
38097  FUNCTION pyp(I,J)
38098 
38099 C...Double precision and integer declarations.
38100  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38101  INTEGER pyk,pychge,pycomp
38102 C...Commonblocks.
38103  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38104  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38105  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38106  SAVE /pyjets/,/pydat1/,/pydat2/
38107 C...Local array.
38108  dimension psum(4)
38109 
38110 C...Set default value. For I = 0 sum of momenta or charges,
38111 C...or invariant mass of system.
38112  pyp=0d0
38113  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
38114  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
38115  DO 100 i1=1,n
38116  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+p(i1,j)
38117  100 CONTINUE
38118  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
38119  DO 120 j1=1,4
38120  psum(j1)=0d0
38121  DO 110 i1=1,n
38122  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+
38123  & p(i1,j1)
38124  110 CONTINUE
38125  120 CONTINUE
38126  pyp=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
38127  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
38128  DO 130 i1=1,n
38129  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+pychge(k(i1,2))/3d0
38130  130 CONTINUE
38131  ELSEIF(i.EQ.0) THEN
38132 
38133 C...Direct readout of P matrix.
38134  ELSEIF(j.LE.5) THEN
38135  pyp=p(i,j)
38136 
38137 C...Charge, total momentum, transverse momentum, transverse mass.
38138  ELSEIF(j.LE.12) THEN
38139  IF(j.EQ.6) pyp=pychge(k(i,2))/3d0
38140  IF(j.EQ.7.OR.j.EQ.8) pyp=p(i,1)**2+p(i,2)**2+p(i,3)**2
38141  IF(j.EQ.9.OR.j.EQ.10) pyp=p(i,1)**2+p(i,2)**2
38142  IF(j.EQ.11.OR.j.EQ.12) pyp=p(i,5)**2+p(i,1)**2+p(i,2)**2
38143  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) pyp=sqrt(pyp)
38144 
38145 C...Theta and phi angle in radians or degrees.
38146  ELSEIF(j.LE.16) THEN
38147  IF(j.LE.14) pyp=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
38148  IF(j.GE.15) pyp=pyangl(p(i,1),p(i,2))
38149  IF(j.EQ.14.OR.j.EQ.16) pyp=pyp*180d0/paru(1)
38150 
38151 C...True rapidity, rapidity with pion mass, pseudorapidity.
38152  ELSEIF(j.LE.19) THEN
38153  pmr=0d0
38154  IF(j.EQ.17) pmr=p(i,5)
38155  IF(j.EQ.18) pmr=pymass(211)
38156  pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
38157  pyp=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
38158  & 1d20)),p(i,3))
38159 
38160 C...Energy and momentum fractions (only to be used in CM frame).
38161  ELSEIF(j.LE.25) THEN
38162  IF(j.EQ.20) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
38163  IF(j.EQ.21) pyp=2d0*p(i,3)/paru(21)
38164  IF(j.EQ.22) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
38165  IF(j.EQ.23) pyp=2d0*p(i,4)/paru(21)
38166  IF(j.EQ.24) pyp=(p(i,4)+p(i,3))/paru(21)
38167  IF(j.EQ.25) pyp=(p(i,4)-p(i,3))/paru(21)
38168  ENDIF
38169 
38170  RETURN
38171  END
38172 
38173 C*********************************************************************
38174 
38175 C...PYSPHE
38176 C...Performs sphericity tensor analysis to give sphericity,
38177 C...aplanarity and the related event axes.
38178 
38179  SUBROUTINE pysphe(SPH,APL)
38180 
38181 C...Double precision and integer declarations.
38182  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38183  INTEGER pyk,pychge,pycomp
38184 C...Commonblocks.
38185  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38186  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38187  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38188  SAVE /pyjets/,/pydat1/,/pydat2/
38189 C...Local arrays.
38190  dimension sm(3,3),sv(3,3)
38191 
38192 C...Calculate matrix to be diagonalized.
38193  np=0
38194  DO 110 j1=1,3
38195  DO 100 j2=j1,3
38196  sm(j1,j2)=0d0
38197  100 CONTINUE
38198  110 CONTINUE
38199  ps=0d0
38200  DO 140 i=1,n
38201  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
38202  IF(mstu(41).GE.2) THEN
38203  kc=pycomp(k(i,2))
38204  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
38205  & kc.EQ.18) goto 140
38206  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
38207  & goto 140
38208  ENDIF
38209  np=np+1
38210  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
38211  pwt=1d0
38212  IF(abs(paru(41)-2d0).GT.0.001d0) pwt=
38213  & max(1d-10,pa)**(paru(41)-2d0)
38214  DO 130 j1=1,3
38215  DO 120 j2=j1,3
38216  sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
38217  120 CONTINUE
38218  130 CONTINUE
38219  ps=ps+pwt*pa**2
38220  140 CONTINUE
38221 
38222 C...Very low multiplicities (0 or 1) not considered.
38223  IF(np.LE.1) THEN
38224  CALL pyerrm(8,'(PYSPHE:) too few particles for analysis')
38225  sph=-1d0
38226  apl=-1d0
38227  RETURN
38228  ENDIF
38229  DO 160 j1=1,3
38230  DO 150 j2=j1,3
38231  sm(j1,j2)=sm(j1,j2)/ps
38232  150 CONTINUE
38233  160 CONTINUE
38234 
38235 C...Find eigenvalues to matrix (third degree equation).
38236  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
38237  &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
38238  sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
38239  &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
38240  &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
38241  sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
38242  p(n+1,4)=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
38243  p(n+3,4)=1d0/3d0+sqrt(-sq)*min(2d0*sp,-sqrt(3d0*(1d0-sp**2))-sp)
38244  p(n+2,4)=1d0-p(n+1,4)-p(n+3,4)
38245  IF(p(n+2,4).LT.1d-5) THEN
38246  CALL pyerrm(8,'(PYSPHE:) all particles back-to-back')
38247  sph=-1d0
38248  apl=-1d0
38249  RETURN
38250  ENDIF
38251 
38252 C...Find first and last eigenvector by solving equation system.
38253  DO 240 i=1,3,2
38254  DO 180 j1=1,3
38255  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
38256  DO 170 j2=j1+1,3
38257  sv(j1,j2)=sm(j1,j2)
38258  sv(j2,j1)=sm(j1,j2)
38259  170 CONTINUE
38260  180 CONTINUE
38261  smax=0d0
38262  DO 200 j1=1,3
38263  DO 190 j2=1,3
38264  IF(abs(sv(j1,j2)).LE.smax) goto 190
38265  ja=j1
38266  jb=j2
38267  smax=abs(sv(j1,j2))
38268  190 CONTINUE
38269  200 CONTINUE
38270  smax=0d0
38271  DO 220 j3=ja+1,ja+2
38272  j1=j3-3*((j3-1)/3)
38273  rl=sv(j1,jb)/sv(ja,jb)
38274  DO 210 j2=1,3
38275  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
38276  IF(abs(sv(j1,j2)).LE.smax) goto 210
38277  jc=j1
38278  smax=abs(sv(j1,j2))
38279  210 CONTINUE
38280  220 CONTINUE
38281  jb1=jb+1-3*(jb/3)
38282  jb2=jb+2-3*((jb+1)/3)
38283  p(n+i,jb1)=-sv(jc,jb2)
38284  p(n+i,jb2)=sv(jc,jb1)
38285  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
38286  & sv(ja,jb)
38287  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
38288  sgn=(-1d0)**int(pyr(0)+0.5d0)
38289  DO 230 j=1,3
38290  p(n+i,j)=sgn*p(n+i,j)/pa
38291  230 CONTINUE
38292  240 CONTINUE
38293 
38294 C...Middle axis orthogonal to other two. Fill other codes.
38295  sgn=(-1d0)**int(pyr(0)+0.5d0)
38296  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
38297  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
38298  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
38299  DO 260 i=1,3
38300  k(n+i,1)=31
38301  k(n+i,2)=95
38302  k(n+i,3)=i
38303  k(n+i,4)=0
38304  k(n+i,5)=0
38305  p(n+i,5)=0d0
38306  DO 250 j=1,5
38307  v(i,j)=0d0
38308  250 CONTINUE
38309  260 CONTINUE
38310 
38311 C...Calculate sphericity and aplanarity. Select storing option.
38312  sph=1.5d0*(p(n+2,4)+p(n+3,4))
38313  apl=1.5d0*p(n+3,4)
38314  mstu(61)=n+1
38315  mstu(62)=np
38316  IF(mstu(43).LE.1) mstu(3)=3
38317  IF(mstu(43).GE.2) n=n+3
38318 
38319  RETURN
38320  END
38321 
38322 C*********************************************************************
38323 
38324 C...PYTHRU
38325 C...Performs thrust analysis to give thrust, oblateness
38326 C...and the related event axes.
38327 
38328  SUBROUTINE pythru(THR,OBL)
38329 
38330 C...Double precision and integer declarations.
38331  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38332  INTEGER pyk,pychge,pycomp
38333 C...Commonblocks.
38334  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38335  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38336  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38337  SAVE /pyjets/,/pydat1/,/pydat2/
38338 C...Local arrays.
38339  dimension tdi(3),tpr(3)
38340 
38341 C...Take copy of particles that are to be considered in thrust analysis.
38342  np=0
38343  ps=0d0
38344  DO 100 i=1,n
38345  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
38346  IF(mstu(41).GE.2) THEN
38347  kc=pycomp(k(i,2))
38348  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
38349  & kc.EQ.18) goto 100
38350  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
38351  & goto 100
38352  ENDIF
38353  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
38354  CALL pyerrm(11,'(PYTHRU:) no more memory left in PYJETS')
38355  thr=-2d0
38356  obl=-2d0
38357  RETURN
38358  ENDIF
38359  np=np+1
38360  k(n+np,1)=23
38361  p(n+np,1)=p(i,1)
38362  p(n+np,2)=p(i,2)
38363  p(n+np,3)=p(i,3)
38364  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
38365  p(n+np,5)=1d0
38366  IF(abs(paru(42)-1d0).GT.0.001d0) p(n+np,5)=
38367  & p(n+np,4)**(paru(42)-1d0)
38368  ps=ps+p(n+np,4)*p(n+np,5)
38369  100 CONTINUE
38370 
38371 C...Very low multiplicities (0 or 1) not considered.
38372  IF(np.LE.1) THEN
38373  CALL pyerrm(8,'(PYTHRU:) too few particles for analysis')
38374  thr=-1d0
38375  obl=-1d0
38376  RETURN
38377  ENDIF
38378 
38379 C...Loop over thrust and major. T axis along z direction in latter case.
38380  DO 320 ild=1,2
38381  IF(ild.EQ.2) THEN
38382  k(n+np+1,1)=31
38383  phi=pyangl(p(n+np+1,1),p(n+np+1,2))
38384  mstu(33)=1
38385  CALL pyrobo(n+1,n+np+1,0d0,-phi,0d0,0d0,0d0)
38386  the=pyangl(p(n+np+1,3),p(n+np+1,1))
38387  CALL pyrobo(n+1,n+np+1,-the,0d0,0d0,0d0,0d0)
38388  ENDIF
38389 
38390 C...Find and order particles with highest p (pT for major).
38391  DO 110 ilf=n+np+4,n+np+mstu(44)+4
38392  p(ilf,4)=0d0
38393  110 CONTINUE
38394  DO 160 i=n+1,n+np
38395  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
38396  DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
38397  IF(p(i,4).LE.p(ilf,4)) goto 140
38398  DO 120 j=1,5
38399  p(ilf+1,j)=p(ilf,j)
38400  120 CONTINUE
38401  130 CONTINUE
38402  ilf=n+np+3
38403  140 DO 150 j=1,5
38404  p(ilf+1,j)=p(i,j)
38405  150 CONTINUE
38406  160 CONTINUE
38407 
38408 C...Find and order initial axes with highest thrust (major).
38409  DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
38410  p(ilg,4)=0d0
38411  170 CONTINUE
38412  nc=2**(min(mstu(44),np)-1)
38413  DO 250 ilc=1,nc
38414  DO 180 j=1,3
38415  tdi(j)=0d0
38416  180 CONTINUE
38417  DO 200 ilf=1,min(mstu(44),np)
38418  sgn=p(n+np+ilf+3,5)
38419  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
38420  DO 190 j=1,4-ild
38421  tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
38422  190 CONTINUE
38423  200 CONTINUE
38424  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
38425  DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
38426  IF(tds.LE.p(ilg,4)) goto 230
38427  DO 210 j=1,4
38428  p(ilg+1,j)=p(ilg,j)
38429  210 CONTINUE
38430  220 CONTINUE
38431  ilg=n+np+mstu(44)+4
38432  230 DO 240 j=1,3
38433  p(ilg+1,j)=tdi(j)
38434  240 CONTINUE
38435  p(ilg+1,4)=tds
38436  250 CONTINUE
38437 
38438 C...Iterate direction of axis until stable maximum.
38439  p(n+np+ild,4)=0d0
38440  ilg=0
38441  260 ilg=ilg+1
38442  thp=0d0
38443  270 thps=thp
38444  DO 280 j=1,3
38445  IF(thp.LE.1d-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
38446  IF(thp.GT.1d-10) tdi(j)=tpr(j)
38447  tpr(j)=0d0
38448  280 CONTINUE
38449  DO 300 i=n+1,n+np
38450  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
38451  DO 290 j=1,4-ild
38452  tpr(j)=tpr(j)+sgn*p(i,j)
38453  290 CONTINUE
38454  300 CONTINUE
38455  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
38456  IF(thp.GE.thps+paru(48)) goto 270
38457 
38458 C...Save good axis. Try new initial axis until a number of tries agree.
38459  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 260
38460  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
38461  iagr=0
38462  sgn=(-1d0)**int(pyr(0)+0.5d0)
38463  DO 310 j=1,3
38464  p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
38465  310 CONTINUE
38466  p(n+np+ild,4)=thp
38467  p(n+np+ild,5)=0d0
38468  ENDIF
38469  iagr=iagr+1
38470  IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 260
38471  320 CONTINUE
38472 
38473 C...Find minor axis and value by orthogonality.
38474  sgn=(-1d0)**int(pyr(0)+0.5d0)
38475  p(n+np+3,1)=-sgn*p(n+np+2,2)
38476  p(n+np+3,2)=sgn*p(n+np+2,1)
38477  p(n+np+3,3)=0d0
38478  thp=0d0
38479  DO 330 i=n+1,n+np
38480  thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
38481  330 CONTINUE
38482  p(n+np+3,4)=thp/ps
38483  p(n+np+3,5)=0d0
38484 
38485 C...Fill axis information. Rotate back to original coordinate system.
38486  DO 350 ild=1,3
38487  k(n+ild,1)=31
38488  k(n+ild,2)=96
38489  k(n+ild,3)=ild
38490  k(n+ild,4)=0
38491  k(n+ild,5)=0
38492  DO 340 j=1,5
38493  p(n+ild,j)=p(n+np+ild,j)
38494  v(n+ild,j)=0d0
38495  340 CONTINUE
38496  350 CONTINUE
38497  CALL pyrobo(n+1,n+3,the,phi,0d0,0d0,0d0)
38498 
38499 C...Calculate thrust and oblateness. Select storing option.
38500  thr=p(n+1,4)
38501  obl=p(n+2,4)-p(n+3,4)
38502  mstu(61)=n+1
38503  mstu(62)=np
38504  IF(mstu(43).LE.1) mstu(3)=3
38505  IF(mstu(43).GE.2) n=n+3
38506 
38507  RETURN
38508  END
38509 
38510 C*********************************************************************
38511 
38512 C...PYCLUS
38513 C...Subdivides the particle content of an event into jets/clusters.
38514 
38515  SUBROUTINE pyclus(NJET)
38516 
38517 C...Double precision and integer declarations.
38518  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38519  INTEGER pyk,pychge,pycomp
38520 C...Commonblocks.
38521  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38522  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38523  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38524  SAVE /pyjets/,/pydat1/,/pydat2/
38525 C...Local arrays and saved variables.
38526  dimension ps(5)
38527  SAVE nsav,np,ps,pss,rinit,npre,nrem
38528 
38529 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
38530  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
38531  &p(i1,3)*p(i2,3))*2d0*p(i1,5)*p(i2,5)/(0.0001d0+p(i1,5)+p(i2,5))**2
38532  r2m(i1,i2)=2d0*p(i1,4)*p(i2,4)*(1d0-(p(i1,1)*p(i2,1)+p(i1,2)*
38533  &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
38534  r2d(i1,i2)=2d0*min(p(i1,4),p(i2,4))**2*(1d0-(p(i1,1)*p(i2,1)+
38535  &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
38536 
38537 C...If first time, reset. If reentering, skip preliminaries.
38538  IF(mstu(48).LE.0) THEN
38539  np=0
38540  DO 100 j=1,5
38541  ps(j)=0d0
38542  100 CONTINUE
38543  pss=0d0
38544  pimass=pmas(pycomp(211),1)
38545  ELSE
38546  njet=nsav
38547  IF(mstu(43).GE.2) n=n-njet
38548  DO 110 i=n+1,n+njet
38549  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
38550  110 CONTINUE
38551  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
38552  r2acc=paru(44)**2
38553  ELSE
38554  r2acc=paru(45)*ps(5)**2
38555  ENDIF
38556  nloop=0
38557  goto 300
38558  ENDIF
38559 
38560 C...Find which particles are to be considered in cluster search.
38561  DO 140 i=1,n
38562  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
38563  IF(mstu(41).GE.2) THEN
38564  kc=pycomp(k(i,2))
38565  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
38566  & kc.EQ.18) goto 140
38567  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
38568  & goto 140
38569  ENDIF
38570  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
38571  CALL pyerrm(11,'(PYCLUS:) no more memory left in PYJETS')
38572  njet=-1
38573  RETURN
38574  ENDIF
38575 
38576 C...Take copy of these particles, with space left for jets later on.
38577  np=np+1
38578  k(n+np,3)=i
38579  DO 120 j=1,5
38580  p(n+np,j)=p(i,j)
38581  120 CONTINUE
38582  IF(mstu(42).EQ.0) p(n+np,5)=0d0
38583  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
38584  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
38585  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
38586  DO 130 j=1,4
38587  ps(j)=ps(j)+p(n+np,j)
38588  130 CONTINUE
38589  pss=pss+p(n+np,5)
38590  140 CONTINUE
38591  DO 160 i=n+1,n+np
38592  k(i+np,3)=k(i,3)
38593  DO 150 j=1,5
38594  p(i+np,j)=p(i,j)
38595  150 CONTINUE
38596  160 CONTINUE
38597  ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
38598 
38599 C...Very low multiplicities not considered.
38600  IF(np.LT.mstu(47)) THEN
38601  CALL pyerrm(8,'(PYCLUS:) too few particles for analysis')
38602  njet=-1
38603  RETURN
38604  ENDIF
38605 
38606 C...Find precluster configuration. If too few jets, make harder cuts.
38607  nloop=0
38608  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
38609  r2acc=paru(44)**2
38610  ELSE
38611  r2acc=paru(45)*ps(5)**2
38612  ENDIF
38613  rinit=1.25d0*paru(43)
38614  IF(np.LE.mstu(47)+2) rinit=0d0
38615  170 rinit=0.8d0*rinit
38616  npre=0
38617  nrem=np
38618  DO 180 i=n+np+1,n+2*np
38619  k(i,4)=0
38620  180 CONTINUE
38621 
38622 C...Sum up small momentum region. Jet if enough absolute momentum.
38623  IF(mstu(46).LE.2) THEN
38624  DO 190 j=1,4
38625  p(n+1,j)=0d0
38626  190 CONTINUE
38627  DO 210 i=n+np+1,n+2*np
38628  IF(p(i,5).GT.2d0*rinit) goto 210
38629  nrem=nrem-1
38630  k(i,4)=1
38631  DO 200 j=1,4
38632  p(n+1,j)=p(n+1,j)+p(i,j)
38633  200 CONTINUE
38634  210 CONTINUE
38635  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
38636  IF(p(n+1,5).GT.2d0*rinit) npre=1
38637  IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
38638  IF(nrem.EQ.0) goto 170
38639  ENDIF
38640 
38641 C...Find fastest remaining particle.
38642  220 npre=npre+1
38643  pmax=0d0
38644  DO 230 i=n+np+1,n+2*np
38645  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 230
38646  imax=i
38647  pmax=p(i,5)
38648  230 CONTINUE
38649  DO 240 j=1,5
38650  p(n+npre,j)=p(imax,j)
38651  240 CONTINUE
38652  nrem=nrem-1
38653  k(imax,4)=npre
38654 
38655 C...Sum up precluster around it according to pT separation.
38656  IF(mstu(46).LE.2) THEN
38657  DO 260 i=n+np+1,n+2*np
38658  IF(k(i,4).NE.0) goto 260
38659  r2=r2t(i,imax)
38660  IF(r2.GT.rinit**2) goto 260
38661  nrem=nrem-1
38662  k(i,4)=npre
38663  DO 250 j=1,4
38664  p(n+npre,j)=p(n+npre,j)+p(i,j)
38665  250 CONTINUE
38666  260 CONTINUE
38667  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
38668 
38669 C...Sum up precluster around it according to mass or
38670 C...Durham pT separation.
38671  ELSE
38672  270 imin=0
38673  r2min=rinit**2
38674  DO 280 i=n+np+1,n+2*np
38675  IF(k(i,4).NE.0) goto 280
38676  IF(mstu(46).LE.4) THEN
38677  r2=r2m(i,n+npre)
38678  ELSE
38679  r2=r2d(i,n+npre)
38680  ENDIF
38681  IF(r2.GE.r2min) goto 280
38682  imin=i
38683  r2min=r2
38684  280 CONTINUE
38685  IF(imin.NE.0) THEN
38686  DO 290 j=1,4
38687  p(n+npre,j)=p(n+npre,j)+p(imin,j)
38688  290 CONTINUE
38689  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
38690  nrem=nrem-1
38691  k(imin,4)=npre
38692  goto 270
38693  ENDIF
38694  ENDIF
38695 
38696 C...Check if more preclusters to be found. Start over if too few.
38697  IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
38698  IF(nrem.GT.0) goto 220
38699  njet=npre
38700 
38701 C...Reassign all particles to nearest jet. Sum up new jet momenta.
38702  300 tsav=0d0
38703  psjt=0d0
38704  310 IF(mstu(46).LE.1) THEN
38705  DO 330 i=n+1,n+njet
38706  DO 320 j=1,4
38707  v(i,j)=0d0
38708  320 CONTINUE
38709  330 CONTINUE
38710  DO 360 i=n+np+1,n+2*np
38711  r2min=pss**2
38712  DO 340 ijet=n+1,n+njet
38713  IF(p(ijet,5).LT.rinit) goto 340
38714  r2=r2t(i,ijet)
38715  IF(r2.GE.r2min) goto 340
38716  imin=ijet
38717  r2min=r2
38718  340 CONTINUE
38719  k(i,4)=imin-n
38720  DO 350 j=1,4
38721  v(imin,j)=v(imin,j)+p(i,j)
38722  350 CONTINUE
38723  360 CONTINUE
38724  psjt=0d0
38725  DO 380 i=n+1,n+njet
38726  DO 370 j=1,4
38727  p(i,j)=v(i,j)
38728  370 CONTINUE
38729  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
38730  psjt=psjt+p(i,5)
38731  380 CONTINUE
38732  ENDIF
38733 
38734 C...Find two closest jets.
38735  r2min=2d0*max(r2acc,ps(5)**2)
38736  DO 400 itry1=n+1,n+njet-1
38737  DO 390 itry2=itry1+1,n+njet
38738  IF(mstu(46).LE.2) THEN
38739  r2=r2t(itry1,itry2)
38740  ELSEIF(mstu(46).LE.4) THEN
38741  r2=r2m(itry1,itry2)
38742  ELSE
38743  r2=r2d(itry1,itry2)
38744  ENDIF
38745  IF(r2.GE.r2min) goto 390
38746  imin1=itry1
38747  imin2=itry2
38748  r2min=r2
38749  390 CONTINUE
38750  400 CONTINUE
38751 
38752 C...If allowed, join two closest jets and start over.
38753  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
38754  irec=min(imin1,imin2)
38755  idel=max(imin1,imin2)
38756  DO 410 j=1,4
38757  p(irec,j)=p(imin1,j)+p(imin2,j)
38758  410 CONTINUE
38759  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
38760  DO 430 i=idel+1,n+njet
38761  DO 420 j=1,5
38762  p(i-1,j)=p(i,j)
38763  420 CONTINUE
38764  430 CONTINUE
38765  IF(mstu(46).GE.2) THEN
38766  DO 440 i=n+np+1,n+2*np
38767  iori=n+k(i,4)
38768  IF(iori.EQ.idel) k(i,4)=irec-n
38769  IF(iori.GT.idel) k(i,4)=k(i,4)-1
38770  440 CONTINUE
38771  ENDIF
38772  njet=njet-1
38773  goto 300
38774 
38775 C...Divide up broad jet if empty cluster in list of final ones.
38776  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
38777  DO 450 i=n+1,n+njet
38778  k(i,5)=0
38779  450 CONTINUE
38780  DO 460 i=n+np+1,n+2*np
38781  k(n+k(i,4),5)=k(n+k(i,4),5)+1
38782  460 CONTINUE
38783  iemp=0
38784  DO 470 i=n+1,n+njet
38785  IF(k(i,5).EQ.0) iemp=i
38786  470 CONTINUE
38787  IF(iemp.NE.0) THEN
38788  nloop=nloop+1
38789  ispl=0
38790  r2max=0d0
38791  DO 480 i=n+np+1,n+2*np
38792  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 480
38793  ijet=n+k(i,4)
38794  r2=r2t(i,ijet)
38795  IF(r2.LE.r2max) goto 480
38796  ispl=i
38797  r2max=r2
38798  480 CONTINUE
38799  IF(ispl.NE.0) THEN
38800  ijet=n+k(ispl,4)
38801  DO 490 j=1,4
38802  p(iemp,j)=p(ispl,j)
38803  p(ijet,j)=p(ijet,j)-p(ispl,j)
38804  490 CONTINUE
38805  p(iemp,5)=p(ispl,5)
38806  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
38807  IF(nloop.LE.2) goto 300
38808  ENDIF
38809  ENDIF
38810  ENDIF
38811 
38812 C...If generalized thrust has not yet converged, continue iteration.
38813  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
38814  &THEN
38815  tsav=psjt/pss
38816  goto 310
38817  ENDIF
38818 
38819 C...Reorder jets according to energy.
38820  DO 510 i=n+1,n+njet
38821  DO 500 j=1,5
38822  v(i,j)=p(i,j)
38823  500 CONTINUE
38824  510 CONTINUE
38825  DO 540 inew=n+1,n+njet
38826  pemax=0d0
38827  DO 520 itry=n+1,n+njet
38828  IF(v(itry,4).LE.pemax) goto 520
38829  imax=itry
38830  pemax=v(itry,4)
38831  520 CONTINUE
38832  k(inew,1)=31
38833  k(inew,2)=97
38834  k(inew,3)=inew-n
38835  k(inew,4)=0
38836  DO 530 j=1,5
38837  p(inew,j)=v(imax,j)
38838  530 CONTINUE
38839  v(imax,4)=-1d0
38840  k(imax,5)=inew
38841  540 CONTINUE
38842 
38843 C...Clean up particle-jet assignments and jet information.
38844  DO 550 i=n+np+1,n+2*np
38845  iori=k(n+k(i,4),5)
38846  k(i,4)=iori-n
38847  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
38848  k(iori,4)=k(iori,4)+1
38849  550 CONTINUE
38850  iemp=0
38851  psjt=0d0
38852  DO 570 i=n+1,n+njet
38853  k(i,5)=0
38854  psjt=psjt+p(i,5)
38855  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0d0))
38856  DO 560 j=1,5
38857  v(i,j)=0d0
38858  560 CONTINUE
38859  IF(k(i,4).EQ.0) iemp=i
38860  570 CONTINUE
38861 
38862 C...Select storing option. Output variables. Check for failure.
38863  mstu(61)=n+1
38864  mstu(62)=np
38865  mstu(63)=npre
38866  paru(61)=ps(5)
38867  paru(62)=psjt/pss
38868  paru(63)=sqrt(r2min)
38869  IF(njet.LE.1) paru(63)=0d0
38870  IF(iemp.NE.0) THEN
38871  CALL pyerrm(8,'(PYCLUS:) failed to reconstruct as requested')
38872  njet=-1
38873  ENDIF
38874  IF(mstu(43).LE.1) mstu(3)=njet
38875  IF(mstu(43).GE.2) n=n+njet
38876  nsav=njet
38877 
38878  RETURN
38879  END
38880 
38881 C*********************************************************************
38882 
38883 C...PYCELL
38884 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
38885 C...as used for calorimeters at hadron colliders.
38886 
38887  SUBROUTINE pycell(NJET)
38888 
38889 C...Double precision and integer declarations.
38890  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38891  INTEGER pyk,pychge,pycomp
38892 C...Commonblocks.
38893  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38894  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38895  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38896  SAVE /pyjets/,/pydat1/,/pydat2/
38897 
38898 C...Loop over all particles. Find cell that was hit by given particle.
38899  ptlrat=1d0/sinh(paru(51))**2
38900  np=0
38901  nc=n
38902  DO 110 i=1,n
38903  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
38904  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110
38905  IF(mstu(41).GE.2) THEN
38906  kc=pycomp(k(i,2))
38907  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
38908  & kc.EQ.18) goto 110
38909  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
38910  & goto 110
38911  ENDIF
38912  np=np+1
38913  pt=sqrt(p(i,1)**2+p(i,2)**2)
38914  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
38915  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5d0*
38916  & (eta/paru(51)+1d0))))
38917  phi=pyangl(p(i,1),p(i,2))
38918  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5d0*
38919  & (phi/paru(1)+1d0))))
38920  ietph=mstu(52)*ieta+iphi
38921 
38922 C...Add to cell already hit, or book new cell.
38923  DO 100 ic=n+1,nc
38924  IF(ietph.EQ.k(ic,3)) THEN
38925  k(ic,4)=k(ic,4)+1
38926  p(ic,5)=p(ic,5)+pt
38927  goto 110
38928  ENDIF
38929  100 CONTINUE
38930  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
38931  CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
38932  njet=-2
38933  RETURN
38934  ENDIF
38935  nc=nc+1
38936  k(nc,3)=ietph
38937  k(nc,4)=1
38938  k(nc,5)=2
38939  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
38940  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
38941  p(nc,5)=pt
38942  110 CONTINUE
38943 
38944 C...Smear true bin content by calorimeter resolution.
38945  IF(mstu(53).GE.1) THEN
38946  DO 130 ic=n+1,nc
38947  pei=p(ic,5)
38948  IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
38949  120 pef=pei+paru(55)*sqrt(-2d0*log(max(1d-10,pyr(0)))*pei)*
38950  & cos(paru(2)*pyr(0))
38951  IF(pef.LT.0d0.OR.pef.GT.paru(56)*pei) goto 120
38952  p(ic,5)=pef
38953  IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
38954  130 CONTINUE
38955  ENDIF
38956 
38957 C...Remove cells below threshold.
38958  IF(paru(58).GT.0d0) THEN
38959  ncc=nc
38960  nc=n
38961  DO 140 ic=n+1,ncc
38962  IF(p(ic,5).GT.paru(58)) THEN
38963  nc=nc+1
38964  k(nc,3)=k(ic,3)
38965  k(nc,4)=k(ic,4)
38966  k(nc,5)=k(ic,5)
38967  p(nc,1)=p(ic,1)
38968  p(nc,2)=p(ic,2)
38969  p(nc,5)=p(ic,5)
38970  ENDIF
38971  140 CONTINUE
38972  ENDIF
38973 
38974 C...Find initiator cell: the one with highest pT of not yet used ones.
38975  nj=nc
38976  150 etmax=0d0
38977  DO 160 ic=n+1,nc
38978  IF(k(ic,5).NE.2) goto 160
38979  IF(p(ic,5).LE.etmax) goto 160
38980  icmax=ic
38981  eta=p(ic,1)
38982  phi=p(ic,2)
38983  etmax=p(ic,5)
38984  160 CONTINUE
38985  IF(etmax.LT.paru(52)) goto 220
38986  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
38987  CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
38988  njet=-2
38989  RETURN
38990  ENDIF
38991  k(icmax,5)=1
38992  nj=nj+1
38993  k(nj,4)=0
38994  k(nj,5)=1
38995  p(nj,1)=eta
38996  p(nj,2)=phi
38997  p(nj,3)=0d0
38998  p(nj,4)=0d0
38999  p(nj,5)=0d0
39000 
39001 C...Sum up unused cells within required distance of initiator.
39002  DO 170 ic=n+1,nc
39003  IF(k(ic,5).EQ.0) goto 170
39004  IF(abs(p(ic,1)-eta).GT.paru(54)) goto 170
39005  dphia=abs(p(ic,2)-phi)
39006  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 170
39007  phic=p(ic,2)
39008  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
39009  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 170
39010  k(ic,5)=-k(ic,5)
39011  k(nj,4)=k(nj,4)+k(ic,4)
39012  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
39013  p(nj,4)=p(nj,4)+p(ic,5)*phic
39014  p(nj,5)=p(nj,5)+p(ic,5)
39015  170 CONTINUE
39016 
39017 C...Reject cluster below minimum ET, else accept.
39018  IF(p(nj,5).LT.paru(53)) THEN
39019  nj=nj-1
39020  DO 180 ic=n+1,nc
39021  IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
39022  180 CONTINUE
39023  ELSEIF(mstu(54).LE.2) THEN
39024  p(nj,3)=p(nj,3)/p(nj,5)
39025  p(nj,4)=p(nj,4)/p(nj,5)
39026  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
39027  & p(nj,4))
39028  DO 190 ic=n+1,nc
39029  IF(k(ic,5).LT.0) k(ic,5)=0
39030  190 CONTINUE
39031  ELSE
39032  DO 200 j=1,4
39033  p(nj,j)=0d0
39034  200 CONTINUE
39035  DO 210 ic=n+1,nc
39036  IF(k(ic,5).GE.0) goto 210
39037  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
39038  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
39039  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
39040  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
39041  k(ic,5)=0
39042  210 CONTINUE
39043  ENDIF
39044  goto 150
39045 
39046 C...Arrange clusters in falling ET sequence.
39047  220 DO 250 i=1,nj-nc
39048  etmax=0d0
39049  DO 230 ij=nc+1,nj
39050  IF(k(ij,5).EQ.0) goto 230
39051  IF(p(ij,5).LT.etmax) goto 230
39052  ijmax=ij
39053  etmax=p(ij,5)
39054  230 CONTINUE
39055  k(ijmax,5)=0
39056  k(n+i,1)=31
39057  k(n+i,2)=98
39058  k(n+i,3)=i
39059  k(n+i,4)=k(ijmax,4)
39060  k(n+i,5)=0
39061  DO 240 j=1,5
39062  p(n+i,j)=p(ijmax,j)
39063  v(n+i,j)=0d0
39064  240 CONTINUE
39065  250 CONTINUE
39066  njet=nj-nc
39067 
39068 C...Convert to massless or massive four-vectors.
39069  IF(mstu(54).EQ.2) THEN
39070  DO 260 i=n+1,n+njet
39071  eta=p(i,3)
39072  p(i,1)=p(i,5)*cos(p(i,4))
39073  p(i,2)=p(i,5)*sin(p(i,4))
39074  p(i,3)=p(i,5)*sinh(eta)
39075  p(i,4)=p(i,5)*cosh(eta)
39076  p(i,5)=0d0
39077  260 CONTINUE
39078  ELSEIF(mstu(54).GE.3) THEN
39079  DO 270 i=n+1,n+njet
39080  p(i,5)=sqrt(max(0d0,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
39081  270 CONTINUE
39082  ENDIF
39083 
39084 C...Information about storage.
39085  mstu(61)=n+1
39086  mstu(62)=np
39087  mstu(63)=nc-n
39088  IF(mstu(43).LE.1) mstu(3)=njet
39089  IF(mstu(43).GE.2) n=n+njet
39090 
39091  RETURN
39092  END
39093 
39094 C*********************************************************************
39095 
39096 C...PYJMAS
39097 C...Determines, approximately, the two jet masses that minimize
39098 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
39099 
39100  SUBROUTINE pyjmas(PMH,PML)
39101 
39102 C...Double precision and integer declarations.
39103  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39104  INTEGER pyk,pychge,pycomp
39105 C...Commonblocks.
39106  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
39107  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39108  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39109  SAVE /pyjets/,/pydat1/,/pydat2/
39110 C...Local arrays.
39111  dimension sm(3,3),sax(3),ps(3,5)
39112 
39113 C...Reset.
39114  np=0
39115  DO 120 j1=1,3
39116  DO 100 j2=j1,3
39117  sm(j1,j2)=0d0
39118  100 CONTINUE
39119  DO 110 j2=1,4
39120  ps(j1,j2)=0d0
39121  110 CONTINUE
39122  120 CONTINUE
39123  pss=0d0
39124  pimass=pmas(pycomp(211),1)
39125 
39126 C...Take copy of particles that are to be considered in mass analysis.
39127  DO 170 i=1,n
39128  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
39129  IF(mstu(41).GE.2) THEN
39130  kc=pycomp(k(i,2))
39131  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
39132  & kc.EQ.18) goto 170
39133  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
39134  & goto 170
39135  ENDIF
39136  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
39137  CALL pyerrm(11,'(PYJMAS:) no more memory left in PYJETS')
39138  pmh=-2d0
39139  pml=-2d0
39140  RETURN
39141  ENDIF
39142  np=np+1
39143  DO 130 j=1,5
39144  p(n+np,j)=p(i,j)
39145  130 CONTINUE
39146  IF(mstu(42).EQ.0) p(n+np,5)=0d0
39147  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
39148  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
39149 
39150 C...Fill information in sphericity tensor and total momentum vector.
39151  DO 150 j1=1,3
39152  DO 140 j2=j1,3
39153  sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
39154  140 CONTINUE
39155  150 CONTINUE
39156  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
39157  DO 160 j=1,4
39158  ps(3,j)=ps(3,j)+p(n+np,j)
39159  160 CONTINUE
39160  170 CONTINUE
39161 
39162 C...Very low multiplicities (0 or 1) not considered.
39163  IF(np.LE.1) THEN
39164  CALL pyerrm(8,'(PYJMAS:) too few particles for analysis')
39165  pmh=-1d0
39166  pml=-1d0
39167  RETURN
39168  ENDIF
39169  paru(61)=sqrt(max(0d0,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-
39170  &ps(3,3)**2))
39171 
39172 C...Find largest eigenvalue to matrix (third degree equation).
39173  DO 190 j1=1,3
39174  DO 180 j2=j1,3
39175  sm(j1,j2)=sm(j1,j2)/pss
39176  180 CONTINUE
39177  190 CONTINUE
39178  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
39179  &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
39180  sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
39181  &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
39182  &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
39183  sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
39184  sma=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
39185 
39186 C...Find largest eigenvector by solving equation system.
39187  DO 210 j1=1,3
39188  sm(j1,j1)=sm(j1,j1)-sma
39189  DO 200 j2=j1+1,3
39190  sm(j2,j1)=sm(j1,j2)
39191  200 CONTINUE
39192  210 CONTINUE
39193  smax=0d0
39194  DO 230 j1=1,3
39195  DO 220 j2=1,3
39196  IF(abs(sm(j1,j2)).LE.smax) goto 220
39197  ja=j1
39198  jb=j2
39199  smax=abs(sm(j1,j2))
39200  220 CONTINUE
39201  230 CONTINUE
39202  smax=0d0
39203  DO 250 j3=ja+1,ja+2
39204  j1=j3-3*((j3-1)/3)
39205  rl=sm(j1,jb)/sm(ja,jb)
39206  DO 240 j2=1,3
39207  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
39208  IF(abs(sm(j1,j2)).LE.smax) goto 240
39209  jc=j1
39210  smax=abs(sm(j1,j2))
39211  240 CONTINUE
39212  250 CONTINUE
39213  jb1=jb+1-3*(jb/3)
39214  jb2=jb+2-3*((jb+1)/3)
39215  sax(jb1)=-sm(jc,jb2)
39216  sax(jb2)=sm(jc,jb1)
39217  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
39218 
39219 C...Divide particles into two initial clusters by hemisphere.
39220  DO 270 i=n+1,n+np
39221  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
39222  is=1
39223  IF(psax.LT.0d0) is=2
39224  k(i,3)=is
39225  DO 260 j=1,4
39226  ps(is,j)=ps(is,j)+p(i,j)
39227  260 CONTINUE
39228  270 CONTINUE
39229  pms=max(1d-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
39230  &max(1d-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
39231 
39232 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
39233  280 pmd=0d0
39234  im=0
39235  DO 290 j=1,4
39236  ps(3,j)=ps(1,j)-ps(2,j)
39237  290 CONTINUE
39238  DO 300 i=n+1,n+np
39239  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)
39240  IF(k(i,3).EQ.1) pmdi=2d0*(p(i,5)**2-pps)
39241  IF(k(i,3).EQ.2) pmdi=2d0*(p(i,5)**2+pps)
39242  IF(pmdi.LT.pmd) THEN
39243  pmd=pmdi
39244  im=i
39245  ENDIF
39246  300 CONTINUE
39247 
39248 C...Loop back if significant reduction in sum of m^2.
39249  IF(pmd.LT.-paru(48)*pms) THEN
39250  pms=pms+pmd
39251  is=k(im,3)
39252  DO 310 j=1,4
39253  ps(is,j)=ps(is,j)-p(im,j)
39254  ps(3-is,j)=ps(3-is,j)+p(im,j)
39255  310 CONTINUE
39256  k(im,3)=3-is
39257  goto 280
39258  ENDIF
39259 
39260 C...Final masses and output.
39261  mstu(61)=n+1
39262  mstu(62)=np
39263  ps(1,5)=sqrt(max(0d0,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
39264  ps(2,5)=sqrt(max(0d0,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
39265  pmh=max(ps(1,5),ps(2,5))
39266  pml=min(ps(1,5),ps(2,5))
39267 
39268  RETURN
39269  END
39270 
39271 C*********************************************************************
39272 
39273 C...PYFOWO
39274 C...Calculates the first few Fox-Wolfram moments.
39275 
39276  SUBROUTINE pyfowo(H10,H20,H30,H40)
39277 
39278 C...Double precision and integer declarations.
39279  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39280  INTEGER pyk,pychge,pycomp
39281 C...Commonblocks.
39282  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
39283  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39284  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39285  SAVE /pyjets/,/pydat1/,/pydat2/
39286 
39287 C...Copy momenta for particles and calculate H0.
39288  np=0
39289  h0=0d0
39290  hd=0d0
39291  DO 110 i=1,n
39292  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
39293  IF(mstu(41).GE.2) THEN
39294  kc=pycomp(k(i,2))
39295  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
39296  & kc.EQ.18) goto 110
39297  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
39298  & goto 110
39299  ENDIF
39300  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
39301  CALL pyerrm(11,'(PYFOWO:) no more memory left in PYJETS')
39302  h10=-1d0
39303  h20=-1d0
39304  h30=-1d0
39305  h40=-1d0
39306  RETURN
39307  ENDIF
39308  np=np+1
39309  DO 100 j=1,3
39310  p(n+np,j)=p(i,j)
39311  100 CONTINUE
39312  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
39313  h0=h0+p(n+np,4)
39314  hd=hd+p(n+np,4)**2
39315  110 CONTINUE
39316  h0=h0**2
39317 
39318 C...Very low multiplicities (0 or 1) not considered.
39319  IF(np.LE.1) THEN
39320  CALL pyerrm(8,'(PYFOWO:) too few particles for analysis')
39321  h10=-1d0
39322  h20=-1d0
39323  h30=-1d0
39324  h40=-1d0
39325  RETURN
39326  ENDIF
39327 
39328 C...Calculate H1 - H4.
39329  h10=0d0
39330  h20=0d0
39331  h30=0d0
39332  h40=0d0
39333  DO 130 i1=n+1,n+np
39334  DO 120 i2=i1+1,n+np
39335  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
39336  & (p(i1,4)*p(i2,4))
39337  h10=h10+p(i1,4)*p(i2,4)*cthe
39338  h20=h20+p(i1,4)*p(i2,4)*(1.5d0*cthe**2-0.5d0)
39339  h30=h30+p(i1,4)*p(i2,4)*(2.5d0*cthe**3-1.5d0*cthe)
39340  h40=h40+p(i1,4)*p(i2,4)*(4.375d0*cthe**4-3.75d0*cthe**2+
39341  & 0.375d0)
39342  120 CONTINUE
39343  130 CONTINUE
39344 
39345 C...Calculate H1/H0 - H4/H0. Output.
39346  mstu(61)=n+1
39347  mstu(62)=np
39348  h10=(hd+2d0*h10)/h0
39349  h20=(hd+2d0*h20)/h0
39350  h30=(hd+2d0*h30)/h0
39351  h40=(hd+2d0*h40)/h0
39352 
39353  RETURN
39354  END
39355 
39356 C*********************************************************************
39357 
39358 C...PYTABU
39359 C...Evaluates various properties of an event, with statistics
39360 C...accumulated during the course of the run and
39361 C...printed at the end.
39362 
39363  SUBROUTINE pytabu(MTABU)
39364 
39365 C...Double precision and integer declarations.
39366  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39367  INTEGER pyk,pychge,pycomp
39368 C...Commonblocks.
39369  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
39370  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39371  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39372  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
39373  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
39374 C...Local arrays, character variables, saved variables and data.
39375  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
39376  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
39377  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
39378  &kfdm(8),kfdc(200,0:8),npdc(200)
39379  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
39380  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
39381  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
39382  CHARACTER chau*16,chis(2)*12,chdc(8)*12
39383  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
39384  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0d0/,fm2fm/120*0d0/,
39385  &nevee/0/,fe1ec/50*0d0/,fe2ec/50*0d0/,fe1ea/25*0d0/,fe2ea/25*0d0/,
39386  &nevdc/0/,nkfdc/0/,nredc/0/
39387 
39388 C...Reset statistics on initial parton state.
39389  IF(mtabu.EQ.10) THEN
39390  nevis=0
39391  nkfis=0
39392 
39393 C...Identify and order flavour content of initial state.
39394  ELSEIF(mtabu.EQ.11) THEN
39395  nevis=nevis+1
39396  kfm1=2*iabs(mstu(161))
39397  IF(mstu(161).GT.0) kfm1=kfm1-1
39398  kfm2=2*iabs(mstu(162))
39399  IF(mstu(162).GT.0) kfm2=kfm2-1
39400  kfmn=min(kfm1,kfm2)
39401  kfmx=max(kfm1,kfm2)
39402  DO 100 i=1,nkfis
39403  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
39404  ikfis=-i
39405  goto 110
39406  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
39407  & kfmx.LT.kfis(i,2))) THEN
39408  ikfis=i
39409  goto 110
39410  ENDIF
39411  100 CONTINUE
39412  ikfis=nkfis+1
39413  110 IF(ikfis.LT.0) THEN
39414  ikfis=-ikfis
39415  ELSE
39416  IF(nkfis.GE.100) RETURN
39417  DO 130 i=nkfis,ikfis,-1
39418  kfis(i+1,1)=kfis(i,1)
39419  kfis(i+1,2)=kfis(i,2)
39420  DO 120 j=0,10
39421  npis(i+1,j)=npis(i,j)
39422  120 CONTINUE
39423  130 CONTINUE
39424  nkfis=nkfis+1
39425  kfis(ikfis,1)=kfmn
39426  kfis(ikfis,2)=kfmx
39427  DO 140 j=0,10
39428  npis(ikfis,j)=0
39429  140 CONTINUE
39430  ENDIF
39431  npis(ikfis,0)=npis(ikfis,0)+1
39432 
39433 C...Count number of partons in initial state.
39434  np=0
39435  DO 160 i=1,n
39436  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
39437  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
39438  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
39439  & THEN
39440  ELSE
39441  im=i
39442  150 im=k(im,3)
39443  IF(im.LE.0.OR.im.GT.n) THEN
39444  np=np+1
39445  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
39446  np=np+1
39447  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
39448  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10)
39449  & .NE.0) THEN
39450  ELSE
39451  goto 150
39452  ENDIF
39453  ENDIF
39454  160 CONTINUE
39455  npco=max(np,1)
39456  IF(np.GE.6) npco=6
39457  IF(np.GE.8) npco=7
39458  IF(np.GE.11) npco=8
39459  IF(np.GE.16) npco=9
39460  IF(np.GE.26) npco=10
39461  npis(ikfis,npco)=npis(ikfis,npco)+1
39462  mstu(62)=np
39463 
39464 C...Write statistics on initial parton state.
39465  ELSEIF(mtabu.EQ.12) THEN
39466  fac=1d0/max(1,nevis)
39467  WRITE(mstu(11),5000) nevis
39468  DO 170 i=1,nkfis
39469  kfmn=kfis(i,1)
39470  IF(kfmn.EQ.0) kfmn=kfis(i,2)
39471  kfm1=(kfmn+1)/2
39472  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
39473  CALL pyname(kfm1,chau)
39474  chis(1)=chau(1:12)
39475  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
39476  kfmx=kfis(i,2)
39477  IF(kfis(i,1).EQ.0) kfmx=0
39478  kfm2=(kfmx+1)/2
39479  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
39480  CALL pyname(kfm2,chau)
39481  chis(2)=chau(1:12)
39482  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
39483  WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
39484  & (npis(i,j)/dble(npis(i,0)),j=1,10)
39485  170 CONTINUE
39486 
39487 C...Copy statistics on initial parton state into /PYJETS/.
39488  ELSEIF(mtabu.EQ.13) THEN
39489  fac=1d0/max(1,nevis)
39490  DO 190 i=1,nkfis
39491  kfmn=kfis(i,1)
39492  IF(kfmn.EQ.0) kfmn=kfis(i,2)
39493  kfm1=(kfmn+1)/2
39494  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
39495  kfmx=kfis(i,2)
39496  IF(kfis(i,1).EQ.0) kfmx=0
39497  kfm2=(kfmx+1)/2
39498  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
39499  k(i,1)=32
39500  k(i,2)=99
39501  k(i,3)=kfm1
39502  k(i,4)=kfm2
39503  k(i,5)=npis(i,0)
39504  DO 180 j=1,5
39505  p(i,j)=fac*npis(i,j)
39506  v(i,j)=fac*npis(i,j+5)
39507  180 CONTINUE
39508  190 CONTINUE
39509  n=nkfis
39510  DO 200 j=1,5
39511  k(n+1,j)=0
39512  p(n+1,j)=0d0
39513  v(n+1,j)=0d0
39514  200 CONTINUE
39515  k(n+1,1)=32
39516  k(n+1,2)=99
39517  k(n+1,5)=nevis
39518  mstu(3)=1
39519 
39520 C...Reset statistics on number of particles/partons.
39521  ELSEIF(mtabu.EQ.20) THEN
39522  nevfs=0
39523  nprfs=0
39524  nfifs=0
39525  nchfs=0
39526  nkffs=0
39527 
39528 C...Identify whether particle/parton is primary or not.
39529  ELSEIF(mtabu.EQ.21) THEN
39530  nevfs=nevfs+1
39531  mstu(62)=0
39532  DO 260 i=1,n
39533  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 260
39534  mstu(62)=mstu(62)+1
39535  kc=pycomp(k(i,2))
39536  mpri=0
39537  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
39538  mpri=1
39539  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
39540  mpri=1
39541  ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
39542  mpri=1
39543  ELSEIF(kc.EQ.0) THEN
39544  ELSEIF(k(k(i,3),1).EQ.13) THEN
39545  im=k(k(i,3),3)
39546  IF(im.LE.0.OR.im.GT.n) THEN
39547  mpri=1
39548  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
39549  mpri=1
39550  ENDIF
39551  ELSEIF(kchg(kc,2).EQ.0) THEN
39552  kcm=pycomp(k(k(i,3),2))
39553  IF(kcm.NE.0) THEN
39554  IF(kchg(kcm,2).NE.0) mpri=1
39555  ENDIF
39556  ENDIF
39557  IF(kc.NE.0.AND.mpri.EQ.1) THEN
39558  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
39559  ENDIF
39560  IF(k(i,1).LE.10) THEN
39561  nfifs=nfifs+1
39562  IF(pychge(k(i,2)).NE.0) nchfs=nchfs+1
39563  ENDIF
39564 
39565 C...Fill statistics on number of particles/partons in event.
39566  kfa=iabs(k(i,2))
39567  kfs=3-isign(1,k(i,2))-mpri
39568  DO 210 ip=1,nkffs
39569  IF(kfa.EQ.kffs(ip)) THEN
39570  ikffs=-ip
39571  goto 220
39572  ELSEIF(kfa.LT.kffs(ip)) THEN
39573  ikffs=ip
39574  goto 220
39575  ENDIF
39576  210 CONTINUE
39577  ikffs=nkffs+1
39578  220 IF(ikffs.LT.0) THEN
39579  ikffs=-ikffs
39580  ELSE
39581  IF(nkffs.GE.400) RETURN
39582  DO 240 ip=nkffs,ikffs,-1
39583  kffs(ip+1)=kffs(ip)
39584  DO 230 j=1,4
39585  npfs(ip+1,j)=npfs(ip,j)
39586  230 CONTINUE
39587  240 CONTINUE
39588  nkffs=nkffs+1
39589  kffs(ikffs)=kfa
39590  DO 250 j=1,4
39591  npfs(ikffs,j)=0
39592  250 CONTINUE
39593  ENDIF
39594  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
39595  260 CONTINUE
39596 
39597 C...Write statistics on particle/parton composition of events.
39598  ELSEIF(mtabu.EQ.22) THEN
39599  fac=1d0/max(1,nevfs)
39600  WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
39601  DO 270 i=1,nkffs
39602  CALL pyname(kffs(i),chau)
39603  kc=pycomp(kffs(i))
39604  mdcyf=0
39605  IF(kc.NE.0) mdcyf=mdcy(kc,1)
39606  WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
39607  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
39608  270 CONTINUE
39609 
39610 C...Copy particle/parton composition information into /PYJETS/.
39611  ELSEIF(mtabu.EQ.23) THEN
39612  fac=1d0/max(1,nevfs)
39613  DO 290 i=1,nkffs
39614  k(i,1)=32
39615  k(i,2)=99
39616  k(i,3)=kffs(i)
39617  k(i,4)=0
39618  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
39619  DO 280 j=1,4
39620  p(i,j)=fac*npfs(i,j)
39621  v(i,j)=0d0
39622  280 CONTINUE
39623  p(i,5)=fac*k(i,5)
39624  v(i,5)=0d0
39625  290 CONTINUE
39626  n=nkffs
39627  DO 300 j=1,5
39628  k(n+1,j)=0
39629  p(n+1,j)=0d0
39630  v(n+1,j)=0d0
39631  300 CONTINUE
39632  k(n+1,1)=32
39633  k(n+1,2)=99
39634  k(n+1,5)=nevfs
39635  p(n+1,1)=fac*nprfs
39636  p(n+1,2)=fac*nfifs
39637  p(n+1,3)=fac*nchfs
39638  mstu(3)=1
39639 
39640 C...Reset factorial moments statistics.
39641  ELSEIF(mtabu.EQ.30) THEN
39642  nevfm=0
39643  nmufm=0
39644  DO 330 im=1,3
39645  DO 320 ib=1,10
39646  DO 310 ip=1,4
39647  fm1fm(im,ib,ip)=0d0
39648  fm2fm(im,ib,ip)=0d0
39649  310 CONTINUE
39650  320 CONTINUE
39651  330 CONTINUE
39652 
39653 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
39654  ELSEIF(mtabu.EQ.31) THEN
39655  nevfm=nevfm+1
39656  nlow=n+mstu(3)
39657  nupp=nlow
39658  DO 410 i=1,n
39659  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 410
39660  IF(mstu(41).GE.2) THEN
39661  kc=pycomp(k(i,2))
39662  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
39663  & kc.EQ.18) goto 410
39664  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
39665  & pychge(k(i,2)).EQ.0) goto 410
39666  ENDIF
39667  pmr=0d0
39668  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
39669  IF(mstu(42).GE.2) pmr=p(i,5)
39670  pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
39671  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
39672  & 1d20)),p(i,3))
39673  IF(abs(yeta).GT.paru(57)) goto 410
39674  phi=pyangl(p(i,1),p(i,2))
39675  iyeta=512d0*(yeta+paru(57))/(2d0*paru(57))
39676  iyeta=max(0,min(511,iyeta))
39677  iphi=512d0*(phi+paru(1))/paru(2)
39678  iphi=max(0,min(511,iphi))
39679  iyep=0
39680  DO 340 ib=0,9
39681  iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
39682  340 CONTINUE
39683 
39684 C...Order particles in (pseudo)rapidity and/or azimuth.
39685  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
39686  CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
39687  RETURN
39688  ENDIF
39689  nupp=nupp+1
39690  IF(nupp.EQ.nlow+1) THEN
39691  k(nupp,1)=iyeta
39692  k(nupp,2)=iphi
39693  k(nupp,3)=iyep
39694  ELSE
39695  DO 350 i1=nupp-1,nlow+1,-1
39696  IF(iyeta.GE.k(i1,1)) goto 360
39697  k(i1+1,1)=k(i1,1)
39698  350 CONTINUE
39699  360 k(i1+1,1)=iyeta
39700  DO 370 i1=nupp-1,nlow+1,-1
39701  IF(iphi.GE.k(i1,2)) goto 380
39702  k(i1+1,2)=k(i1,2)
39703  370 CONTINUE
39704  380 k(i1+1,2)=iphi
39705  DO 390 i1=nupp-1,nlow+1,-1
39706  IF(iyep.GE.k(i1,3)) goto 400
39707  k(i1+1,3)=k(i1,3)
39708  390 CONTINUE
39709  400 k(i1+1,3)=iyep
39710  ENDIF
39711  410 CONTINUE
39712  k(nupp+1,1)=2**10
39713  k(nupp+1,2)=2**10
39714  k(nupp+1,3)=4**10
39715 
39716 C...Calculate sum of factorial moments in event.
39717  DO 480 im=1,3
39718  DO 430 ib=1,10
39719  DO 420 ip=1,4
39720  fevfm(ib,ip)=0d0
39721  420 CONTINUE
39722  430 CONTINUE
39723  DO 450 ib=1,10
39724  IF(im.LE.2) ibin=2**(10-ib)
39725  IF(im.EQ.3) ibin=4**(10-ib)
39726  iagr=k(nlow+1,im)/ibin
39727  nagr=1
39728  DO 440 i=nlow+2,nupp+1
39729  icut=k(i,im)/ibin
39730  IF(icut.EQ.iagr) THEN
39731  nagr=nagr+1
39732  ELSE
39733  IF(nagr.EQ.1) THEN
39734  ELSEIF(nagr.EQ.2) THEN
39735  fevfm(ib,1)=fevfm(ib,1)+2d0
39736  ELSEIF(nagr.EQ.3) THEN
39737  fevfm(ib,1)=fevfm(ib,1)+6d0
39738  fevfm(ib,2)=fevfm(ib,2)+6d0
39739  ELSEIF(nagr.EQ.4) THEN
39740  fevfm(ib,1)=fevfm(ib,1)+12d0
39741  fevfm(ib,2)=fevfm(ib,2)+24d0
39742  fevfm(ib,3)=fevfm(ib,3)+24d0
39743  ELSE
39744  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1d0)
39745  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1d0)*(nagr-2d0)
39746  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1d0)*(nagr-2d0)*
39747  & (nagr-3d0)
39748  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1d0)*(nagr-2d0)*
39749  & (nagr-3d0)*(nagr-4d0)
39750  ENDIF
39751  iagr=icut
39752  nagr=1
39753  ENDIF
39754  440 CONTINUE
39755  450 CONTINUE
39756 
39757 C...Add results to total statistics.
39758  DO 470 ib=10,1,-1
39759  DO 460 ip=1,4
39760  IF(fevfm(1,ip).LT.0.5d0) THEN
39761  fevfm(ib,ip)=0d0
39762  ELSEIF(im.LE.2) THEN
39763  fevfm(ib,ip)=2d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
39764  ELSE
39765  fevfm(ib,ip)=4d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
39766  ENDIF
39767  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
39768  fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
39769  460 CONTINUE
39770  470 CONTINUE
39771  480 CONTINUE
39772  nmufm=nmufm+(nupp-nlow)
39773  mstu(62)=nupp-nlow
39774 
39775 C...Write accumulated statistics on factorial moments.
39776  ELSEIF(mtabu.EQ.32) THEN
39777  fac=1d0/max(1,nevfm)
39778  IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
39779  IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
39780  IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
39781  DO 510 im=1,3
39782  WRITE(mstu(11),5500)
39783  DO 500 ib=1,10
39784  byeta=2d0*paru(57)
39785  IF(im.NE.2) byeta=byeta/2**(ib-1)
39786  bphi=paru(2)
39787  IF(im.NE.1) bphi=bphi/2**(ib-1)
39788  IF(im.LE.2) bnave=fac*nmufm/dble(2**(ib-1))
39789  IF(im.EQ.3) bnave=fac*nmufm/dble(4**(ib-1))
39790  DO 490 ip=1,4
39791  fmoma(ip)=fac*fm1fm(im,ib,ip)
39792  fmoms(ip)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
39793  & fmoma(ip)**2)))
39794  490 CONTINUE
39795  WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
39796  & ip=1,4)
39797  500 CONTINUE
39798  510 CONTINUE
39799 
39800 C...Copy statistics on factorial moments into /PYJETS/.
39801  ELSEIF(mtabu.EQ.33) THEN
39802  fac=1d0/max(1,nevfm)
39803  DO 540 im=1,3
39804  DO 530 ib=1,10
39805  i=10*(im-1)+ib
39806  k(i,1)=32
39807  k(i,2)=99
39808  k(i,3)=1
39809  IF(im.NE.2) k(i,3)=2**(ib-1)
39810  k(i,4)=1
39811  IF(im.NE.1) k(i,4)=2**(ib-1)
39812  k(i,5)=0
39813  p(i,1)=2d0*paru(57)/k(i,3)
39814  v(i,1)=paru(2)/k(i,4)
39815  DO 520 ip=1,4
39816  p(i,ip+1)=fac*fm1fm(im,ib,ip)
39817  v(i,ip+1)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
39818  & p(i,ip+1)**2)))
39819  520 CONTINUE
39820  530 CONTINUE
39821  540 CONTINUE
39822  n=30
39823  DO 550 j=1,5
39824  k(n+1,j)=0
39825  p(n+1,j)=0d0
39826  v(n+1,j)=0d0
39827  550 CONTINUE
39828  k(n+1,1)=32
39829  k(n+1,2)=99
39830  k(n+1,5)=nevfm
39831  mstu(3)=1
39832 
39833 C...Reset statistics on Energy-Energy Correlation.
39834  ELSEIF(mtabu.EQ.40) THEN
39835  nevee=0
39836  DO 560 j=1,25
39837  fe1ec(j)=0d0
39838  fe2ec(j)=0d0
39839  fe1ec(51-j)=0d0
39840  fe2ec(51-j)=0d0
39841  fe1ea(j)=0d0
39842  fe2ea(j)=0d0
39843  560 CONTINUE
39844 
39845 C...Find particles to include, with proper assumed mass.
39846  ELSEIF(mtabu.EQ.41) THEN
39847  nevee=nevee+1
39848  nlow=n+mstu(3)
39849  nupp=nlow
39850  ecm=0d0
39851  DO 570 i=1,n
39852  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 570
39853  IF(mstu(41).GE.2) THEN
39854  kc=pycomp(k(i,2))
39855  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
39856  & kc.EQ.18) goto 570
39857  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
39858  & pychge(k(i,2)).EQ.0) goto 570
39859  ENDIF
39860  pmr=0d0
39861  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
39862  IF(mstu(42).GE.2) pmr=p(i,5)
39863  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
39864  CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
39865  RETURN
39866  ENDIF
39867  nupp=nupp+1
39868  p(nupp,1)=p(i,1)
39869  p(nupp,2)=p(i,2)
39870  p(nupp,3)=p(i,3)
39871  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
39872  p(nupp,5)=max(1d-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
39873  ecm=ecm+p(nupp,4)
39874  570 CONTINUE
39875  IF(nupp.EQ.nlow) RETURN
39876 
39877 C...Analyze Energy-Energy Correlation in event.
39878  fac=(2d0/ecm**2)*50d0/paru(1)
39879  DO 580 j=1,50
39880  fevee(j)=0d0
39881  580 CONTINUE
39882  DO 600 i1=nlow+2,nupp
39883  DO 590 i2=nlow+1,i1-1
39884  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
39885  & (p(i1,5)*p(i2,5))
39886  the=acos(max(-1d0,min(1d0,cthe)))
39887  ithe=max(1,min(50,1+int(50d0*the/paru(1))))
39888  fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
39889  590 CONTINUE
39890  600 CONTINUE
39891  DO 610 j=1,25
39892  fe1ec(j)=fe1ec(j)+fevee(j)
39893  fe2ec(j)=fe2ec(j)+fevee(j)**2
39894  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
39895  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
39896  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
39897  fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
39898  610 CONTINUE
39899  mstu(62)=nupp-nlow
39900 
39901 C...Write statistics on Energy-Energy Correlation.
39902  ELSEIF(mtabu.EQ.42) THEN
39903  fac=1d0/max(1,nevee)
39904  WRITE(mstu(11),5700) nevee
39905  DO 620 j=1,25
39906  feec1=fac*fe1ec(j)
39907  fees1=sqrt(max(0d0,fac*(fac*fe2ec(j)-feec1**2)))
39908  feec2=fac*fe1ec(51-j)
39909  fees2=sqrt(max(0d0,fac*(fac*fe2ec(51-j)-feec2**2)))
39910  feeca=fac*fe1ea(j)
39911  feesa=sqrt(max(0d0,fac*(fac*fe2ea(j)-feeca**2)))
39912  WRITE(mstu(11),5800) 3.6d0*(j-1),3.6d0*j,feec1,fees1,
39913  & feec2,fees2,feeca,feesa
39914  620 CONTINUE
39915 
39916 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
39917  ELSEIF(mtabu.EQ.43) THEN
39918  fac=1d0/max(1,nevee)
39919  DO 630 i=1,25
39920  k(i,1)=32
39921  k(i,2)=99
39922  k(i,3)=0
39923  k(i,4)=0
39924  k(i,5)=0
39925  p(i,1)=fac*fe1ec(i)
39926  v(i,1)=sqrt(max(0d0,fac*(fac*fe2ec(i)-p(i,1)**2)))
39927  p(i,2)=fac*fe1ec(51-i)
39928  v(i,2)=sqrt(max(0d0,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
39929  p(i,3)=fac*fe1ea(i)
39930  v(i,3)=sqrt(max(0d0,fac*(fac*fe2ea(i)-p(i,3)**2)))
39931  p(i,4)=paru(1)*(i-1)/50d0
39932  p(i,5)=paru(1)*i/50d0
39933  v(i,4)=3.6d0*(i-1)
39934  v(i,5)=3.6d0*i
39935  630 CONTINUE
39936  n=25
39937  DO 640 j=1,5
39938  k(n+1,j)=0
39939  p(n+1,j)=0d0
39940  v(n+1,j)=0d0
39941  640 CONTINUE
39942  k(n+1,1)=32
39943  k(n+1,2)=99
39944  k(n+1,5)=nevee
39945  mstu(3)=1
39946 
39947 C...Reset statistics on decay channels.
39948  ELSEIF(mtabu.EQ.50) THEN
39949  nevdc=0
39950  nkfdc=0
39951  nredc=0
39952 
39953 C...Identify and order flavour content of final state.
39954  ELSEIF(mtabu.EQ.51) THEN
39955  nevdc=nevdc+1
39956  nds=0
39957  DO 670 i=1,n
39958  IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 670
39959  nds=nds+1
39960  IF(nds.GT.8) THEN
39961  nredc=nredc+1
39962  RETURN
39963  ENDIF
39964  kfm=2*iabs(k(i,2))
39965  IF(k(i,2).LT.0) kfm=kfm-1
39966  DO 650 ids=nds-1,1,-1
39967  iin=ids+1
39968  IF(kfm.LT.kfdm(ids)) goto 660
39969  kfdm(ids+1)=kfdm(ids)
39970  650 CONTINUE
39971  iin=1
39972  660 kfdm(iin)=kfm
39973  670 CONTINUE
39974 
39975 C...Find whether old or new final state.
39976  DO 690 idc=1,nkfdc
39977  IF(nds.LT.kfdc(idc,0)) THEN
39978  ikfdc=idc
39979  goto 700
39980  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
39981  DO 680 i=1,nds
39982  IF(kfdm(i).LT.kfdc(idc,i)) THEN
39983  ikfdc=idc
39984  goto 700
39985  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
39986  goto 690
39987  ENDIF
39988  680 CONTINUE
39989  ikfdc=-idc
39990  goto 700
39991  ENDIF
39992  690 CONTINUE
39993  ikfdc=nkfdc+1
39994  700 IF(ikfdc.LT.0) THEN
39995  ikfdc=-ikfdc
39996  ELSEIF(nkfdc.GE.200) THEN
39997  nredc=nredc+1
39998  RETURN
39999  ELSE
40000  DO 720 idc=nkfdc,ikfdc,-1
40001  npdc(idc+1)=npdc(idc)
40002  DO 710 i=0,8
40003  kfdc(idc+1,i)=kfdc(idc,i)
40004  710 CONTINUE
40005  720 CONTINUE
40006  nkfdc=nkfdc+1
40007  kfdc(ikfdc,0)=nds
40008  DO 730 i=1,nds
40009  kfdc(ikfdc,i)=kfdm(i)
40010  730 CONTINUE
40011  npdc(ikfdc)=0
40012  ENDIF
40013  npdc(ikfdc)=npdc(ikfdc)+1
40014 
40015 C...Write statistics on decay channels.
40016  ELSEIF(mtabu.EQ.52) THEN
40017  fac=1d0/max(1,nevdc)
40018  WRITE(mstu(11),5900) nevdc
40019  DO 750 idc=1,nkfdc
40020  DO 740 i=1,kfdc(idc,0)
40021  kfm=kfdc(idc,i)
40022  kf=(kfm+1)/2
40023  IF(2*kf.NE.kfm) kf=-kf
40024  CALL pyname(kf,chau)
40025  chdc(i)=chau(1:12)
40026  IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
40027  740 CONTINUE
40028  WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
40029  750 CONTINUE
40030  IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
40031 
40032 C...Copy statistics on decay channels into /PYJETS/.
40033  ELSEIF(mtabu.EQ.53) THEN
40034  fac=1d0/max(1,nevdc)
40035  DO 780 idc=1,nkfdc
40036  k(idc,1)=32
40037  k(idc,2)=99
40038  k(idc,3)=0
40039  k(idc,4)=0
40040  k(idc,5)=kfdc(idc,0)
40041  DO 760 j=1,5
40042  p(idc,j)=0d0
40043  v(idc,j)=0d0
40044  760 CONTINUE
40045  DO 770 i=1,kfdc(idc,0)
40046  kfm=kfdc(idc,i)
40047  kf=(kfm+1)/2
40048  IF(2*kf.NE.kfm) kf=-kf
40049  IF(i.LE.5) p(idc,i)=kf
40050  IF(i.GE.6) v(idc,i-5)=kf
40051  770 CONTINUE
40052  v(idc,5)=fac*npdc(idc)
40053  780 CONTINUE
40054  n=nkfdc
40055  DO 790 j=1,5
40056  k(n+1,j)=0
40057  p(n+1,j)=0d0
40058  v(n+1,j)=0d0
40059  790 CONTINUE
40060  k(n+1,1)=32
40061  k(n+1,2)=99
40062  k(n+1,5)=nevdc
40063  v(n+1,5)=fac*nredc
40064  mstu(3)=1
40065  ENDIF
40066 
40067 C...Format statements for output on unit MSTU(11) (default 6).
40068  5000 FORMAT(///20x,'Event statistics - initial state'/
40069  &20x,'based on an analysis of ',i6,' events'//
40070  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
40071  &'according to fragmenting system multiplicity'/
40072  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
40073  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
40074  5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
40075  5200 FORMAT(///20x,'Event statistics - final state'/
40076  &20x,'based on an analysis of ',i7,' events'//
40077  &5x,'Mean primary multiplicity =',f10.4/
40078  &5x,'Mean final multiplicity =',f10.4/
40079  &5x,'Mean charged multiplicity =',f10.4//
40080  &5x,'Number of particles produced per event (directly and via ',
40081  &'decays/branchings)'/
40082  &8x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
40083  &8x,'Total'/35x,'prim seco prim seco'/)
40084  5300 FORMAT(1x,i9,4x,a16,i2,5(1x,f11.6))
40085  5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
40086  &20x,'based on an analysis of ',i6,' events'//
40087  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
40088  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
40089  5500 FORMAT(10x)
40090  5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
40091  5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
40092  &20x,'based on an analysis of ',i6,' events'//
40093  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
40094  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
40095  5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
40096  5900 FORMAT(///20x,'Decay channel analysis - final state'/
40097  &20x,'based on an analysis of ',i6,' events'//
40098  &2x,'Probability',10x,'Complete final state'/)
40099  6000 FORMAT(2x,f9.5,5x,8(a12,1x))
40100  6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
40101  &'or table overflow)')
40102 
40103  RETURN
40104  END
40105 
40106 C*********************************************************************
40107 
40108 C...PYEEVT
40109 C...Handles the generation of an e+e- annihilation jet event.
40110 
40111  SUBROUTINE pyeevt(KFL,ECM)
40112 C...Double precision and integer declarations.
40113  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40114  INTEGER pyk,pychge,pycomp
40115 C...Commonblocks.
40116  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
40117  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40118  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
40119  SAVE /pyjets/,/pydat1/,/pydat2/
40120 
40121 C...Check input parameters.
40122  IF(mstu(12).GE.1) CALL pylist(0)
40123  IF(kfl.LT.0.OR.kfl.GT.8) THEN
40124  CALL pyerrm(16,'(PYEEVT:) called with unknown flavour code')
40125  IF(mstu(21).GE.1) RETURN
40126  ENDIF
40127  IF(kfl.LE.5) ecmmin=parj(127)+2.02d0*parf(100+max(1,kfl))
40128  IF(kfl.GE.6) ecmmin=parj(127)+2.02d0*pmas(kfl,1)
40129  IF(ecm.LT.ecmmin) THEN
40130  CALL pyerrm(16,'(PYEEVT:) called with too small CM energy')
40131  IF(mstu(21).GE.1) RETURN
40132  ENDIF
40133 
40134 C...Check consistency of MSTJ options set.
40135  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
40136  CALL pyerrm(6,
40137  & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
40138  mstj(110)=1
40139  ENDIF
40140  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
40141  CALL pyerrm(6,
40142  & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
40143  mstj(111)=0
40144  ENDIF
40145 
40146 C...Initialize alpha_strong and total cross-section.
40147  mstu(111)=mstj(108)
40148  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
40149  &mstu(111)=1
40150  paru(112)=parj(121)
40151  IF(mstu(111).EQ.2) paru(112)=parj(122)
40152  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
40153  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL pyxtee(kfl,ecm,
40154  &xtot)
40155  IF(mstj(116).GE.3) mstj(116)=1
40156  parj(171)=0d0
40157 
40158 C...Add initial e+e- to event record (documentation only).
40159  ntry=0
40160  100 ntry=ntry+1
40161  IF(ntry.GT.100) THEN
40162  CALL pyerrm(14,'(PYEEVT:) caught in an infinite loop')
40163  RETURN
40164  ENDIF
40165  mstu(24)=0
40166  nc=0
40167  IF(mstj(115).GE.2) THEN
40168  nc=nc+2
40169  CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
40170  k(nc-1,1)=21
40171  CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
40172  k(nc,1)=21
40173  ENDIF
40174 
40175 C...Radiative photon (in initial state).
40176  mk=0
40177  ecmc=ecm
40178  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL pyradk(ecm,mk,pak,
40179  &thek,phik,alpk)
40180  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2d0*pak))
40181  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
40182  nc=nc+1
40183  CALL py1ent(nc,22,pak,thek,phik)
40184  k(nc,3)=min(mstj(115)/2,1)
40185  ENDIF
40186 
40187 C...Virtual exchange boson (gamma or Z0).
40188  IF(mstj(115).GE.3) THEN
40189  nc=nc+1
40190  kf=22
40191  IF(mstj(102).EQ.2) kf=23
40192  mstu10=mstu(10)
40193  mstu(10)=1
40194  p(nc,5)=ecmc
40195  CALL py1ent(nc,kf,ecmc,0d0,0d0)
40196  k(nc,1)=21
40197  k(nc,3)=1
40198  mstu(10)=mstu10
40199  ENDIF
40200 
40201 C...Choice of flavour and jet configuration.
40202  CALL pyxkfl(kfl,ecm,ecmc,kflc)
40203  IF(kflc.EQ.0) goto 100
40204  CALL pyxjet(ecmc,njet,cut)
40205  kfln=21
40206  IF(njet.EQ.4) CALL pyx4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
40207  &x12,x14)
40208  IF(njet.EQ.3) CALL pyx3jt(njet,cut,kflc,ecmc,x1,x3)
40209  IF(njet.EQ.2) mstj(120)=1
40210 
40211 C...Fill jet configuration and origin.
40212  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL py2ent(nc+1,kflc,-kflc,ecmc)
40213  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL py2ent(-(nc+1),kflc,-kflc,
40214  &ecmc)
40215  IF(njet.EQ.3) CALL py3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
40216  IF(njet.EQ.4.AND.kfln.EQ.21) CALL py4ent(nc+1,kflc,kfln,kfln,
40217  &-kflc,ecmc,x1,x2,x4,x12,x14)
40218  IF(njet.EQ.4.AND.kfln.NE.21) CALL py4ent(nc+1,kflc,-kfln,kfln,
40219  &-kflc,ecmc,x1,x2,x4,x12,x14)
40220  IF(mstu(24).NE.0) goto 100
40221  DO 110 ip=nc+1,n
40222  k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
40223  110 CONTINUE
40224 
40225 C...Angular orientation according to matrix element.
40226  IF(mstj(106).EQ.1) THEN
40227  CALL pyxdif(nc,njet,kflc,ecmc,chi,the,phi)
40228  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
40229  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
40230  ENDIF
40231 
40232 C...Rotation and boost from radiative photon.
40233  IF(mk.EQ.1) THEN
40234  dbek=-pak/(ecm-pak)
40235  nmin=nc+1-mstj(115)/3
40236  CALL pyrobo(nmin,n,0d0,-phik,0d0,0d0,0d0)
40237  CALL pyrobo(nmin,n,alpk,0d0,dbek*sin(thek),0d0,dbek*cos(thek))
40238  CALL pyrobo(nmin,n,0d0,phik,0d0,0d0,0d0)
40239  ENDIF
40240 
40241 C...Generate parton shower. Rearrange along strings and check.
40242  IF(mstj(101).EQ.5) THEN
40243  CALL pyshow(n-1,n,ecmc)
40244  mstj14=mstj(14)
40245  IF(mstj(105).EQ.-1) mstj(14)=-1
40246  IF(mstj(105).GE.0) mstu(28)=0
40247  CALL pyprep(0)
40248  mstj(14)=mstj14
40249  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
40250  ENDIF
40251 
40252 C...Fragmentation/decay generation. Information for PYTABU.
40253  IF(mstj(105).EQ.1) CALL pyexec
40254  mstu(161)=kflc
40255  mstu(162)=-kflc
40256 
40257  RETURN
40258  END
40259 
40260 C*********************************************************************
40261 
40262 C...PYXTEE
40263 C...Calculates total cross-section, including initial state
40264 C...radiation effects.
40265 
40266  SUBROUTINE pyxtee(KFL,ECM,XTOT)
40267 
40268 C...Double precision and integer declarations.
40269  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40270  INTEGER pyk,pychge,pycomp
40271 C...Commonblocks.
40272  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40273  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
40274  SAVE /pydat1/,/pydat2/
40275 
40276 C...Status, (optimized) Q^2 scale, alpha_strong.
40277  parj(151)=ecm
40278  mstj(119)=10*mstj(102)+kfl
40279  IF(mstj(111).EQ.0) THEN
40280  q2r=ecm**2
40281  ELSEIF(mstu(111).EQ.0) THEN
40282  parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
40283  & ((33d0-2d0*mstu(112))*paru(111)))))
40284  q2r=parj(168)*ecm**2
40285  ELSE
40286  parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
40287  & (2d0*paru(112)/ecm)**2))
40288  q2r=parj(168)*ecm**2
40289  ENDIF
40290  alspi=pyalps(q2r)/paru(1)
40291 
40292 C...QCD corrections factor in R.
40293  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
40294  rqcd=1d0
40295  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
40296  rqcd=1d0+alspi
40297  ELSEIF(mstj(109).EQ.0) THEN
40298  rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
40299  IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+(33d0-2d0*mstu(112))/12d0*
40300  & log(parj(168))*alspi**2)
40301  ELSEIF(iabs(mstj(101)).EQ.1) THEN
40302  rqcd=1d0+(3d0/4d0)*alspi
40303  ELSE
40304  rqcd=1d0+(3d0/4d0)*alspi-(3d0/32d0+0.519d0*mstu(118))*alspi**2
40305  ENDIF
40306 
40307 C...Calculate Z0 width if default value not acceptable.
40308  IF(mstj(102).GE.3) THEN
40309  rva=3d0*(3d0+(4d0*paru(102)-1d0)**2)+6d0*rqcd*(2d0+
40310  & (1d0-8d0*paru(102)/3d0)**2+(4d0*paru(102)/3d0-1d0)**2)
40311  DO 100 kflc=5,6
40312  vq=1d0
40313  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-
40314  & (2d0*pymass(kflc)/ ecm)**2))
40315  IF(kflc.EQ.5) vf=4d0*paru(102)/3d0-1d0
40316  IF(kflc.EQ.6) vf=1d0-8d0*paru(102)/3d0
40317  rva=rva+3d0*rqcd*(0.5d0*vq*(3d0-vq**2)*vf**2+vq**3)
40318  100 CONTINUE
40319  parj(124)=paru(101)*parj(123)*rva/(48d0*paru(102)*
40320  & (1d0-paru(102)))
40321  ENDIF
40322 
40323 C...Calculate propagator and related constants for QFD case.
40324  poll=1d0-parj(131)*parj(132)
40325  IF(mstj(102).GE.2) THEN
40326  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
40327  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
40328  sfi=sfw*(1d0-(parj(123)/ecm)**2)
40329  ve=4d0*paru(102)-1d0
40330  sf1i=sff*(ve*poll+parj(132)-parj(131))
40331  sf1w=sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
40332  hf1i=sfi*sf1i
40333  hf1w=sfw*sf1w
40334  ENDIF
40335 
40336 C...Loop over different flavours: charge, velocity.
40337  rtot=0d0
40338  rqq=0d0
40339  rqv=0d0
40340  rva=0d0
40341  DO 110 kflc=1,max(mstj(104),kfl)
40342  IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110
40343  mstj(93)=1
40344  pmq=pymass(kflc)
40345  IF(ecm.LT.2d0*pmq+parj(127)) goto 110
40346  qf=kchg(kflc,1)/3d0
40347  vq=1d0
40348  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1d0-(2d0*pmq/ecm)**2)
40349 
40350 C...Calculate R and sum of charges for QED or QFD case.
40351  rqq=rqq+3d0*qf**2*poll
40352  IF(mstj(102).LE.1) THEN
40353  rtot=rtot+3d0*0.5d0*vq*(3d0-vq**2)*qf**2*poll
40354  ELSE
40355  vf=sign(1d0,qf)-4d0*qf*paru(102)
40356  rqv=rqv-6d0*qf*vf*sf1i
40357  rva=rva+3d0*(vf**2+1d0)*sf1w
40358  rtot=rtot+3d0*(0.5d0*vq*(3d0-vq**2)*(qf**2*poll-
40359  & 2d0*qf*vf*hf1i+vf**2*hf1w)+vq**3*hf1w)
40360  ENDIF
40361  110 CONTINUE
40362  rsum=rqq
40363  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
40364 
40365 C...Calculate cross-section, including QCD corrections.
40366  parj(141)=rqq
40367  parj(142)=rtot
40368  parj(143)=rtot*rqcd
40369  parj(144)=parj(143)
40370  parj(145)=parj(141)*86.8d0/ecm**2
40371  parj(146)=parj(142)*86.8d0/ecm**2
40372  parj(147)=parj(143)*86.8d0/ecm**2
40373  parj(148)=parj(147)
40374  parj(157)=rsum*rqcd
40375  parj(158)=0d0
40376  parj(159)=0d0
40377  xtot=parj(147)
40378  IF(mstj(107).LE.0) RETURN
40379 
40380 C...Virtual cross-section.
40381  xkl=parj(135)
40382  xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
40383  ale=2d0*log(ecm/pymass(11))-1d0
40384  sigv=ale/3d0+2d0*log(ecm**2/(pymass(13)*pymass(15)))/3d0-4d0/3d0+
40385  &1.526d0*log(ecm**2/0.932d0)
40386 
40387 C...Soft and hard radiative cross-section in QED case.
40388  IF(mstj(102).LE.1) THEN
40389  sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+2d0*sigv
40390  sigs=ale*(2d0*log(xkl)-log(1d0-xkl)-xkl)
40391  sigh=ale*(2d0*log(xku/xkl)-log((1d0-xku)/(1d0-xkl))-(xku-xkl))
40392 
40393 C...Soft and hard radiative cross-section in QFD case.
40394  ELSE
40395  szm=1d0-(parj(123)/ecm)**2
40396  szw=parj(123)*parj(124)/ecm**2
40397  parj(161)=-rqq/rsum
40398  parj(162)=-(rqq+rqv+rva)/rsum
40399  parj(163)=(rqv*(1d0-0.5d0*szm-sfi)+rva*(1.5d0-szm-sfw))/rsum
40400  parj(164)=(rqv*szw**2*(1d0-2d0*sfw)+rva*(2d0*sfi+szw**2-
40401  & 4d0+3d0*szm-szm**2))/(szw*rsum)
40402  sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+((2d0*rqq+sfi*rqv)/
40403  & rsum)*sigv+(szw*sfw*rqv/rsum)*paru(1)*20d0/9d0
40404  sigs=ale*(2d0*log(xkl)+parj(161)*log(1d0-xkl)+parj(162)*xkl+
40405  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
40406  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
40407  sigh=ale*(2d0*log(xku/xkl)+parj(161)*log((1d0-xku)/
40408  & (1d0-xkl))+parj(162)*(xku-xkl)+parj(163)*
40409  & log(((xku-szm)**2+szw**2)/((xkl-szm)**2+szw**2))+
40410  & parj(164)*(atan((xku-szm)/szw)-atan((xkl-szm)/szw)))
40411  ENDIF
40412 
40413 C...Total cross-section and fraction of hard photon events.
40414  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
40415  parj(157)=rsum*(1d0+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
40416  parj(144)=parj(157)
40417  parj(148)=parj(144)*86.8d0/ecm**2
40418  xtot=parj(148)
40419 
40420  RETURN
40421  END
40422 
40423 C*********************************************************************
40424 
40425 C...PYRADK
40426 C...Generates initial state photon radiation.
40427 
40428  SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)
40429 
40430 C...Double precision and integer declarations.
40431  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40432  INTEGER pyk,pychge,pycomp
40433 C...Commonblocks.
40434  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40435  SAVE /pydat1/
40436 
40437 C...Function: cumulative hard photon spectrum in QFD case.
40438  fxk(xx)=2d0*log(xx)+parj(161)*log(1d0-xx)+parj(162)*xx+
40439  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
40440 
40441 C...Determine whether radiative photon or not.
40442  mk=0
40443  pak=0d0
40444  IF(parj(160).LT.pyr(0)) RETURN
40445  mk=1
40446 
40447 C...Photon energy range. Find photon momentum in QED case.
40448  xkl=parj(135)
40449  xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
40450  IF(mstj(102).LE.1) THEN
40451  100 xk=1d0/(1d0+(1d0/xkl-1d0)*((1d0/xku-1d0)/(1d0/xkl-1d0))**pyr(0))
40452  IF(1d0+(1d0-xk)**2.LT.2d0*pyr(0)) goto 100
40453 
40454 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
40455  ELSE
40456  szm=1d0-(parj(123)/ecm)**2
40457  szw=parj(123)*parj(124)/ecm**2
40458  fxkl=fxk(xkl)
40459  fxku=fxk(xku)
40460  fxkd=1d-4*(fxku-fxkl)
40461  fxkr=fxkl+pyr(0)*(fxku-fxkl)
40462  nxk=0
40463  110 nxk=nxk+1
40464  xk=0.5d0*(xkl+xku)
40465  fxkv=fxk(xk)
40466  IF(fxkv.GT.fxkr) THEN
40467  xku=xk
40468  fxku=fxkv
40469  ELSE
40470  xkl=xk
40471  fxkl=fxkv
40472  ENDIF
40473  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110
40474  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
40475  ENDIF
40476  pak=0.5d0*ecm*xk
40477 
40478 C...Photon polar and azimuthal angle.
40479  pme=2d0*(pymass(11)/ecm)**2
40480  120 cthm=pme*(2d0/pme)**pyr(0)
40481  IF(1d0-(xk**2*cthm*(1d0-0.5d0*cthm)+2d0*(1d0-xk)*pme/max(pme,
40482  &cthm*(1d0-0.5d0*cthm)))/(1d0+(1d0-xk)**2).LT.pyr(0)) goto 120
40483  cthe=1d0-cthm
40484  IF(pyr(0).GT.0.5d0) cthe=-cthe
40485  sthe=sqrt(max(0d0,(cthm-pme)*(2d0-cthm)))
40486  thek=pyangl(cthe,sthe)
40487  phik=paru(2)*pyr(0)
40488 
40489 C...Rotation angle for hadronic system.
40490  sgn=1d0
40491  IF(0.5d0*(2d0-xk*(1d0-cthe))**2/((2d0-xk)**2+(xk*cthe)**2).GT.
40492  &pyr(0)) sgn=-1d0
40493  alpk=asin(sgn*sthe*(xk-sgn*(2d0*sqrt(1d0-xk)-2d0+xk)*cthe)/
40494  &(2d0-xk*(1d0-sgn*cthe)))
40495 
40496  RETURN
40497  END
40498 
40499 C*********************************************************************
40500 
40501 C...PYXKFL
40502 C...Selects flavour for produced qqbar pair.
40503 
40504  SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)
40505 
40506 C...Double precision and integer declarations.
40507  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40508  INTEGER pyk,pychge,pycomp
40509 C...Commonblocks.
40510  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40511  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
40512  SAVE /pydat1/,/pydat2/
40513 
40514 C...Calculate maximum weight in QED or QFD case.
40515  IF(mstj(102).LE.1) THEN
40516  rfmax=4d0/9d0
40517  ELSE
40518  poll=1d0-parj(131)*parj(132)
40519  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
40520  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
40521  sfi=sfw*(1d0-(parj(123)/ecmc)**2)
40522  ve=4d0*paru(102)-1d0
40523  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
40524  hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
40525  rfmax=max(4d0/9d0*poll-4d0/3d0*(1d0-8d0*paru(102)/3d0)*hf1i+
40526  & ((1d0-8d0*paru(102)/3d0)**2+1d0)*hf1w,1d0/9d0*poll+2d0/3d0*
40527  & (-1d0+4d0*paru(102)/3d0)*hf1i+((-1d0+4d0*paru(102)/3d0)**2+
40528  & 1d0)*hf1w)
40529  ENDIF
40530 
40531 C...Choose flavour. Gives charge and velocity.
40532  ntry=0
40533  100 ntry=ntry+1
40534  IF(ntry.GT.100) THEN
40535  CALL pyerrm(14,'(PYXKFL:) caught in an infinite loop')
40536  kflc=0
40537  RETURN
40538  ENDIF
40539  kflc=kfl
40540  IF(kfl.LE.0) kflc=1+int(mstj(104)*pyr(0))
40541  mstj(93)=1
40542  pmq=pymass(kflc)
40543  IF(ecm.LT.2d0*pmq+parj(127)) goto 100
40544  qf=kchg(kflc,1)/3d0
40545  vq=1d0
40546  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-(2d0*pmq/ecmc)**2))
40547 
40548 C...Calculate weight in QED or QFD case.
40549  IF(mstj(102).LE.1) THEN
40550  rf=qf**2
40551  rfv=0.5d0*vq*(3d0-vq**2)*qf**2
40552  ELSE
40553  vf=sign(1d0,qf)-4d0*qf*paru(102)
40554  rf=qf**2*poll-2d0*qf*vf*hf1i+(vf**2+1d0)*hf1w
40555  rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+vf**2*hf1w)+
40556  & vq**3*hf1w
40557  IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
40558  ENDIF
40559 
40560 C...Weighting or new event (radiative photon). Cross-section update.
40561  IF(kfl.LE.0.AND.rf.LT.pyr(0)*rfmax) goto 100
40562  parj(158)=parj(158)+1d0
40563  IF(ecmc.LT.2d0*pmq+parj(127).OR.rfv.LT.pyr(0)*rf) kflc=0
40564  IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100
40565  IF(kflc.NE.0) parj(159)=parj(159)+1d0
40566  parj(144)=parj(157)*parj(159)/parj(158)
40567  parj(148)=parj(144)*86.8d0/ecm**2
40568 
40569  RETURN
40570  END
40571 
40572 C*********************************************************************
40573 
40574 C...PYXJET
40575 C...Selects number of jets in matrix element approach.
40576 
40577  SUBROUTINE pyxjet(ECM,NJET,CUT)
40578 
40579 C...Double precision and integer declarations.
40580  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40581  INTEGER pyk,pychge,pycomp
40582 C...Commonblocks.
40583  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40584  SAVE /pydat1/
40585 C...Local array and data.
40586  dimension zhut(5)
40587  DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/
40588 
40589 C...Trivial result for two-jets only, including parton shower.
40590  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
40591  cut=0d0
40592 
40593 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
40594  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
40595  cf=4d0/3d0
40596  IF(mstj(109).EQ.2) cf=1d0
40597  IF(mstj(111).EQ.0) THEN
40598  q2=ecm**2
40599  q2r=ecm**2
40600  ELSEIF(mstu(111).EQ.0) THEN
40601  parj(169)=min(1d0,parj(129))
40602  q2=parj(169)*ecm**2
40603  parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
40604  & ((33d0-2d0*mstu(112))*paru(111)))))
40605  q2r=parj(168)*ecm**2
40606  ELSE
40607  parj(169)=min(1d0,max(parj(129),(2d0*paru(112)/ecm)**2))
40608  q2=parj(169)*ecm**2
40609  parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
40610  & (2d0*paru(112)/ecm)**2))
40611  q2r=parj(168)*ecm**2
40612  ENDIF
40613 
40614 C...alpha_strong for R and R itself.
40615  alspi=(3d0/4d0)*cf*pyalps(q2r)/paru(1)
40616  IF(iabs(mstj(101)).EQ.1) THEN
40617  rqcd=1d0+alspi
40618  ELSEIF(mstj(109).EQ.0) THEN
40619  rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
40620  IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+
40621  & (33d0-2d0*mstu(112))/12d0*log(parj(168))*alspi**2)
40622  ELSE
40623  rqcd=1d0+alspi-(3d0/32d0+0.519d0*mstu(118))*(4d0*alspi/3d0)**2
40624  ENDIF
40625 
40626 C...alpha_strong for jet rate. Initial value for y cut.
40627  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
40628  cut=max(0.001d0,parj(125),(parj(126)/ecm)**2)
40629  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
40630  & cut=max(cut,exp(-sqrt(0.75d0/alspi))/2d0)
40631  IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
40632 
40633 C...Parametrization of first order three-jet cross-section.
40634  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25d0) THEN
40635  parj(152)=0d0
40636  ELSE
40637  parj(152)=(2d0*alspi/3d0)*((3d0-6d0*cut+2d0*log(cut))*
40638  & log(cut/(1d0-2d0*cut))+(2.5d0+1.5d0*cut-6.571d0)*
40639  & (1d0-3d0*cut)+5.833d0*(1d0-3d0*cut)**2-3.894d0*
40640  & (1d0-3d0*cut)**3+1.342d0*(1d0-3d0*cut)**4)/rqcd
40641  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
40642  & parj(152)=0d0
40643  ENDIF
40644 
40645 C...Parametrization of second order three-jet cross-section.
40646  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
40647  & cut.GE.0.25d0) THEN
40648  parj(153)=0d0
40649  ELSEIF(mstj(110).LE.1) THEN
40650  ct=log(1d0/cut-2d0)
40651  parj(153)=alspi**2*ct**2*(2.419d0+0.5989d0*ct+0.6782d0*ct**2-
40652  & 0.2661d0*ct**3+0.01159d0*ct**4)/rqcd
40653 
40654 C...Interpolation in second/first order ratio for Zhu parametrization.
40655  ELSEIF(mstj(110).EQ.2) THEN
40656  iza=0
40657  DO 110 iy=1,5
40658  IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
40659  110 CONTINUE
40660  IF(iza.NE.0) THEN
40661  zhurat=zhut(iza)
40662  ELSE
40663  iz=100d0*cut
40664  zhurat=zhut(iz)+(100d0*cut-iz)*(zhut(iz+1)-zhut(iz))
40665  ENDIF
40666  parj(153)=alspi*parj(152)*zhurat
40667  ENDIF
40668 
40669 C...Shift in second order three-jet cross-section with optimized Q^2.
40670  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3
40671  & .AND.cut.LT.0.25d0) parj(153)=parj(153)+
40672  & (33d0-2d0*mstu(112))/12d0*log(parj(169))*alspi*parj(152)
40673 
40674 C...Parametrization of second order four-jet cross-section.
40675  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125d0) THEN
40676  parj(154)=0d0
40677  ELSE
40678  ct=log(1d0/cut-5d0)
40679  IF(cut.LE.0.018d0) THEN
40680  xqqgg=6.349d0-4.330d0*ct+0.8304d0*ct**2
40681  IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(3.035d0-2.091d0*ct+
40682  & 0.4059d0*ct**2)
40683  xqqqq=1.25d0*(-0.1080d0+0.01486d0*ct+0.009364d0*ct**2)
40684  IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
40685  ELSE
40686  xqqgg=-0.09773d0+0.2959d0*ct-0.2764d0*ct**2+0.08832d0*ct**3
40687  IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(-0.04079d0+
40688  & 0.1340d0*ct-0.1326d0*ct**2+0.04365d0*ct**3)
40689  xqqqq=1.25d0*(0.003661d0-0.004888d0*ct-0.001081d0*ct**2+
40690  & 0.002093d0*ct**3)
40691  IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
40692  ENDIF
40693  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
40694  parj(155)=xqqqq/(xqqgg+xqqqq)
40695  ENDIF
40696 
40697 C...If negative three-jet rate, change y' optimization parameter.
40698  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0d0.AND.
40699  & parj(169).LT.0.99d0) THEN
40700  parj(169)=min(1d0,1.2d0*parj(169))
40701  q2=parj(169)*ecm**2
40702  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
40703  goto 100
40704  ENDIF
40705 
40706 C...If too high cross-section, use harder cuts, or fail.
40707  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
40708  IF(mstj(110).EQ.2.AND.cut.GT.0.0499d0.AND.mstj(111).EQ.1.AND.
40709  & parj(169).LT.0.99d0) THEN
40710  parj(169)=min(1d0,1.2d0*parj(169))
40711  q2=parj(169)*ecm**2
40712  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
40713  goto 100
40714  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499d0) THEN
40715  CALL pyerrm(26,
40716  & '(PYXJET:) no allowed y cut value for Zhu parametrization')
40717  ENDIF
40718  cut=0.26d0*(4d0*cut)**(parj(152)+parj(153)+
40719  & parj(154))**(-1d0/3d0)
40720  IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
40721  goto 100
40722  ENDIF
40723 
40724 C...Scalar gluon (first order only).
40725  ELSE
40726  alspi=pyalps(ecm**2)/paru(1)
40727  cut=max(0.001d0,parj(125),(parj(126)/ecm)**2,exp(-3d0/alspi))
40728  parj(152)=0d0
40729  IF(cut.LT.0.25d0) parj(152)=(alspi/3d0)*((1d0-2d0*cut)*
40730  & log((1d0-2d0*cut)/cut)+0.5d0*(9d0*cut**2-1d0))
40731  parj(153)=0d0
40732  parj(154)=0d0
40733  ENDIF
40734 
40735 C...Select number of jets.
40736  parj(150)=cut
40737  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
40738  njet=2
40739  ELSEIF(mstj(101).LE.0) THEN
40740  njet=min(4,2-mstj(101))
40741  ELSE
40742  rnj=pyr(0)
40743  njet=2
40744  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
40745  IF(parj(154).GT.rnj) njet=4
40746  ENDIF
40747 
40748  RETURN
40749  END
40750 
40751 C*********************************************************************
40752 
40753 C...PYX3JT
40754 C...Selects the kinematical variables of three-jet events.
40755 
40756  SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)
40757 
40758 C...Double precision and integer declarations.
40759  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40760  INTEGER pyk,pychge,pycomp
40761 C...Commonblocks.
40762  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40763  SAVE /pydat1/
40764 C...Local array.
40765  dimension zhup(5,12)
40766 
40767 C...Coefficients of Zhu second order parametrization.
40768  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
40769  &18.29d0, 89.56d0, 4.541d0, -52.09d0, -109.8d0, 24.90d0,
40770  &11.63d0, 3.683d0, 17.50d0,0.002440d0, -1.362d0,-0.3537d0,
40771  &11.42d0, 6.299d0, -22.55d0, -8.915d0, 59.25d0, -5.855d0,
40772  &-32.85d0, -1.054d0, -16.90d0,0.006489d0,-0.8156d0,0.01095d0,
40773  &7.847d0, -3.964d0, -35.83d0, 1.178d0, 29.39d0, 0.2806d0,
40774  &47.82d0, -12.36d0, -56.72d0, 0.04054d0,-0.4365d0, 0.6062d0,
40775  &5.441d0, -56.89d0, -50.27d0, 15.13d0, 114.3d0, -18.19d0,
40776  &97.05d0, -1.890d0, -139.9d0, 0.08153d0,-0.4984d0, 0.9439d0,
40777  &-17.65d0, 51.44d0, -58.32d0, 70.95d0, -255.7d0, -78.99d0,
40778  &476.9d0, 29.65d0, -239.3d0, 0.4745d0, -1.174d0, 6.081d0/
40779 
40780 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
40781  dilog(x)=x+x**2/4d0+x**3/9d0+x**4/16d0+x**5/25d0+x**6/36d0+
40782  &x**7/49d0
40783 
40784 C...Event type. Mass effect factors and other common constants.
40785  mstj(120)=2
40786  mstj(121)=0
40787  pmq=pymass(kfl)
40788  qme=(2d0*pmq/ecm)**2
40789  IF(mstj(109).NE.1) THEN
40790  cutl=log(cut)
40791  cutd=log(1d0/cut-2d0)
40792  IF(mstj(109).EQ.0) THEN
40793  cf=4d0/3d0
40794  cn=3d0
40795  tr=2d0
40796  wtmx=min(20d0,37d0-6d0*cutd)
40797  IF(mstj(110).EQ.2) wtmx=2d0*(7.5d0+80d0*cut)
40798  ELSE
40799  cf=1d0
40800  cn=0d0
40801  tr=12d0
40802  wtmx=0d0
40803  ENDIF
40804 
40805 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
40806  als2pi=paru(118)/paru(2)
40807  wtopt=0d0
40808  IF(mstj(111).EQ.1) wtopt=(33d0-2d0*mstu(112))/6d0*
40809  & log(parj(169))*als2pi
40810  wtmax=max(0d0,1d0+wtopt+als2pi*wtmx)
40811 
40812 C...Choose three-jet events in allowed region.
40813  100 njet=3
40814  110 y13l=cutl+cutd*pyr(0)
40815  y23l=cutl+cutd*pyr(0)
40816  y13=exp(y13l)
40817  y23=exp(y23l)
40818  y12=1d0-y13-y23
40819  IF(y12.LE.cut) goto 110
40820  IF(y13**2+y23**2+2d0*y12.LE.2d0*pyr(0)) goto 110
40821 
40822 C...Second order corrections.
40823  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
40824  y12l=log(y12)
40825  y13m=log(1d0-y13)
40826  y23m=log(1d0-y23)
40827  y12m=log(1d0-y12)
40828  IF(y13.LE.0.5d0) y13i=dilog(y13)
40829  IF(y13.GE.0.5d0) y13i=1.644934d0-y13l*y13m-dilog(1d0-y13)
40830  IF(y23.LE.0.5d0) y23i=dilog(y23)
40831  IF(y23.GE.0.5d0) y23i=1.644934d0-y23l*y23m-dilog(1d0-y23)
40832  IF(y12.LE.0.5d0) y12i=dilog(y12)
40833  IF(y12.GE.0.5d0) y12i=1.644934d0-y12l*y12m-dilog(1d0-y12)
40834  wt1=(y13**2+y23**2+2d0*y12)/(y13*y23)
40835  wt2=cf*(-2d0*(cutl-y12l)**2-3d0*cutl-1d0+3.289868d0+
40836  & 2d0*(2d0*cutl-y12l)*cut/y12)+
40837  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-
40838  & 11d0*cutl/6d0+67d0/18d0+1.644934d0-(2d0*cutl-y12l)*cut/y12+
40839  & (2d0*cutl-y13l)*cut/y13+(2d0*cutl-y23l)*cut/y23)+
40840  & tr*(2d0*cutl/3d0-10d0/9d0)+
40841  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
40842  & y13l*(4d0*y12**2+2d0*y12*y13+4d0*y12*y23+y13*y23)/
40843  & (y12+y23)**2+y23l*(4d0*y12**2+2d0*y12*y23+4d0*y12*y13+
40844  & y13*y23)/(y12+y13)**2)/wt1+
40845  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+(cn-2d0*cf)*
40846  & ((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
40847  & y23m+1.644934d0-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
40848  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934d0-y12i-y13i)/
40849  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
40850  & 2d0*y12l*y12**2/(y13+y23)**2-4d0*y12l*y12/(y13+y23))/wt1-
40851  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934d0-y13i-y23i)
40852  IF(1d0+wtopt+als2pi*wt2.LE.0d0) mstj(121)=1
40853  IF(1d0+wtopt+als2pi*wt2.LE.wtmax*pyr(0)) goto 110
40854  parj(156)=(wtopt+als2pi*wt2)/(1d0+wtopt+als2pi*wt2)
40855 
40856  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
40857 C...Second order corrections; Zhu parametrization of ERT.
40858  zx=(y23-y13)**2
40859  zy=1d0-y12
40860  iza=0
40861  DO 120 iy=1,5
40862  IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
40863  120 CONTINUE
40864  IF(iza.NE.0) THEN
40865  iz=iza
40866  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
40867  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
40868  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
40869  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
40870  ELSE
40871  iz=100d0*cut
40872  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
40873  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
40874  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
40875  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
40876  iz=iz+1
40877  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
40878  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
40879  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
40880  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
40881  wt2=wtl+(wtu-wtl)*(100d0*cut+1d0-iz)
40882  ENDIF
40883  IF(1d0+wtopt+2d0*als2pi*wt2.LE.0d0) mstj(121)=1
40884  IF(1d0+wtopt+2d0*als2pi*wt2.LE.wtmax*pyr(0)) goto 110
40885  parj(156)=(wtopt+2d0*als2pi*wt2)/(1d0+wtopt+2d0*als2pi*wt2)
40886  ENDIF
40887 
40888 C...Impose mass cuts (gives two jets). For fixed jet number new try.
40889  x1=1d0-y23
40890  x2=1d0-y13
40891  x3=1d0-y12
40892  IF(4d0*y23*y13*y12/x3**2.LE.qme) njet=2
40893  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
40894  & 0.5d0*qme**2+(0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/(1d0-x1)+
40895  & (1d0-x1)/(1d0-x2)).GT.(x1**2+x2**2)*pyr(0)) njet=2
40896  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100
40897 
40898 C...Scalar gluon model (first order only, no mass effects).
40899  ELSE
40900  130 njet=3
40901  140 x3=sqrt(4d0*cut**2+pyr(0)*((1d0-cut)**2-4d0*cut**2))
40902  IF(log((x3-cut)/cut).LE.pyr(0)*log((1d0-2d0*cut)/cut)) goto 140
40903  yd=sign(2d0*cut*((x3-cut)/cut)**pyr(0)-x3,pyr(0)-0.5d0)
40904  x1=1d0-0.5d0*(x3+yd)
40905  x2=1d0-0.5d0*(x3-yd)
40906  IF(4d0*(1d0-x1)*(1d0-x2)*(1d0-x3)/x3**2.LE.qme) njet=2
40907  IF(mstj(102).GE.2) THEN
40908  IF(x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*parj(171).LT.
40909  & x3**2*pyr(0)) njet=2
40910  ENDIF
40911  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130
40912  ENDIF
40913 
40914  RETURN
40915  END
40916 
40917 C*********************************************************************
40918 
40919 C...PYX4JT
40920 C...Selects the kinematical variables of four-jet events.
40921 
40922  SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
40923 
40924 C...Double precision and integer declarations.
40925  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40926  INTEGER pyk,pychge,pycomp
40927 C...Commonblocks.
40928  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40929  SAVE /pydat1/
40930 C...Local arrays.
40931  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
40932 
40933 C...Common constants. Colour factors for QCD and Abelian gluon theory.
40934  pmq=pymass(kfl)
40935  qme=(2d0*pmq/ecm)**2
40936  ct=log(1d0/cut-5d0)
40937  IF(mstj(109).EQ.0) THEN
40938  cf=4d0/3d0
40939  cn=3d0
40940  tr=2.5d0
40941  ELSE
40942  cf=1d0
40943  cn=0d0
40944  tr=15d0
40945  ENDIF
40946 
40947 C...Choice of process (qqbargg or qqbarqqbar).
40948  100 njet=4
40949  it=1
40950  IF(parj(155).GT.pyr(0)) it=2
40951  IF(mstj(101).LE.-3) it=-mstj(101)-2
40952  IF(it.EQ.1) wtmx=0.7d0/cut**2
40953  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6d0/cut**2
40954  IF(it.EQ.2) wtmx=0.1125d0*cf*tr/cut**2
40955  id=1
40956 
40957 C...Sample the five kinematical variables (for qqgg preweighted in y34).
40958  110 y134=3d0*cut+(1d0-6d0*cut)*pyr(0)
40959  y234=3d0*cut+(1d0-6d0*cut)*pyr(0)
40960  IF(it.EQ.1) y34=(1d0-5d0*cut)*exp(-ct*pyr(0))
40961  IF(it.EQ.2) y34=cut+(1d0-6d0*cut)*pyr(0)
40962  IF(y34.LE.y134+y234-1d0.OR.y34.GE.y134*y234) goto 110
40963  vt=pyr(0)
40964  cp=cos(paru(1)*pyr(0))
40965  y14=(y134-y34)*vt
40966  y13=y134-y14-y34
40967  vb=y34*(1d0-y134-y234+y34)/((y134-y34)*(y234-y34))
40968  y24=0.5d0*(y234-y34)*(1d0-4d0*sqrt(max(0d0,vt*(1d0-vt)*
40969  &vb*(1d0-vb)))*cp-(1d0-2d0*vt)*(1d0-2d0*vb))
40970  y23=y234-y34-y24
40971  y12=1d0-y134-y23-y24
40972  IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110
40973  y123=y12+y13+y23
40974  y124=y12+y14+y24
40975 
40976 C...Calculate matrix elements for qqgg or qqqq process.
40977  ic=0
40978  wttot=0d0
40979  120 ic=ic+1
40980  IF(it.EQ.1) THEN
40981  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3d0*y12*y23*y34+
40982  & 3d0*y12*y14*y34+4d0*y12**2*y34-y13*y23*y24+2d0*y12*y23*y24-
40983  & y13*y14*y24-2d0*y12*y13*y24+2d0*y12**2*y24+y14*y23**2+2d0*y12*
40984  & y23**2+y14**2*y23+4d0*y12*y14*y23+4d0*y12**2*y23+2d0*y12*y14**2+
40985  & 2d0*y12*y13*y14+4d0*y12**2*y14+2d0*y12**2*y13+2d0*y12**3)/
40986  & (2d0*y13*y134*y234*y24)+(y24*y34+y12*y34+y13*y24-
40987  & y14*y23+y12*y13)/(y13*y134**2)+2d0*y23*(1d0-y13)/
40988  & (y13*y134*y24)+y34/(2d0*y13*y24)
40989  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2d0*y12*
40990  & y14*y24)/(y13*y134*y23*y14)+y12*(1d0+y34)*y124/(y134*y234*y14*
40991  & y24)-(2d0*y13*y24+y14**2+y13*y23+2d0*y12*y13)/(y13*y134*y14)+
40992  & y12*y123*y124/(2d0*y13*y14*y23*y24)
40993  wtc(ic)=-(5d0*y12*y34**2+2d0*y12*y24*y34+2d0*y12*y23*y34+
40994  & 2d0*y12*y14*y34+2d0*y12*y13*y34+4d0*y12**2*y34-y13*y24**2+
40995  & y14*y23*y24+y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-
40996  & 3d0*y12*y13*y24-y14*y23**2-y14**2*y23+y13*y14*y23-
40997  & 3d0*y12*y14*y23-y12*y13*y23)/(4d0*y134*y234*y34**2)+
40998  & (3d0*y12*y34**2-3d0*y13*y24*y34+3d0*y12*y24*y34+
40999  & 3d0*y14*y23*y34-y13*y24**2-y12*y23*y34+6d0*y12*y14*y34+
41000  & 2d0*y12*y13*y34-2d0*y12**2*y34+y14*y23*y24-3d0*y13*y23*y24-
41001  & 2d0*y13*y14*y24+4d0*y12*y14*y24+2d0*y12*y13*y24+
41002  & 3d0*y14*y23**2+2d0*y14**2*y23+2d0*y14**2*y12+
41003  & 2d0*y12**2*y14+6d0*y12*y14*y23-2d0*y12*y13**2-
41004  & 2d0*y12**2*y13)/(4d0*y13*y134*y234*y34)
41005  wtc(ic)=wtc(ic)+(2d0*y12*y34**2-2d0*y13*y24*y34+y12*y24*y34+
41006  & 4d0*y13*y23*y34+4d0*y12*y14*y34+2d0*y12*y13*y34+2d0*y12**2*y34-
41007  & y13*y24**2+3d0*y14*y23*y24+4d0*y13*y23*y24-2d0*y13*y14*y24+
41008  & 4d0*y12*y14*y24+2d0*y12*y13*y24+2d0*y14*y23**2+4d0*y13*y23**2+
41009  & 2d0*y13*y14*y23+2d0*y12*y14*y23+4d0*y12*y13*y23+2d0*y12*y14**2+
41010  & 4d0*y12**2*y13+4d0*y12*y13*y14+2d0*y12**2*y14)/
41011  & (4d0*y13*y134*y24*y34)-(y12*y34**2-2d0*y14*y24*y34-
41012  & 2d0*y13*y24*y34-y14*y23*y34+y13*y23*y34+y12*y14*y34+
41013  & 2d0*y12*y13*y34-2d0*y14**2*y24-4d0*y13*y14*y24-
41014  & 4d0*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-
41015  & y12*y13**2)/(2d0*y13*y34*y134**2)+(y12*y34**2-
41016  & 4d0*y14*y24*y34-2d0*y13*y24*y34-2d0*y14*y23*y34-
41017  & 4d0*y13*y23*y34-4d0*y12*y14*y34-4d0*y12*y13*y34-
41018  & 2d0*y13*y14*y24+2d0*y13**2*y24+2d0*y14**2*y23-
41019  & 2d0*y13*y14*y23-y12*y14**2-6d0*y12*y13*y14-
41020  & y12*y13**2)/(4d0*y34**2*y134**2)
41021  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5d0*cn)*wtb(ic)+
41022  & cn*wtc(ic))/8d0
41023  ELSE
41024  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2d0*y12*
41025  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
41026  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
41027  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
41028  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
41029  & y13*y14*y24+2d0*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
41030  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
41031  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
41032  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
41033  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
41034  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
41035  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
41036  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
41037  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
41038  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
41039  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
41040  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
41041  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5d0*cn)*wte(ic))/16d0
41042  ENDIF
41043 
41044 C...Permutations of momenta in matrix element. Weighting.
41045  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
41046  ysav=y13
41047  y13=y14
41048  y14=ysav
41049  ysav=y23
41050  y23=y24
41051  y24=ysav
41052  ysav=y123
41053  y123=y124
41054  y124=ysav
41055  ENDIF
41056  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
41057  ysav=y13
41058  y13=y23
41059  y23=ysav
41060  ysav=y14
41061  y14=y24
41062  y24=ysav
41063  ysav=y134
41064  y134=y234
41065  y234=ysav
41066  ENDIF
41067  IF(ic.LE.3) goto 120
41068  IF(id.EQ.1.AND.wttot.LT.pyr(0)*wtmx) goto 110
41069  ic=5
41070 
41071 C...qqgg events: string configuration and event type.
41072  IF(it.EQ.1) THEN
41073  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
41074  parj(156)=y34*(2d0*(wta(1)+wta(2)+wta(3)+wta(4))+4d0*(wtc(1)+
41075  & wtc(2)+wtc(3)+wtc(4)))/(9d0*wttot)
41076  IF(wta(2)+wta(4)+2d0*(wtc(2)+wtc(4)).GT.pyr(0)*(wta(1)+wta(2)+
41077  & wta(3)+wta(4)+2d0*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
41078  IF(id.EQ.2) goto 130
41079  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
41080  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8d0*wttot)
41081  IF(wta(2)+wta(4).GT.pyr(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
41082  IF(id.EQ.2) goto 130
41083  ENDIF
41084  mstj(120)=3
41085  IF(mstj(109).EQ.0.AND.0.5d0*y34*(wtc(1)+wtc(2)+wtc(3)+
41086  & wtc(4)).GT.pyr(0)*wttot) mstj(120)=4
41087  kfln=21
41088 
41089 C...Mass cuts. Kinematical variables out.
41090  IF(y12.LE.cut+qme) njet=2
41091  IF(njet.EQ.2) goto 150
41092  q12=0.5d0*(1d0-sqrt(1d0-qme/y12))
41093  x1=1d0-(1d0-q12)*y234-q12*y134
41094  x4=1d0-(1d0-q12)*y134-q12*y234
41095  x2=1d0-y124
41096  x12=(1d0-q12)*y13+q12*y23
41097  x14=y12-0.5d0*qme
41098  IF(y134*y234/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
41099 
41100 C...qqbarqqbar events: string configuration, choose new flavour.
41101  ELSE
41102  IF(id.EQ.1) THEN
41103  wtr=pyr(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
41104  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
41105  IF(wtr.LT.wtd(3)+wtd(4)) id=3
41106  IF(wtr.LT.wtd(4)) id=4
41107  IF(id.GE.2) goto 130
41108  ENDIF
41109  mstj(120)=5
41110  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16d0*wttot)
41111  140 kfln=1+int(5d0*pyr(0))
41112  IF(kfln.NE.kfl.AND.0.2d0*parj(156).LE.pyr(0)) goto 140
41113  IF(kfln.EQ.kfl.AND.1d0-0.8d0*parj(156).LE.pyr(0)) goto 140
41114  IF(kfln.GT.mstj(104)) njet=2
41115  pmqn=pymass(kfln)
41116  qmen=(2d0*pmqn/ecm)**2
41117 
41118 C...Mass cuts. Kinematical variables out.
41119  IF(y24.LE.cut+qme.OR.y13.LE.1.1d0*qmen) njet=2
41120  IF(njet.EQ.2) goto 150
41121  q24=0.5d0*(1d0-sqrt(1d0-qme/y24))
41122  q13=0.5d0*(1d0-sqrt(1d0-qmen/y13))
41123  x1=1d0-(1d0-q24)*y123-q24*y134
41124  x4=1d0-(1d0-q24)*y134-q24*y123
41125  x2=1d0-(1d0-q13)*y234-q13*y124
41126  x12=(1d0-q24)*((1d0-q13)*y14+q13*y34)+q24*((1d0-q13)*y12+
41127  & q13*y23)
41128  x14=y24-0.5d0*qme
41129  x34=(1d0-q24)*((1d0-q13)*y23+q13*y12)+q24*((1d0-q13)*y34+
41130  & q13*y14)
41131  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
41132  & (parj(127)+pmq+pmqn)**2) njet=2
41133  IF(y123*y134/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
41134  ENDIF
41135  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100
41136 
41137  RETURN
41138  END
41139 
41140 C*********************************************************************
41141 
41142 C...PYXDIF
41143 C...Gives the angular orientation of events.
41144 
41145  SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
41146 
41147 C...Double precision and integer declarations.
41148  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41149  INTEGER pyk,pychge,pycomp
41150 C...Commonblocks.
41151  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
41152  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41153  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41154  SAVE /pyjets/,/pydat1/,/pydat2/
41155 
41156 C...Charge. Factors depending on polarization for QED case.
41157  qf=kchg(kfl,1)/3d0
41158  poll=1d0-parj(131)*parj(132)
41159  pold=parj(132)-parj(131)
41160  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
41161  hf1=poll
41162  hf2=0d0
41163  hf3=parj(133)**2
41164  hf4=0d0
41165 
41166 C...Factors depending on flavour, energy and polarization for QFD case.
41167  ELSE
41168  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
41169  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
41170  sfi=sfw*(1d0-(parj(123)/ecm)**2)
41171  ae=-1d0
41172  ve=4d0*paru(102)-1d0
41173  af=sign(1d0,qf)
41174  vf=af-4d0*qf*paru(102)
41175  hf1=qf**2*poll-2d0*qf*vf*sfi*sff*(ve*poll-ae*pold)+
41176  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2d0*ve*ae*pold)
41177  hf2=-2d0*qf*af*sfi*sff*(ae*poll-ve*pold)+2d0*vf*af*sfw*sff**2*
41178  & (2d0*ve*ae*poll-(ve**2+ae**2)*pold)
41179  hf3=parj(133)**2*(qf**2-2d0*qf*vf*sfi*sff*ve+(vf**2+af**2)*
41180  & sfw*sff**2*(ve**2-ae**2))
41181  hf4=-parj(133)**2*2d0*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
41182  & sff*ae
41183  ENDIF
41184 
41185 C...Mass factor. Differential cross-sections for two-jet events.
41186  sq2=sqrt(2d0)
41187  qme=0d0
41188  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
41189  &mstj(109).NE.1) qme=(2d0*pymass(kfl)/ecm)**2
41190  IF(njet.EQ.2) THEN
41191  sigu=4d0*sqrt(1d0-qme)
41192  sigl=2d0*qme*sqrt(1d0-qme)
41193  sigt=0d0
41194  sigi=0d0
41195  siga=0d0
41196  sigp=4d0
41197 
41198 C...Kinematical variables. Reduce four-jet event to three-jet one.
41199  ELSE
41200  IF(njet.EQ.3) THEN
41201  x1=2d0*p(nc+1,4)/ecm
41202  x2=2d0*p(nc+3,4)/ecm
41203  ELSE
41204  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
41205  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
41206  x1=2d0*p(nc+1,4)/ecmr
41207  x2=2d0*p(nc+4,4)/ecmr
41208  ENDIF
41209 
41210 C...Differential cross-sections for three-jet (or reduced four-jet).
41211  xq=(1d0-x1)/(1d0-x2)
41212  ct12=(x1*x2-2d0*x1-2d0*x2+2d0+qme)/sqrt((x1**2-qme)*(x2**2-qme))
41213  st12=sqrt(1d0-ct12**2)
41214  IF(mstj(109).NE.1) THEN
41215  sigu=2d0*x1**2+x2**2*(1d0+ct12**2)-qme*(3d0+ct12**2-x1-x2)-
41216  & qme*x1/xq+0.5d0*qme*((x2**2-qme)*st12**2-2d0*x2)*xq
41217  sigl=(x2*st12)**2-qme*(3d0-ct12**2-2.5d0*(x1+x2)+x1*x2+qme)+
41218  & 0.5d0*qme*(x1**2-x1-qme)/xq+0.5d0*qme*((x2**2-qme)*ct12**2-
41219  & x2)*xq
41220  sigt=0.5d0*(x2**2-qme-0.5d0*qme*(x2**2-qme)/xq)*st12**2
41221  sigi=((1d0-0.5d0*qme*xq)*(x2**2-qme)*st12*ct12+
41222  & qme*(1d0-x1-x2+0.5d0*x1*x2+0.5d0*qme)*st12/ct12)/sq2
41223  siga=x2**2*st12/sq2
41224  sigp=2d0*(x1**2-x2**2*ct12)
41225 
41226 C...Differential cross-sect for scalar gluons (no mass effects).
41227  ELSE
41228  x3=2d0-x1-x2
41229  xt=x2*st12
41230  ct13=sqrt(max(0d0,1d0-(xt/x3)**2))
41231  sigu=(1d0-parj(171))*(x3**2-0.5d0*xt**2)+
41232  & parj(171)*(x3**2-0.5d0*xt**2-4d0*(1d0-x1)*(1d0-x2)**2/x1)
41233  sigl=(1d0-parj(171))*0.5d0*xt**2+
41234  & parj(171)*0.5d0*(1d0-x1)**2*xt**2
41235  sigt=(1d0-parj(171))*0.25d0*xt**2+
41236  & parj(171)*0.25d0*xt**2*(1d0-2d0*x1)
41237  sigi=-(0.5d0/sq2)*((1d0-parj(171))*xt*x3*ct13+
41238  & parj(171)*xt*((1d0-2d0*x1)*x3*ct13-x1*(x1-x2)))
41239  siga=(0.25d0/sq2)*xt*(2d0*(1d0-x1)-x1*x3)
41240  sigp=x3**2-2d0*(1d0-x1)*(1d0-x2)/x1
41241  ENDIF
41242  ENDIF
41243 
41244 C...Upper bounds for differential cross-section.
41245  hf1a=abs(hf1)
41246  hf2a=abs(hf2)
41247  hf3a=abs(hf3)
41248  hf4a=abs(hf4)
41249  sigmax=(2d0*hf1a+hf3a+hf4a)*abs(sigu)+2d0*(hf1a+hf3a+hf4a)*
41250  &abs(sigl)+2d0*(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigt)+2d0*sq2*
41251  &(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigi)+4d0*sq2*hf2a*abs(siga)+
41252  &2d0*hf2a*abs(sigp)
41253 
41254 C...Generate angular orientation according to differential cross-sect.
41255  100 chi=paru(2)*pyr(0)
41256  cthe=2d0*pyr(0)-1d0
41257  phi=paru(2)*pyr(0)
41258  cchi=cos(chi)
41259  schi=sin(chi)
41260  c2chi=cos(2d0*chi)
41261  s2chi=sin(2d0*chi)
41262  the=acos(cthe)
41263  sthe=sin(the)
41264  c2phi=cos(2d0*(phi-parj(134)))
41265  s2phi=sin(2d0*(phi-parj(134)))
41266  sig=((1d0+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
41267  &2d0*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
41268  &2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*c2chi*c2phi-2d0*cthe*s2chi*
41269  &s2phi)*hf3-((1d0+cthe**2)*c2chi*s2phi+2d0*cthe*s2chi*c2phi)*hf4)*
41270  &sigt-2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*(cthe*cchi*c2phi-
41271  &schi*s2phi)*hf3+2d0*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
41272  &4d0*sq2*sthe*cchi*hf2*siga+2d0*cthe*hf2*sigp
41273  IF(sig.LT.sigmax*pyr(0)) goto 100
41274 
41275  RETURN
41276  END
41277 
41278 C*********************************************************************
41279 
41280 C...PYONIA
41281 C...Generates Upsilon and toponium decays into three gluons
41282 C...or two gluons and a photon.
41283 
41284  SUBROUTINE pyonia(KFL,ECM)
41285 
41286 C...Double precision and integer declarations.
41287  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41288  INTEGER pyk,pychge,pycomp
41289 C...Commonblocks.
41290  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
41291  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41292  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41293  SAVE /pyjets/,/pydat1/,/pydat2/
41294 
41295 C...Printout. Check input parameters.
41296  IF(mstu(12).GE.1) CALL pylist(0)
41297  IF(kfl.LT.0.OR.kfl.GT.8) THEN
41298  CALL pyerrm(16,'(PYONIA:) called with unknown flavour code')
41299  IF(mstu(21).GE.1) RETURN
41300  ENDIF
41301  IF(ecm.LT.parj(127)+2.02d0*parf(101)) THEN
41302  CALL pyerrm(16,'(PYONIA:) called with too small CM energy')
41303  IF(mstu(21).GE.1) RETURN
41304  ENDIF
41305 
41306 C...Initial e+e- and onium state (optional).
41307  nc=0
41308  IF(mstj(115).GE.2) THEN
41309  nc=nc+2
41310  CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
41311  k(nc-1,1)=21
41312  CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
41313  k(nc,1)=21
41314  ENDIF
41315  kflc=iabs(kfl)
41316  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
41317  nc=nc+1
41318  kf=110*kflc+3
41319  mstu10=mstu(10)
41320  mstu(10)=1
41321  p(nc,5)=ecm
41322  CALL py1ent(nc,kf,ecm,0d0,0d0)
41323  k(nc,1)=21
41324  k(nc,3)=1
41325  mstu(10)=mstu10
41326  ENDIF
41327 
41328 C...Choose x1 and x2 according to matrix element.
41329  ntry=0
41330  100 x1=pyr(0)
41331  x2=pyr(0)
41332  x3=2d0-x1-x2
41333  IF(x3.GE.1d0.OR.((1d0-x1)/(x2*x3))**2+((1d0-x2)/(x1*x3))**2+
41334  &((1d0-x3)/(x1*x2))**2.LE.2d0*pyr(0)) goto 100
41335  ntry=ntry+1
41336  njet=3
41337  IF(mstj(101).LE.4) CALL py3ent(nc+1,21,21,21,ecm,x1,x3)
41338  IF(mstj(101).GE.5) CALL py3ent(-(nc+1),21,21,21,ecm,x1,x3)
41339 
41340 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
41341  mstu(111)=mstj(108)
41342  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
41343  &mstu(111)=1
41344  paru(112)=parj(121)
41345  IF(mstu(111).EQ.2) paru(112)=parj(122)
41346  qf=0d0
41347  IF(kflc.NE.0) qf=kchg(kflc,1)/3d0
41348  rgam=7.2d0*qf**2*paru(101)/pyalps(ecm**2)
41349  mk=0
41350  ecmc=ecm
41351  IF(pyr(0).GT.rgam/(1d0+rgam)) THEN
41352  IF(1d0-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
41353  & njet=2
41354  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL py2ent(nc+1,21,21,ecm)
41355  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL py2ent(-(nc+1),21,21,ecm)
41356  ELSE
41357  mk=1
41358  ecmc=sqrt(1d0-x1)*ecm
41359  IF(ecmc.LT.2d0*parj(127)) goto 100
41360  k(nc+1,1)=1
41361  k(nc+1,2)=22
41362  k(nc+1,4)=0
41363  k(nc+1,5)=0
41364  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
41365  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
41366  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
41367  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
41368  njet=2
41369  IF(ecmc.LT.4d0*parj(127)) THEN
41370  mstu10=mstu(10)
41371  mstu(10)=1
41372  p(nc+2,5)=ecmc
41373  CALL py1ent(nc+2,83,0.5d0*(x2+x3)*ecm,paru(1),0d0)
41374  mstu(10)=mstu10
41375  njet=0
41376  ENDIF
41377  ENDIF
41378  DO 110 ip=nc+1,n
41379  k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
41380  110 CONTINUE
41381 
41382 C...Differential cross-sections. Upper limit for cross-section.
41383  IF(mstj(106).EQ.1) THEN
41384  sq2=sqrt(2d0)
41385  hf1=1d0-parj(131)*parj(132)
41386  hf3=parj(133)**2
41387  ct13=(x1*x3-2d0*x1-2d0*x3+2d0)/(x1*x3)
41388  st13=sqrt(1d0-ct13**2)
41389  sigl=0.5d0*x3**2*((1d0-x2)**2+(1d0-x3)**2)*st13**2
41390  sigu=(x1*(1d0-x1))**2+(x2*(1d0-x2))**2+(x3*(1d0-x3))**2-sigl
41391  sigt=0.5d0*sigl
41392  sigi=(sigl*ct13/st13+0.5d0*x1*x3*(1d0-x2)**2*st13)/sq2
41393  sigmax=(2d0*hf1+hf3)*abs(sigu)+2d0*(hf1+hf3)*abs(sigl)+2d0*(hf1+
41394  & 2d0*hf3)*abs(sigt)+2d0*sq2*(hf1+2d0*hf3)*abs(sigi)
41395 
41396 C...Angular orientation of event.
41397  120 chi=paru(2)*pyr(0)
41398  cthe=2d0*pyr(0)-1d0
41399  phi=paru(2)*pyr(0)
41400  cchi=cos(chi)
41401  schi=sin(chi)
41402  c2chi=cos(2d0*chi)
41403  s2chi=sin(2d0*chi)
41404  the=acos(cthe)
41405  sthe=sin(the)
41406  c2phi=cos(2d0*(phi-parj(134)))
41407  s2phi=sin(2d0*(phi-parj(134)))
41408  sig=((1d0+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2d0*(sthe**2*hf1-
41409  & sthe**2*c2phi*hf3)*sigl+2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*
41410  & c2chi*c2phi-2d0*cthe*s2chi*s2phi)*hf3)*sigt-
41411  & 2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*
41412  & (cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
41413  IF(sig.LT.sigmax*pyr(0)) goto 120
41414  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
41415  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
41416  ENDIF
41417 
41418 C...Generate parton shower. Rearrange along strings and check.
41419  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
41420  CALL pyshow(nc+mk+1,-njet,ecmc)
41421  mstj14=mstj(14)
41422  IF(mstj(105).EQ.-1) mstj(14)=-1
41423  IF(mstj(105).GE.0) mstu(28)=0
41424  CALL pyprep(0)
41425  mstj(14)=mstj14
41426  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
41427  ENDIF
41428 
41429 C...Generate fragmentation. Information for PYTABU:
41430  IF(mstj(105).EQ.1) CALL pyexec
41431  mstu(161)=110*kflc+3
41432  mstu(162)=0
41433 
41434  RETURN
41435  END
41436 
41437 C*********************************************************************
41438 
41439 C...PYBOOK
41440 C...Books a histogram.
41441 
41442  SUBROUTINE pybook(ID,TITLE,NX,XL,XU)
41443 
41444 C...Double precision declaration.
41445  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41446 C...Commonblock.
41447  common/pybins/ihist(4),indx(1000),bin(20000)
41448  SAVE /pybins/
41449 C...Local character variables.
41450  CHARACTER title*(*), titfx*60
41451 
41452 C...Check that input is sensible. Find initial address in memory.
41453  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
41454  &'(PYBOOK:) not allowed histogram number')
41455  IF(nx.LE.0.OR.nx.GT.100) CALL pyerrm(28,
41456  &'(PYBOOK:) not allowed number of bins')
41457  IF(xl.GE.xu) CALL pyerrm(28,
41458  &'(PYBOOK:) x limits in wrong order')
41459  indx(id)=ihist(4)
41460  ihist(4)=ihist(4)+28+nx
41461  IF(ihist(4).GT.ihist(2)) CALL pyerrm(28,
41462  &'(PYBOOK:) out of histogram space')
41463  is=indx(id)
41464 
41465 C...Store histogram size and reset contents.
41466  bin(is+1)=nx
41467  bin(is+2)=xl
41468  bin(is+3)=xu
41469  bin(is+4)=(xu-xl)/nx
41470  CALL pynull(id)
41471 
41472 C...Store title by conversion to integer to double precision.
41473  titfx=title//' '
41474  DO 100 it=1,20
41475  bin(is+8+nx+it)=256**2*ichar(titfx(3*it-2:3*it-2))+
41476  & 256*ichar(titfx(3*it-1:3*it-1))+ichar(titfx(3*it:3*it))
41477  100 CONTINUE
41478 
41479  RETURN
41480  END
41481 
41482 C*********************************************************************
41483 
41484 C...PYFILL
41485 C...Fills entry in histogram.
41486 
41487  SUBROUTINE pyfill(ID,X,W)
41488 
41489 C...Double precision declaration.
41490  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41491 C...Commonblock.
41492  common/pybins/ihist(4),indx(1000),bin(20000)
41493  SAVE /pybins/
41494 
41495 C...Find initial address in memory. Increase number of entries.
41496  is=indx(id)
41497  bin(is+5)=bin(is+5)+1d0
41498 
41499 C...Find bin in x, including under/overflow, and fill.
41500  IF(x.LT.bin(is+2)) THEN
41501  bin(is+6)=bin(is+6)+w
41502  ELSEIF(x.GE.bin(is+3)) THEN
41503  bin(is+8)=bin(is+8)+w
41504  ELSE
41505  bin(is+7)=bin(is+7)+w
41506  ix=(x-bin(is+2))/bin(is+4)
41507  ix=max(0,min(nint(bin(is+1))-1,ix))
41508  bin(is+9+ix)=bin(is+9+ix)+w
41509  ENDIF
41510 
41511  RETURN
41512  END
41513 
41514 C*********************************************************************
41515 
41516 C...PYFACT
41517 C...Multiplies histogram contents by factor.
41518 
41519  SUBROUTINE pyfact(ID,F)
41520 
41521 C...Double precision declaration.
41522  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41523 C...Commonblock.
41524  common/pybins/ihist(4),indx(1000),bin(20000)
41525  SAVE /pybins/
41526 
41527 C...Find initial address in memory. Multiply all contents bins.
41528  is=indx(id)
41529  DO 100 ix=is+6,is+8+nint(bin(is+1))
41530  bin(ix)=f*bin(ix)
41531  100 CONTINUE
41532 
41533  RETURN
41534  END
41535 
41536 C*********************************************************************
41537 
41538 C...PYOPER
41539 C...Performs operations between histograms.
41540 
41541  SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)
41542 
41543 C...Double precision declaration.
41544  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41545 C...Commonblock.
41546  common/pybins/ihist(4),indx(1000),bin(20000)
41547  SAVE /pybins/
41548 C...Character variable.
41549  CHARACTER oper*(*)
41550 
41551 C...Find initial addresses in memory, and histogram size.
41552  is1=indx(id1)
41553  is2=indx(min(ihist(1),max(1,id2)))
41554  is3=indx(min(ihist(1),max(1,id3)))
41555  nx=nint(bin(is3+1))
41556  IF(oper.EQ.'M'.AND.id3.EQ.0) nx=nint(bin(is2+1))
41557 
41558 C...Update info on number of histogram entries.
41559  IF(oper.EQ.'+'.OR.oper.EQ.'-'.OR.oper.EQ.'*'.OR.oper.EQ.'/') THEN
41560  bin(is3+5)=bin(is1+5)+bin(is2+5)
41561  ELSEIF(oper.EQ.'A'.OR.oper.EQ.'S'.OR.oper.EQ.'L') THEN
41562  bin(is3+5)=bin(is1+5)
41563  ENDIF
41564 
41565 C...Operations on pair of histograms: addition, subtraction,
41566 C...multiplication, division.
41567  IF(oper.EQ.'+') THEN
41568  DO 100 ix=6,8+nx
41569  bin(is3+ix)=f1*bin(is1+ix)+f2*bin(is2+ix)
41570  100 CONTINUE
41571  ELSEIF(oper.EQ.'-') THEN
41572  DO 110 ix=6,8+nx
41573  bin(is3+ix)=f1*bin(is1+ix)-f2*bin(is2+ix)
41574  110 CONTINUE
41575  ELSEIF(oper.EQ.'*') THEN
41576  DO 120 ix=6,8+nx
41577  bin(is3+ix)=f1*bin(is1+ix)*f2*bin(is2+ix)
41578  120 CONTINUE
41579  ELSEIF(oper.EQ.'/') THEN
41580  DO 130 ix=6,8+nx
41581  fa2=f2*bin(is2+ix)
41582  IF(abs(fa2).LE.1d-20) THEN
41583  bin(is3+ix)=0d0
41584  ELSE
41585  bin(is3+ix)=f1*bin(is1+ix)/fa2
41586  ENDIF
41587  130 CONTINUE
41588 
41589 C...Operations on single histogram: multiplication+addition,
41590 C...square root+addition, logarithm+addition.
41591  ELSEIF(oper.EQ.'A') THEN
41592  DO 140 ix=6,8+nx
41593  bin(is3+ix)=f1*bin(is1+ix)+f2
41594  140 CONTINUE
41595  ELSEIF(oper.EQ.'S') THEN
41596  DO 150 ix=6,8+nx
41597  bin(is3+ix)=f1*sqrt(max(0d0,bin(is1+ix)))+f2
41598  150 CONTINUE
41599  ELSEIF(oper.EQ.'L') THEN
41600  zmin=1d20
41601  DO 160 ix=9,8+nx
41602  IF(bin(is1+ix).LT.zmin.AND.bin(is1+ix).GT.1d-20)
41603  & zmin=0.8d0*bin(is1+ix)
41604  160 CONTINUE
41605  DO 170 ix=6,8+nx
41606  bin(is3+ix)=f1*log10(max(zmin,bin(is1+ix)))+f2
41607  170 CONTINUE
41608 
41609 C...Operation on two or three histograms: average and
41610 C...standard deviation.
41611  ELSEIF(oper.EQ.'M') THEN
41612  DO 180 ix=6,8+nx
41613  IF(abs(bin(is1+ix)).LE.1d-20) THEN
41614  bin(is2+ix)=0d0
41615  ELSE
41616  bin(is2+ix)=bin(is2+ix)/bin(is1+ix)
41617  ENDIF
41618  IF(id3.NE.0) THEN
41619  IF(abs(bin(is1+ix)).LE.1d-20) THEN
41620  bin(is3+ix)=0d0
41621  ELSE
41622  bin(is3+ix)=sqrt(max(0d0,bin(is3+ix)/bin(is1+ix)-
41623  & bin(is2+ix)**2))
41624  ENDIF
41625  ENDIF
41626  bin(is1+ix)=f1*bin(is1+ix)
41627  180 CONTINUE
41628  ENDIF
41629 
41630  RETURN
41631  END
41632 
41633 C*********************************************************************
41634 
41635 C...PYHIST
41636 C...Prints and resets all histograms.
41637 
41638  SUBROUTINE pyhist
41639 
41640 C...Double precision declaration.
41641  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41642 C...Commonblock.
41643  common/pybins/ihist(4),indx(1000),bin(20000)
41644  SAVE /pybins/
41645 
41646 C...Loop over histograms, print and reset used ones.
41647  DO 100 id=1,ihist(1)
41648  is=indx(id)
41649  IF(is.NE.0.AND.nint(bin(is+5)).GT.0) THEN
41650  CALL pyplot(id)
41651  CALL pynull(id)
41652  ENDIF
41653  100 CONTINUE
41654 
41655  RETURN
41656  END
41657 
41658 C*********************************************************************
41659 
41660 C...PYPLOT
41661 C...Prints a histogram (but does not reset it).
41662 
41663  SUBROUTINE pyplot(ID)
41664 
41665 C...Double precision declaration.
41666  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41667 C...Commonblocks.
41668  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41669  common/pybins/ihist(4),indx(1000),bin(20000)
41670  SAVE /pydat1/,/pybins/
41671 C...Local arrays and character variables.
41672  dimension idati(6), irow(100), ifra(100), dyac(10)
41673  CHARACTER title*60, out*100, cha(0:11)*1
41674 
41675 C...Steps in histogram scale. Character sequence.
41676  DATA dyac/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
41677  DATA cha/'0','1','2','3','4','5','6','7','8','9','X','-'/
41678 
41679 C...Find initial address in memory; skip if empty histogram.
41680  is=indx(id)
41681  IF(nint(bin(is+5)).LE.0) THEN
41682  WRITE(mstu(11),5000) id
41683  RETURN
41684  ENDIF
41685 
41686 C...Number of histogram lines and x bins.
41687  lin=ihist(3)-18
41688  nx=nint(bin(is+1))
41689 
41690 C...Extract title by conversion from double precision via integer.
41691  DO 100 it=1,20
41692  ieq=nint(bin(is+8+nx+it))
41693  title(3*it-2:3*it)=char(ieq/256**2)//char(mod(ieq,256**2)/256)
41694  & //char(mod(ieq,256))
41695  100 CONTINUE
41696 
41697 C...Find time; print title.
41698  CALL pytime(idati)
41699  IF(idati(1).GT.0) THEN
41700  WRITE(mstu(11),5100) id, title, (idati(j),j=1,5)
41701  ELSE
41702  WRITE(mstu(11),5200) id, title
41703  ENDIF
41704 
41705 C...Find minimum and maximum bin content.
41706  ymin=bin(is+9)
41707  ymax=bin(is+9)
41708  DO 110 ix=is+10,is+8+nx
41709  IF(bin(ix).LT.ymin) ymin=bin(ix)
41710  IF(bin(ix).GT.ymax) ymax=bin(ix)
41711  110 CONTINUE
41712 
41713 C...Determine scale and step size for y axis.
41714  IF(ymax-ymin.GT.lin*dyac(1)*1d-9) THEN
41715  IF(ymin.GT.0d0.AND.ymin.LT.0.1d0*ymax) ymin=0d0
41716  IF(ymax.LT.0d0.AND.ymax.GT.0.1d0*ymin) ymax=0d0
41717  ipot=int(log10(ymax-ymin)+10d0)-10
41718  IF(ymax-ymin.LT.lin*dyac(1)*10d0**ipot) ipot=ipot-1
41719  IF(ymax-ymin.GT.lin*dyac(10)*10d0**ipot) ipot=ipot+1
41720  dely=dyac(1)
41721  DO 120 idel=1,9
41722  IF(ymax-ymin.GE.lin*dyac(idel)*10d0**ipot) dely=dyac(idel+1)
41723  120 CONTINUE
41724  dy=dely*10d0**ipot
41725 
41726 C...Convert bin contents to integer form; fractional fill in top row.
41727  DO 130 ix=1,nx
41728  cta=abs(bin(is+8+ix))/dy
41729  irow(ix)=sign(cta+0.95d0,bin(is+8+ix))
41730  ifra(ix)=10d0*(cta+1.05d0-dble(int(cta+0.95d0)))
41731  130 CONTINUE
41732  irmi=sign(abs(ymin)/dy+0.95d0,ymin)
41733  irma=sign(abs(ymax)/dy+0.95d0,ymax)
41734 
41735 C...Print histogram row by row.
41736  DO 150 ir=irma,irmi,-1
41737  IF(ir.EQ.0) goto 150
41738  out=' '
41739  DO 140 ix=1,nx
41740  IF(ir.EQ.irow(ix)) out(ix:ix)=cha(ifra(ix))
41741  IF(ir*(irow(ix)-ir).GT.0) out(ix:ix)=cha(10)
41742  140 CONTINUE
41743  WRITE(mstu(11),5300) ir*dely, ipot, out
41744  150 CONTINUE
41745 
41746 C...Print sign and value of bin contents.
41747  ipot=int(log10(max(ymax,-ymin))+10.0001d0)-10
41748  out=' '
41749  DO 160 ix=1,nx
41750  IF(bin(is+8+ix).LT.-10d0**(ipot-4)) out(ix:ix)=cha(11)
41751  irow(ix)=nint(10d0**(3-ipot)*abs(bin(is+8+ix)))
41752  160 CONTINUE
41753  WRITE(mstu(11),5400) out
41754  DO 180 ir=4,1,-1
41755  DO 170 ix=1,nx
41756  out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
41757  170 CONTINUE
41758  WRITE(mstu(11),5500) ipot+ir-4, out
41759  180 CONTINUE
41760 
41761 C...Print sign and value of lower bin edge.
41762  ipot=int(log10(max(-bin(is+2),bin(is+3)-bin(is+4)))+
41763  & 10.0001d0)-10
41764  out=' '
41765  DO 190 ix=1,nx
41766  IF(bin(is+2)+(ix-1)*bin(is+4).LT.-10d0**(ipot-3))
41767  & out(ix:ix)=cha(11)
41768  irow(ix)=nint(10d0**(2-ipot)*abs(bin(is+2)+(ix-1)*bin(is+4)))
41769  190 CONTINUE
41770  WRITE(mstu(11),5600) out
41771  DO 210 ir=3,1,-1
41772  DO 200 ix=1,nx
41773  out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
41774  200 CONTINUE
41775  WRITE(mstu(11),5500) ipot+ir-3, out
41776  210 CONTINUE
41777  ENDIF
41778 
41779 C...Calculate and print statistics.
41780  csum=0d0
41781  cxsum=0d0
41782  cxxsum=0d0
41783  DO 220 ix=1,nx
41784  cta=abs(bin(is+8+ix))
41785  x=bin(is+2)+(ix-0.5d0)*bin(is+4)
41786  csum=csum+cta
41787  cxsum=cxsum+cta*x
41788  cxxsum=cxxsum+cta*x**2
41789  220 CONTINUE
41790  xmean=cxsum/max(csum,1d-20)
41791  xrms=sqrt(max(0d0,cxxsum/max(csum,1d-20)-xmean**2))
41792  WRITE(mstu(11),5700) nint(bin(is+5)),xmean,bin(is+6),
41793  &bin(is+2),bin(is+7),xrms,bin(is+8),bin(is+3)
41794 
41795 C...Formats for output.
41796  5000 FORMAT(/5x,'Histogram no',i5,' : no entries')
41797  5100 FORMAT('1'/5x,'Histogram no',i5,6x,a60,5x,i4,'-',i2,'-',i2,1x,
41798  &i2,':',i2/)
41799  5200 FORMAT('1'/5x,'Histogram no',i5,6x,a60/)
41800  5300 FORMAT(2x,f7.2,'*10**',i2,3x,a100)
41801  5400 FORMAT(/8x,'Contents',3x,a100)
41802  5500 FORMAT(9x,'*10**',i2,3x,a100)
41803  5600 FORMAT(/8x,'Low edge',3x,a100)
41804  5700 FORMAT(/5x,'Entries =',i12,1p,6x,'Mean =',d12.4,6x,'Underflow ='
41805  &,d12.4,6x,'Low edge =',d12.4/5x,'All chan =',d12.4,6x,
41806  &'Rms =',d12.4,6x,'Overflow =',d12.4,6x,'High edge =',d12.4)
41807 
41808  RETURN
41809  END
41810 
41811 C*********************************************************************
41812 
41813 C...PYNULL
41814 C...Resets bin contents of a histogram.
41815 
41816  SUBROUTINE pynull(ID)
41817 
41818 C...Double precision declaration.
41819  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41820 C...Commonblock.
41821  common/pybins/ihist(4),indx(1000),bin(20000)
41822  SAVE /pybins/
41823 
41824  is=indx(id)
41825  DO 100 ix=is+5,is+8+nint(bin(is+1))
41826  bin(ix)=0d0
41827  100 CONTINUE
41828 
41829  RETURN
41830  END
41831 
41832 C*********************************************************************
41833 
41834 C...PYDUMP
41835 C...Dumps histogram contents on file for reading by other program.
41836 C...Can also read back own dump.
41837 
41838  SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)
41839 
41840 C...Double precision declaration.
41841  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41842 C...Commonblock.
41843  common/pybins/ihist(4),indx(1000),bin(20000)
41844  SAVE /pybins/
41845 C...Local arrays and character variables.
41846  dimension ihi(*),iss(100),val(5)
41847  CHARACTER title*60,format*13
41848 
41849 C...Dump all histograms that have been booked,
41850 C...including titles and ranges, one after the other.
41851  IF(mdump.EQ.1) THEN
41852 
41853 C...Loop over histograms and find which are wanted and booked.
41854  IF(nhi.LE.0) THEN
41855  nw=ihist(1)
41856  ELSE
41857  nw=nhi
41858  ENDIF
41859  DO 130 iw=1,nw
41860  IF(nhi.EQ.0) THEN
41861  id=iw
41862  ELSE
41863  id=ihi(iw)
41864  ENDIF
41865  is=indx(id)
41866  IF(is.NE.0) THEN
41867 
41868 C...Write title and histogram size.
41869  nx=nint(bin(is+1))
41870  DO 100 it=1,20
41871  ieq=nint(bin(is+8+nx+it))
41872  title(3*it-2:3*it)=char(ieq/256**2)//
41873  & char(mod(ieq,256**2)/256)//char(mod(ieq,256))
41874  100 CONTINUE
41875  WRITE(lfn,5100) id,title
41876  WRITE(lfn,5200) nx,bin(is+2),bin(is+3)
41877 
41878 C...Write histogram contents, in groups of five.
41879  DO 120 ixg=1,(nx+4)/5
41880  DO 110 ixv=1,5
41881  ix=5*ixg+ixv-5
41882  IF(ix.LE.nx) THEN
41883  val(ixv)=bin(is+8+ix)
41884  ELSE
41885  val(ixv)=0d0
41886  ENDIF
41887  110 CONTINUE
41888  WRITE(lfn,5300) (val(ixv),ixv=1,5)
41889  120 CONTINUE
41890 
41891 C...Go to next histogram; finish.
41892  ELSEIF(nhi.GT.0) THEN
41893  CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
41894  ENDIF
41895  130 CONTINUE
41896 
41897 C...Read back in histograms dumped MDUMP=1.
41898  ELSEIF(mdump.EQ.2) THEN
41899 
41900 C...Read histogram number, title and range, and book.
41901  140 READ(lfn,5100,end=170) id,title
41902  READ(lfn,5200) nx,xl,xu
41903  CALL pybook(id,title,nx,xl,xu)
41904  is=indx(id)
41905 
41906 C...Read histogram contents, in groups of five.
41907  DO 160 ixg=1,(nx+4)/5
41908  READ(lfn,5300) (val(ixv),ixv=1,5)
41909  DO 150 ixv=1,5
41910  ix=5*ixg+ixv-5
41911  IF(ix.LE.nx) bin(is+8+ix)=val(ixv)
41912  150 CONTINUE
41913  160 CONTINUE
41914 
41915 C...Go to next histogram; finish.
41916  goto 140
41917  170 CONTINUE
41918 
41919 C...Write histogram contents in column format,
41920 C...convenient e.g. for GNUPLOT input.
41921  ELSEIF(mdump.EQ.3) THEN
41922 
41923 C...Find addresses to wanted histograms.
41924  nss=0
41925  IF(nhi.LE.0) THEN
41926  nw=ihist(1)
41927  ELSE
41928  nw=nhi
41929  ENDIF
41930  DO 180 iw=1,nw
41931  IF(nhi.EQ.0) THEN
41932  id=iw
41933  ELSE
41934  id=ihi(iw)
41935  ENDIF
41936  is=indx(id)
41937  IF(is.NE.0.AND.nss.LT.100) THEN
41938  nss=nss+1
41939  iss(nss)=is
41940  ELSEIF(nss.GE.100) THEN
41941  CALL pyerrm(8,'(PYDUMP:) too many histograms requested')
41942  ELSEIF(nhi.GT.0) THEN
41943  CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
41944  ENDIF
41945  180 CONTINUE
41946 
41947 C...Check that they have common number of x bins. Fix format.
41948  nx=nint(bin(iss(1)+1))
41949  DO 190 iw=2,nss
41950  IF(nint(bin(iss(iw)+1)).NE.nx) THEN
41951  CALL pyerrm(8,'(PYDUMP:) different number of bins')
41952  RETURN
41953  ENDIF
41954  190 CONTINUE
41955  format='(1P,000D12.4)'
41956  WRITE(FORMAT(5:7),'(I3)') nss+1
41957 
41958 C...Write histogram contents; first column x values.
41959  DO 200 ix=1,nx
41960  x=bin(iss(1)+2)+(ix-0.5d0)*bin(iss(1)+4)
41961  WRITE(lfn,format) x, (bin(iss(iw)+8+ix),iw=1,nss)
41962  200 CONTINUE
41963 
41964  ENDIF
41965 
41966 C...Formats for output.
41967  5100 FORMAT(i5,5x,a60)
41968  5200 FORMAT(i5,1p,2d12.4)
41969  5300 FORMAT(1p,5d12.4)
41970 
41971  RETURN
41972  END
41973 
41974 C*********************************************************************
41975 
41976 C...PYKCUT
41977 C...Dummy routine, which the user can replace in order to make cuts on
41978 C...the kinematics on the parton level before the matrix elements are
41979 C...evaluated and the event is generated. The cross-section estimates
41980 C...will automatically take these cuts into account, so the given
41981 C...values are for the allowed phase space region only. MCUT=0 means
41982 C...that the event has passed the cuts, MCUT=1 that it has failed.
41983 
41984  SUBROUTINE pykcut(MCUT)
41985 
41986 C...Double precision and integer declarations.
41987  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41988  INTEGER pyk,pychge,pycomp
41989 C...Commonblocks.
41990  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41991  common/pyint1/mint(400),vint(400)
41992  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
41993  SAVE /pydat1/,/pyint1/,/pyint2/
41994 
41995 C...Set default value (accepting event) for MCUT.
41996  mcut=0
41997 
41998 C...Read out subprocess number.
41999  isub=mint(1)
42000  istsb=iset(isub)
42001 
42002 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
42003  tau=vint(21)
42004  yst=vint(22)
42005  cth=0d0
42006  IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
42007  taup=0d0
42008  IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
42009 
42010 C...Calculate x_1, x_2, x_F.
42011  IF(istsb.LE.2.OR.istsb.GE.5) THEN
42012  x1=sqrt(tau)*exp(yst)
42013  x2=sqrt(tau)*exp(-yst)
42014  ELSE
42015  x1=sqrt(taup)*exp(yst)
42016  x2=sqrt(taup)*exp(-yst)
42017  ENDIF
42018  xf=x1-x2
42019 
42020 C...Calculate shat, that, uhat, p_T^2.
42021  shat=tau*vint(2)
42022  sqm3=vint(63)
42023  sqm4=vint(64)
42024  rm3=sqm3/shat
42025  rm4=sqm4/shat
42026  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
42027  rpts=4d0*vint(71)**2/shat
42028  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
42029  rm34=2d0*rm3*rm4
42030  rsqm=1d0+rm34
42031  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
42032  that=-0.5d0*shat*max(rthm,1d0-rm3-rm4-be34*cth)
42033  uhat=-0.5d0*shat*max(rthm,1d0-rm3-rm4+be34*cth)
42034  pt2=max(vint(71)**2,0.25d0*shat*be34**2*(1d0-cth**2))
42035 
42036 C...Decisions by user to be put here.
42037 
42038 C...Stop program if this routine is ever called.
42039 C...You should not copy these lines to your own routine.
42040  WRITE(mstu(11),5000)
42041  IF(pyr(0).LT.10d0) stop
42042 
42043 C...Format for error printout.
42044  5000 FORMAT(1x,'Error: you did not link your PYKCUT routine ',
42045  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
42046  &1x,'Execution stopped!')
42047 
42048  RETURN
42049  END
42050 
42051 C*********************************************************************
42052 
42053 C...PYEVWT
42054 C...Dummy routine, which the user can replace in order to multiply the
42055 C...standard PYTHIA differential cross-section by a process- and
42056 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
42057 C...to generation of weighted events, with weight 1/WTXS, while for
42058 C...MSTP(142)=2 it corresponds to a modification of the underlying
42059 C...physics.
42060 
42061  SUBROUTINE pyevwt(WTXS)
42062 
42063 C...Double precision and integer declarations.
42064  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42065  INTEGER pyk,pychge,pycomp
42066 C...Commonblocks.
42067  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42068  common/pyint1/mint(400),vint(400)
42069  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
42070  SAVE /pydat1/,/pyint1/,/pyint2/
42071 
42072 C...Set default weight for WTXS.
42073  wtxs=1d0
42074 
42075 C...Read out subprocess number.
42076  isub=mint(1)
42077  istsb=iset(isub)
42078 
42079 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
42080  tau=vint(21)
42081  yst=vint(22)
42082  cth=0d0
42083  IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
42084  taup=0d0
42085  IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
42086 
42087 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
42088  x1=vint(41)
42089  x2=vint(42)
42090  xf=x1-x2
42091  shat=vint(44)
42092  that=vint(45)
42093  uhat=vint(46)
42094  pt2=vint(48)
42095 
42096 C...Modifications by user to be put here.
42097 
42098 C...Stop program if this routine is ever called.
42099 C...You should not copy these lines to your own routine.
42100  WRITE(mstu(11),5000)
42101  IF(pyr(0).LT.10d0) stop
42102 
42103 C...Format for error printout.
42104  5000 FORMAT(1x,'Error: you did not link your PYEVWT routine ',
42105  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
42106  &1x,'Execution stopped!')
42107 
42108  RETURN
42109  END
42110 
42111 C*********************************************************************
42112 
42113 C...PYUPIN
42114 C...Dummy copy of routine to be called by user to set up a user-defined
42115 C...process.
42116 
42117  SUBROUTINE pyupin(ISUB,TITLE,SIGMAX)
42118 
42119 C...Double precision and integer declarations.
42120  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42121  INTEGER pyk,pychge,pycomp
42122 C...Commonblocks.
42123  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42124  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
42125  common/pyint6/proc(0:500)
42126  CHARACTER proc*28
42127  SAVE /pydat1/,/pyint2/,/pyint6/
42128 C...Local character variable.
42129  CHARACTER*(*) title
42130 
42131 C...Check that subprocess number free.
42132  IF(isub.LT.1.OR.isub.GT.200.OR.iset(isub).GE.0) THEN
42133  WRITE(mstu(11),5000) isub
42134  stop
42135  ENDIF
42136 
42137 C...Fill information on new process.
42138  iset(isub)=11
42139  coef(isub,1)=sigmax
42140  proc(isub)=title//' '
42141 
42142 C...Format for error output.
42143  5000 FORMAT(1x,'Error: user-defined subprocess code ',i4,
42144  &' not allowed.'//1x,'Execution stopped!')
42145 
42146  RETURN
42147  END
42148 
42149 C*********************************************************************
42150 
42151 C...PYUPEV
42152 C...Dummy routine, to be replaced by user. When called from PYTHIA
42153 C...the subprocess number ISUB will be given, and PYUPEV is supposed
42154 C...to generate an event of this type, to be stored in the PYUPPR
42155 C...commonblock. SIGEV gives the differential cross-section associated
42156 C...with the event, i.e. the acceptance probability of the event is
42157 C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
42158 C...call.
42159 
42160  SUBROUTINE pyupev(ISUB,SIGEV)
42161 
42162 C...Double precision and integer declarations.
42163  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42164  INTEGER pyk,pychge,pycomp
42165 C...Commonblocks.
42166  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42167  common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)
42168  SAVE /pydat1/,/pyuppr/
42169 
42170 C...Stop program if this routine is ever called.
42171 C...You should not copy these lines to your own routine.
42172  WRITE(mstu(11),5000)
42173  IF(pyr(0).LT.10d0) stop
42174  sigev=isub
42175 
42176 C...Format for error printout.
42177  5000 FORMAT(1x,'Error: you did not link your PYUPEV routine ',
42178  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
42179  &1x,'Execution stopped!')
42180 
42181  RETURN
42182  END
42183 
42184 C*********************************************************************
42185 
42186 C...PDFSET
42187 C...Dummy routine, to be removed when PDFLIB is to be linked.
42188 
42189  SUBROUTINE pdfset(PARM,VALUE)
42190 
42191 C...Double precision and integer declarations.
42192  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42193  INTEGER pyk,pychge,pycomp
42194 C...Commonblocks.
42195  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42196  SAVE /pydat1/
42197 C...Local arrays and character variables.
42198  CHARACTER*20 parm(20)
42199  DOUBLE PRECISION value(20)
42200 
42201 C...Stop program if this routine is ever called.
42202  WRITE(mstu(11),5000)
42203  IF(pyr(0).LT.10d0) stop
42204  parm(20)=parm(1)
42205  value(20)=value(1)
42206 
42207 C...Format for error printout.
42208  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
42209  &1x,'Dummy routine PDFSET in PYTHIA file called instead.'/
42210  &1x,'Execution stopped!')
42211 
42212  RETURN
42213  END
42214 
42215 C*********************************************************************
42216 
42217 C...STRUCTM
42218 C...Dummy routine, to be removed when PDFLIB is to be linked.
42219 
42220  SUBROUTINE structm(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
42221 
42222 C...Double precision and integer declarations.
42223  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42224  INTEGER pyk,pychge,pycomp
42225 C...Commonblocks.
42226  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42227  SAVE /pydat1/
42228 C...Local variables
42229  DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu
42230 
42231 C...Stop program if this routine is ever called.
42232  WRITE(mstu(11),5000)
42233  IF(pyr(0).LT.10d0) stop
42234  upv=xx+qq
42235  dnv=xx+2d0*qq
42236  usea=xx+3d0*qq
42237  dsea=xx+4d0*qq
42238  str=xx+5d0*qq
42239  chm=xx+6d0*qq
42240  bot=xx+7d0*qq
42241  top=xx+8d0*qq
42242  glu=xx+9d0*qq
42243 
42244 C...Format for error printout.
42245  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
42246  &1x,'Dummy routine STRUCTM in PYTHIA file called instead.'/
42247  &1x,'Execution stopped!')
42248 
42249  RETURN
42250  END
42251 
42252 C*********************************************************************
42253 
42254 C...PYTAUD
42255 C...Dummy routine, to be replaced by user, to handle the decay of a
42256 C...polarized tau lepton.
42257 C...Input:
42258 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
42259 C...IORIG is the position where the mother of the tau is stored;
42260 C... is 0 when the mother is not stored.
42261 C...KFORIG is the flavour of the mother of the tau;
42262 C... is 0 when the mother is not known.
42263 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
42264 C... e.g. in B hadron semileptonic decays the W propagator
42265 C... is not explicitly stored but the W code is still unambiguous.
42266 C...Output:
42267 C...NDECAY is the number of decay products in the current tau decay.
42268 C...These decay products should be added to the /PYJETS/ common block,
42269 C...in positions N+1 through N+NDECAY. For each product I you must
42270 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
42271 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
42272 
42273  SUBROUTINE pytaud(ITAU,IORIG,KFORIG,NDECAY)
42274 
42275 C...Double precision and integer declarations.
42276  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42277  INTEGER pyk,pychge,pycomp
42278 C...Commonblocks.
42279  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
42280  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42281  SAVE /pyjets/,/pydat1/
42282 
42283 C...Stop program if this routine is ever called.
42284 C...You should not copy these lines to your own routine.
42285  ndecay=itau+iorig+kforig
42286  WRITE(mstu(11),5000)
42287  IF(pyr(0).LT.10d0) stop
42288 
42289 C...Format for error printout.
42290  5000 FORMAT(1x,'Error: you did not link your PYTAUD routine ',
42291  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
42292  &1x,'Execution stopped!')
42293 
42294  RETURN
42295  END
42296 
42297 C*********************************************************************
42298 
42299 C...PYTIME
42300 C...Finds current date and time.
42301 C...Since this task is not standardized in Fortran 77, the routine
42302 C...is dummy, to be replaced by the user. Examples are given for
42303 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
42304 C...you do not have access to suitable routines.
42305 
42306  SUBROUTINE pytime(IDATI)
42307 
42308 C...Double precision and integer declarations.
42309  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42310  INTEGER pyk,pychge,pycomp
42311  CHARACTER*8 atime
42312 C...Local array.
42313  INTEGER idati(6),idtemp(3)
42314 
42315 C...Example 0: if you do not have suitable routines.
42316  DO 100 j=1,6
42317  idati(j)=0
42318  100 CONTINUE
42319 
42320 C...Example 1: Fortran 90 routine.
42321 C INTEGER IVAL(8)
42322 C CALL DATE_AND_TIME(VALUES=IVAL)
42323 C IDATI(1)=IVAL(1)
42324 C IDATI(2)=IVAL(2)
42325 C IDATI(3)=IVAL(3)
42326 C IDATI(4)=IVAL(5)
42327 C IDATI(5)=IVAL(6)
42328 C IDATI(6)=IVAL(7)
42329 
42330 C...Example 2: DEC Fortran 77.
42331 C CALL IDATE(IMON,IDAY,IYEAR)
42332 C IDATI(1)=1900+IYEAR
42333 C IDATI(2)=IMON
42334 C IDATI(3)=IDAY
42335 C CALL ITIME(IHOUR,IMIN,ISEC)
42336 C IDATI(4)=IHOUR
42337 C IDATI(5)=IMIN
42338 C IDATI(6)=ISEC
42339 
42340 C...Example 3: DEC Fortran
42341 C CALL IDATE(IMON,IDAY,IYEAR)
42342 C IDATI(1)=1900+IYEAR
42343 C IDATI(2)=IMON
42344 C IDATI(3)=IDAY
42345 C CALL TIME(ATIME)
42346 C IHOUR=0
42347 C IMIN=0
42348 C ISEC=0
42349 C READ(ATIME(1:2),'(I2)') IHOUR
42350 C READ(ATIME(4:5),'(I2)') IMIN
42351 C READ(ATIME(7:8),'(I2)') ISEC
42352 C IDATI(4)=IHOUR
42353 C IDATI(5)=IMIN
42354 C IDATI(6)=ISEC
42355 
42356 C...Example 4: GNU LINUX libU77.
42357 C CALL IDATE(IDTEMP)
42358 C IDATI(1)=IDTEMP(3)
42359 C IDATI(2)=IDTEMP(2)
42360 C IDATI(3)=IDTEMP(1)
42361 C CALL ITIME(IDTEMP)
42362 C IDATI(4)=IDTEMP(1)
42363 C IDATI(5)=IDTEMP(2)
42364 C IDATI(6)=IDTEMP(3)
42365 
42366  RETURN
42367  END
Generated on Sat May 25 2013 14:32:56 for Geant4 by   doxygen 1.8.4